From 3bd98556dd52d20384a7ae2f2e2a42c9b037d0ca Mon Sep 17 00:00:00 2001 From: Chunxi Zhang Date: Mon, 28 Jan 2019 17:06:09 -0600 Subject: [PATCH 01/15] Added the new Tiedtke cumulus, Shinhong, YSU PBL scheme cu_ntiedtke.F90 for the new Tiedtke cumulus scheme which include both deep and shallow cumulus shinhongvdif.F90 for the Shinhong scale-aware PBL scheme (saYSU) ysuvdif.F90 for YSU PBL scheme Modified GFS_PBL_generic.F90 to make these two PBLs work --- physics/GFS_PBL_generic.F90 | 14 +- physics/cu_ntiedtke.F90 | 3833 +++++++++++++++++++++++++++++++++++ physics/shinhongvdif.F90 | 2106 +++++++++++++++++++ physics/ysuvdif.F90 | 1271 ++++++++++++ 4 files changed, 7220 insertions(+), 4 deletions(-) create mode 100644 physics/cu_ntiedtke.F90 create mode 100644 physics/shinhongvdif.F90 create mode 100644 physics/ysuvdif.F90 diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 83e6cdc8b..3a4e2ec32 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -178,6 +178,8 @@ end subroutine GFS_PBL_generic_post_finalize !! | hybedmf | flag_for_hedmf | flag for hybrid edmf pbl scheme (moninedmf) | flag | 0 | logical | | in | F | !! | do_shoc | flag_for_shoc | flag for SHOC | flag | 0 | logical | | in | F | !! | satmedmf | flag_for_scale_aware_TKE_moist_EDMF_PBL | flag for scale-aware TKE moist EDMF PBL scheme | flag | 0 | logical | | in | F | +!! | shinhong | flag_for_scale_aware_Shinhong_PBL | flag for scale-aware Shinhong PBL scheme | flag | 0 | logical | | in | F | +!! | do_ysu | flag_for_ysu | flag for YSU PBL scheme | flag | 0 | logical | | in | F | !! | dvdftra | tendency_of_vertically_diffused_tracer_concentration | updated tendency of the tracers due to vertical diffusion in PBL scheme | kg kg-1 s-1 | 3 | real | kind_phys | in | F | !! | dusfc1 | instantaneous_surface_x_momentum_flux | surface momentum flux in the x-direction valid for current call | Pa | 1 | real | kind_phys | in | F | !! | dvsfc1 | instantaneous_surface_y_momentum_flux | surface momentum flux in the y-direction valid for current call | Pa | 1 | real | kind_phys | in | F | @@ -232,7 +234,7 @@ end subroutine GFS_PBL_generic_post_finalize #endif subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ntoz, ntke, ntkev, & imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_wsm6, ltaerosol, cplflx, lssav, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, & + imp_physics_wsm6, ltaerosol, cplflx, lssav, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, shinhong, do_ysu, & dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, & dqdt, dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice_cloud, dqdt_ozone, dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc, dqdt_rain, dqdt_snow, dqdt_graupel, dqdt_tke, & @@ -247,7 +249,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ntoz, ntke, ntkev, integer, intent(in) :: im, levs, nvdiff, ntrac, ntoz, ntke, ntkev integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 - logical, intent(in) :: ltaerosol, cplflx, lssav, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf + logical, intent(in) :: ltaerosol, cplflx, lssav, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, shinhong, do_ysu real(kind=kind_phys), intent(in) :: dtf real(kind=kind_phys), dimension(im, levs, nvdiff), intent(in) :: dvdftra @@ -271,9 +273,10 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ntoz, ntke, ntkev, errmsg = '' errflg = 0 !GJF: dvdftra is only used if nvdiff != ntrac or (nvdiff == ntrac .and. ) +! print*,"dqdt:",maxval(dqdt(:,:,1)),minval(dqdt(:,:,1)) if (nvdiff == ntrac .and. (hybedmf .or. do_shoc)) then dqdt = dvdftra - elseif (nvdiff /= ntrac) then + elseif (nvdiff /= ntrac .and. .not. shinhong .and. .not. do_ysu) then if (imp_physics == imp_physics_wsm6) then ! WSM6 do k=1,levs @@ -395,7 +398,8 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ntoz, ntke, ntkev, ! endif do k=1,levs do i=1,im - tem = dqdt_water_vapor(i,k) * dtf +! tem = dqdt_water_vapor(i,k) * dtf + tem = dqdt(i,k,1) * dtf dq3dt(i,k) = dq3dt(i,k) + tem enddo enddo @@ -410,6 +414,8 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ntoz, ntke, ntkev, endif ! end if_lssav + ! print*,"dqdt:",shinhong, maxval(dqdt(:,:,1)),minval(dqdt(:,:,1)) + end subroutine GFS_PBL_generic_post_run end module GFS_PBL_generic_post diff --git a/physics/cu_ntiedtke.F90 b/physics/cu_ntiedtke.F90 new file mode 100644 index 000000000..53f59f2b0 --- /dev/null +++ b/physics/cu_ntiedtke.F90 @@ -0,0 +1,3833 @@ +!> \file cu_ntiedtke.F90 +!! This file contains the CCPP-compliant new Tiedtke scheme which parameterize +!! Shallow, deep, and mid-level convections in the model +!! Please refer to Tiedtke (1989), Bechtold et al. (2004,2008, 2014), +!! Zhang et al. (2011), Zhang and Wang (2017, 2018) +!! +!########################################################### + +module cu_ntiedtke + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + use machine , only : kind_phys + use physcons, only:rd=>con_rd, rv=>con_rv, g=>con_g, & + & cpd=>con_cp, alv=>con_hvap, alf=>con_hfus + + implicit none + real(kind=kind_phys),private :: rcpd,vtmpc1,tmelt,als,t13, & + c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg + + real(kind=kind_phys),private :: rovcp,r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice + real(kind=kind_phys),private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon + integer,private :: momtrans,p650 + + parameter( & + t13 = 0.333333333,& + rcpd=1.0/cpd, & + tmelt=273.16, & + zrg=1.0/g, & + c1es=610.78, & + c2es=c1es*rd/rv, & + c3les=17.2693882, & + c3ies=21.875, & + c4les=35.86, & + c4ies=7.66, & + als = alv+alf, & + c5les=c3les*(tmelt-c4les), & + c5ies=c3ies*(tmelt-c4ies), & + r5alvcp=c5les*alv*rcpd, & + r5alscp=c5ies*als*rcpd, & + ralvdcp=alv*rcpd, & + ralsdcp=als*rcpd, & + ralfdcp=alf*rcpd, & + rtwat=tmelt, & + rtber=tmelt-5., & + rtice=tmelt-23., & + vtmpc1=rv/rd-1.0, & + rovcp = rd*rcpd ) +! +! entrdd: average entrainment & detrainment rate for downdrafts +! ------ +! + parameter(entrdd = 2.0e-4) +! +! cmfcmax: maximum massflux value allowed for updrafts etc +! ------- +! + parameter(cmfcmax = 1.0) +! +! cmfcmin: minimum massflux value (for safety) +! ------- +! + parameter(cmfcmin = 1.e-10) +! +! cmfdeps: fractional massflux for downdrafts at lfs +! ------- +! + parameter(cmfdeps = 0.30) + +! zdnoprc: deep cloud is thicker than this height (Unit:Pa) +! + parameter(zdnoprc = 2.0e4) +! ------- +! +! cprcon: coefficient from cloud water to rain water +! + parameter(cprcon = 1.4e-3) +! ------- +! +! momtrans: momentum transport method +! ( 1 = IFS40r1 method; 2 = new method ) +! + parameter(momtrans = 2 ) +! ------- +! + logical :: isequil +! isequil: representing equilibrium and nonequilibrium convection +! ( .false. [default]; .true. [experimental]. Ref. Bechtold et al. 2014 JAS ) +! + parameter(isequil = .false. ) +! +!-------------------- +! switches for deep, mid, shallow convections, downdraft, and momemtum transport +! ------------------ + logical :: lmfpen,lmfmid,lmfscv,lmfdd,lmfdudv + parameter(lmfpen=.true.,lmfmid=.true.,lmfscv=.true.,lmfdd=.true.,lmfdudv=.true.) +!-------------------- +!#################### end of variables definition########################## +!----------------------------------------------------------------------- +! +contains +!> \brief Brief description of the subroutine +!! +!! \section arg_table_cu_ntiedtke_init Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------------|--------------------|------------------------------------------|-------|------|-----------|-----------|--------|----------| +!! | mpirank | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | +!! | mpiroot | mpi_root | master MPI-rank | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_ntiedtke_init(mpirank, mpiroot, errmsg, errflg) + + implicit none + + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! DH* temporary + if (mpirank==mpiroot) then + write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' + write(0,*) ' --- WARNING --- the CCPP New Tiedtke convection scheme is currently under development, use at your own risk --- WARNING ---' + write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' + end if + ! *DH temporary + + end subroutine cu_ntiedtke_init + + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_cu_ntiedtke_finalize Argument Table +!! + subroutine cu_ntiedtke_finalize() + end subroutine cu_ntiedtke_finalize +! +! Tiedtke cumulus scheme from WRF with small modifications +! This scheme includes both deep and shallow convections +!=================== +! +!! +!! \section arg_table_cu_ntiedtke_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------|----------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | pu | x_wind_updated_by_physics | updated x-direction wind | m s-1 | 2 | real | kind_phys | inout | F | +!! | pv | y_wind_updated_by_physics | updated y-direction wind | m s-1 | 2 | real | kind_phys | inout | F | +!! | pt | air_temperature_updated_by_physics | updated temperature | K | 2 | real | kind_phys | inout | F | +!! | pqv | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | pqvf | moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | in | F | +!! | ptf | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | in | F | +!! | clw | convective_transportable_tracers | array to contain cloud water and other tracers | kg kg-1 | 3 | real | kind_phys | inout | F | +!! | poz | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | pzz | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | pomg | omega | layer mean vertical velocity | Pa s-1 | 2 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | hfx | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | zprecc | lwe_thickness_of_deep_convective_precipitation_amount | deep convective rainfall amount on physics timestep | m | 1 | real | kind_phys | out | F | +!! | lmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | lq | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | +!! | kbot | vertical_index_at_cloud_base | index for cloud base | index | 1 | integer | | out | F | +!! | ktop | vertical_index_at_cloud_top | index for cloud top | index | 1 | integer | | out | F | +!! | kcnv | flag_deep_convection | deep convection: 0=no, 1=yes | flag | 1 | integer | | out | F | +!! | ktrac | number_of_total_tracers | number of total tracers | count | 0 | integer | | in | F | +!! | ud_mf | instantaneous_atmosphere_updraft_convective_mass_flux | (updraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | dd_mf | instantaneous_atmosphere_downdraft_convective_mass_flux | (downdraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | dt_mf | instantaneous_atmosphere_detrainment_convective_mass_flux | (detrainment mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | cnvw | convective_cloud_water_mixing_ratio | convective cloud water | kg kg-1 | 2 | real | kind_phys | out | F | +!! | cnvc | convective_cloud_cover | convective cloud cover | frac | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!----------------------------------------------------------------------- +! level 1 subroutine 'tiecnvn' +!----------------------------------------------------------------- + subroutine cu_ntiedtke_run(pu,pv,pt,pqv,pqvf,ptf,clw,poz,pzz,prsl,prsi,pomg, & + evap,hfx,zprecc,lmask,lq,ix,km,dt,dx,kbot,ktop,kcnv,& + ktrac,ud_mf,dd_mf,dt_mf,cnvw,cnvc,errmsg,errflg) +!----------------------------------------------------------------- +! this is the interface between the model and the mass +! flux convection module +!----------------------------------------------------------------- + implicit none +! in&out variables + integer, intent(in) :: lq, ix, km, ktrac + real(kind=kind_phys), intent(in ) :: dt + integer, dimension( lq ), intent(in) :: lmask + real(kind=kind_phys), dimension( lq ), intent(in ) :: evap, hfx, dx + real(kind=kind_phys), dimension( ix , km ), intent(inout) :: pu, pv, pt, pqv + real(kind=kind_phys), dimension( ix , km ), intent(in ) :: poz, prsl, pomg, pqvf, ptf + real(kind=kind_phys), dimension( ix , km+1 ), intent(in ) :: pzz, prsi + real(kind=kind_phys), dimension( ix , km, ktrac+2 ), intent(inout ) :: clw + + integer, dimension( lq ), intent(out) :: kbot, ktop, kcnv + real(kind=kind_phys), dimension( lq ), intent(out) :: zprecc + real(kind=kind_phys), dimension (lq,km), intent(out) :: ud_mf, dd_mf, dt_mf, cnvw, cnvc + +! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! local variables + real(kind=kind_phys) pum1(lq,km), pvm1(lq,km), ztt(lq,km), & + & ptte(lq,km), pqte(lq,km), pvom(lq,km), pvol(lq,km), & + & pverv(lq,km), pgeo(lq,km), pap(lq,km), paph(lq,km+1) + real(kind=kind_phys) pqhfl(lq), zqq(lq,km), & + & prsfc(lq), pssfc(lq), pcte(lq,km), & + & phhfl(lq), pgeoh(lq,km+1) + real(kind=kind_phys) ztp1(lq,km), zqp1(lq,km), ztu(lq,km), zqu(lq,km),& + & zlu(lq,km), zlude(lq,km), zmfu(lq,km), zmfd(lq,km), zmfude_rate(lq,km),& + & zqsat(lq,km), zrain(lq) + real(kind=kind_phys) pcen(lq,km,ktrac),ptenc(lq,km,ktrac) + + integer icbot(lq), ictop(lq), ktype(lq), lndj(lq) + logical locum(lq) +! + real(kind=kind_phys) ztmst,fliq,fice,ztc,zalf,tt + integer i,j,k,k1,n,km1 + real(kind=kind_phys) ztpp1 + real(kind=kind_phys) zew,zqs,zcor +! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + km1 = km + 1 + ztmst=dt +! +! masv flux diagnostics. +! + do j=1,lq + zrain(j)=0.0 + locum(j)=.false. + prsfc(j)=0.0 + pssfc(j)=0.0 + pqhfl(j)=evap(j) + phhfl(j)=hfx(j) + pgeoh(j,km1)=pzz(j,1) + paph(j,km1)=prsi(j,1) + if(lmask(j).eq.1) then + lndj(j)=1 + else + lndj(j)=0 + end if + end do +! +! convert model variables for mflux scheme +! + do k=1,km + k1=km-k+1 + do j=1,lq + pcte(j,k1)=0.0 + pvom(j,k1)=0.0 + pvol(j,k1)=0.0 + ztp1(j,k1)=pt(j,k) + zqp1(j,k1)=pqv(j,k) + pum1(j,k1)=pu(j,k) + pvm1(j,k1)=pv(j,k) + pverv(j,k1)=pomg(j,k) + pgeo(j,k1)=poz(j,k) + pgeoh(j,k1)=pzz(j,k+1) + pap(j,k1)=prsl(j,k) + paph(j,k1)=prsi(j,k+1) + tt=ztp1(j,k1) + zew = foeewm(tt) + zqs = zew/pap(j,k1) + zqs = min(0.5,zqs) + zcor = 1./(1.-vtmpc1*zqs) + zqsat(j,k1)=zqs*zcor + pqte(j,k1)=pqvf(j,k) + zqq(j,k1) =pqte(j,k1) + ptte(j,k1)=ptf(j,k) + ztt(j,k1) =ptte(j,k1) + ud_mf(j,k1)=0. + dd_mf(j,k1)=0. + dt_mf(j,k1)=0. + cnvw(j,k1)=0. + cnvc(j,k1)=0. + end do + end do + + do n=1,ktrac + do k=1,km + k1=km-k+1 + do j=1,lq + pcen(j,k1,n) = clw(j,k,n+2) + ptenc(j,k1,n)= 0. + end do + end do + end do + +! print *, "pgeo=",pgeo(1,:) +! print *, "pgeoh=",pgeoh(1,:) +! print *, "pap=",pap(1,:) +! print *, "paph=",paph(1,:) +! print *, "ztp1=",ztp1(1,:) +! print *, "zqp1=",zqp1(1,:) +! print *, "pum1=",pum1(1,:) +! print *, "pvm1=",pvm1(1,:) +! print *, "pverv=",pverv(1,:) +! print *, "pqte=",pqte(1,:) +! print *, "ptte=",ptte(1,:) +! print *, "hfx=", pqhfl(1),phhfl(1),dx(1) +! +!----------------------------------------------------------------------- +!* 2. call 'cumastrn'(master-routine for cumulus parameterization) +! + call cumastrn & + & (lq, km, km1, km-1, ztp1, & + & zqp1, pum1, pvm1, pverv, zqsat,& + & pqhfl, ztmst, pap, paph, pgeo, & + & ptte, pqte, pvom, pvol, prsfc,& + & pssfc, locum, ktrac, pcen, ptenc,& + & ktype, icbot, ictop, ztu, zqu, & + & zlu, zlude, zmfu, zmfd, zrain,& + & pcte, phhfl, lndj, pgeoh, zmfude_rate, dx) +! +! to include the cloud water and cloud ice detrained from convection +! + do k=1,km + k1=km-k+1 + do j=1,lq + if(pcte(j,k1).gt.0.) then + fliq=foealfa(ztp1(j,k1)) + fice=1.0-fliq + clw(j,k,2)=clw(j,k,2)+fliq*pcte(j,k1)*ztmst + clw(j,k,1)=clw(j,k,1)+fice*pcte(j,k1)*ztmst + endif + end do + end do +! + do k=1,km + k1 = km-k+1 + do j=1,lq + pt(j,k) = ztp1(j,k1)+(ptte(j,k1)-ztt(j,k1))*ztmst + pqv(j,k)= zqp1(j,k1)+(pqte(j,k1)-zqq(j,k1))*ztmst + ud_mf(j,k)= zmfu(j,k1)*ztmst + dd_mf(j,k)= zmfd(j,k1)*ztmst + dt_mf(j,k)= zmfude_rate(j,k1)*ztmst + cnvw(j,k) = zlude(j,k1)*ztmst*g/(prsi(j,k)-prsi(j,k+1)) + cnvc(j,k) = 0.04 * log(1. + 675. * ud_mf(j,k)) + cnvc(j,k) = min(cnvc(j,k), 0.6) + cnvc(j,k) = max(cnvc(j,k), 0.0) + end do + end do + + do j=1,lq + zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst*0.001) + kbot(j) = km-icbot(j)+1 + ktop(j) = km-ictop(j)+1 + if(ktype(j).eq.1 .or. ktype(j).eq.3) then + kcnv(j)=1 + else + kcnv(j)=0 + end if + end do + + if (lmfdudv) then + do k=1,km + k1=km-k+1 + do j=1,lq + pu(j,k)=pu(j,k)+pvom(j,k1)*ztmst + pv(j,k)=pv(j,k)+pvol(j,k1)*ztmst + end do + end do + endif +! + if (ktrac > 0) then + do n=1,ktrac + do k=1,km + k1=km-k+1 + do j=1,lq + clw(j,k,n+2)=pcen(j,k,n)+ptenc(j,k1,n)*ztmst + end do + end do + end do + end if +! + return + end subroutine cu_ntiedtke_run + +!############################################################# +! +! level 2 subroutines +! +!############################################################# +!*********************************************************** +! subroutine cumastrn +!*********************************************************** + subroutine cumastrn & + & (klon, klev, klevp1, klevm1, pten, & + & pqen, puen, pven, pverv, pqsen,& + & pqhfl, ztmst, pap, paph, pgeo, & + & ptte, pqte, pvom, pvol, prsfc,& + & pssfc, ldcum, ktrac, pcen, ptenc,& + & ktype, kcbot, kctop, ptu, pqu,& + & plu, plude, pmfu, pmfd, prain,& + & pcte, phhfl, lndj, zgeoh, pmfude_rate, dx) + implicit none +! +!***cumastrn* master routine for cumulus massflux-scheme +! m.tiedtke e.c.m.w.f. 1986/1987/1989 +! modifications +! y.wang i.p.r.c 2001 +! c.zhang 2012 +!***purpose +! ------- +! this routine computes the physical tendencies of the +! prognostic variables t,q,u and v due to convective processes. +! processes considered are: convective fluxes, formation of +! precipitation, evaporation of falling rain below cloud base, +! saturated cumulus downdrafts. +!***method +! ------ +! parameterization is done using a massflux-scheme. +! (1) define constants and parameters +! (2) specify values (t,q,qs...) at half levels and +! initialize updraft- and downdraft-values in 'cuinin' +! (3) calculate cloud base in 'cutypen', calculate cloud types in cutypen, +! and specify cloud base massflux +! (4) do cloud ascent in 'cuascn' in absence of downdrafts +! (5) do downdraft calculations: +! (a) determine values at lfs in 'cudlfsn' +! (b) determine moist descent in 'cuddrafn' +! (c) recalculate cloud base massflux considering the +! effect of cu-downdrafts +! (6) do final adjusments to convective fluxes in 'cuflxn', +! do evaporation in subcloud layer +! (7) calculate increments of t and q in 'cudtdqn' +! (8) calculate increments of u and v in 'cududvn' +!***externals. +! ---------- +! cuinin: initializes values at vertical grid used in cu-parametr. +! cutypen: cloud bypes, 1: deep cumulus 2: shallow cumulus +! cuascn: cloud ascent for entraining plume +! cudlfsn: determines values at lfs for downdrafts +! cuddrafn:does moist descent for cumulus downdrafts +! cuflxn: final adjustments to convective fluxes (also in pbl) +! cudqdtn: updates tendencies for t and q +! cududvn: updates tendencies for u and v +!***switches. +! -------- +! lmfmid=.t. midlevel convection is switched on +! lmfdd=.t. cumulus downdrafts switched on +! lmfdudv=.t. cumulus friction switched on +!*** +! model parameters (defined in subroutine cuparam) +! ------------------------------------------------ +! entrdd entrainment rate for cumulus downdrafts +! cmfcmax maximum massflux value allowed for +! cmfcmin minimum massflux value (for safety) +! cmfdeps fractional massflux for downdrafts at lfs +! cprcon coefficient for conversion from cloud water to rain +!***reference. +! ---------- +! paper on massflux scheme (tiedtke,1989) +!----------------------------------------------------------------- + integer klev,klon,ktrac,klevp1,klevm1 + real(kind=kind_phys) pten(klon,klev), pqen(klon,klev),& + & puen(klon,klev), pven(klon,klev),& + & ptte(klon,klev), pqte(klon,klev),& + & pvom(klon,klev), pvol(klon,klev),& + & pqsen(klon,klev), pgeo(klon,klev),& + & pap(klon,klev), paph(klon,klevp1),& + & pverv(klon,klev), pqhfl(klon),& + & phhfl(klon) + real(kind=kind_phys) ptu(klon,klev), pqu(klon,klev),& + & plu(klon,klev), plude(klon,klev),& + & pmfu(klon,klev), pmfd(klon,klev),& + & prain(klon),& + & prsfc(klon), pssfc(klon) + real(kind=kind_phys) ztenh(klon,klev), zqenh(klon,klev),& + & zgeoh(klon,klevp1), zqsenh(klon,klev),& + & ztd(klon,klev), zqd(klon,klev),& + & zmfus(klon,klev), zmfds(klon,klev),& + & zmfuq(klon,klev), zmfdq(klon,klev),& + & zdmfup(klon,klev), zdmfdp(klon,klev),& + & zmful(klon,klev), zrfl(klon),& + & zuu(klon,klev), zvu(klon,klev),& + & zud(klon,klev), zvd(klon,klev),& + & zlglac(klon,klev) + real(kind=kind_phys) pmflxr(klon,klevp1), pmflxs(klon,klevp1) + real(kind=kind_phys) zhcbase(klon),& + & zmfub(klon), zmfub1(klon),& + & zdhpbl(klon) + real(kind=kind_phys) zsfl(klon), zdpmel(klon,klev),& + & pcte(klon,klev), zcape(klon),& + & zcape1(klon), zcape2(klon),& + & ztauc(klon), ztaubl(klon),& + & zheat(klon) + real(kind=kind_phys) pcen(klon,klev,ktrac), ptenc(klon,klev,ktrac) + real(kind=kind_phys) wup(klon), zdqcv(klon) + real(kind=kind_phys) wbase(klon), zmfuub(klon) + real(kind=kind_phys) upbl(klon) + real(kind=kind_phys) dx(klon) + real(kind=kind_phys) pmfude_rate(klon,klev), pmfdde_rate(klon,klev) + real(kind=kind_phys) zmfuus(klon,klev), zmfdus(klon,klev) + real(kind=kind_phys) zmfudr(klon,klev), zmfddr(klon,klev) + real(kind=kind_phys) zuv2(klon,klev),ztenu(klon,klev),ztenv(klon,klev) + real(kind=kind_phys) zmfuvb(klon),zsum12(klon),zsum22(klon) + integer ilab(klon,klev), idtop(klon),& + & ictop0(klon), ilwmin(klon) + integer kdpl(klon) + integer kcbot(klon), kctop(klon),& + & ktype(klon), lndj(klon) + logical ldcum(klon), lldcum(klon) + logical loddraf(klon), llddraf3(klon), llo1, llo2(klon) + +! local varaiables + real(kind=kind_phys) zcons,zcons2,zqumqe,zdqmin,zdh,zmfmax + real(kind=kind_phys) zalfaw,zalv,zqalv,zc5ldcp,zc4les,zhsat,zgam,zzz,zhhat + real(kind=kind_phys) zpbmpt,zro,zdz,zdp,zeps,zfac,wspeed + integer jl,jk,ik + integer ikb,ikt,icum,itopm2 + real(kind=kind_phys) ztmst,ztau,zerate,zderate,zmfa + real(kind=kind_phys) zmfs(klon),pmean(klev),zlon + real(kind=kind_phys) zduten,zdvten,ztdis,pgf_u,pgf_v +!------------------------------------------- +! 1. specify constants and parameters +!------------------------------------------- + zcons=1./(g*ztmst) + zcons2=3./(g*ztmst) + + zlon = real(klon) + do jk = klev , 1 , -1 + pmean(jk) = sum(pap(:,jk))/zlon + end do + p650 = klev-2 + do jk = klev , 3 , -1 + if ( pmean(jk)/pmean(klev)*1.013250e5 > 650.e2 ) p650 = jk + end do + +!-------------------------------------------------------------- +!* 2. initialize values at vertical grid points in 'cuini' +!-------------------------------------------------------------- + call cuinin & + & (klon, klev, klevp1, klevm1, pten, & + & pqen, pqsen, puen, pven, pverv,& + & pgeo, paph, zgeoh, ztenh, zqenh,& + & zqsenh, ilwmin, ptu, pqu, ztd, & + & zqd, zuu, zvu, zud, zvd, & + & pmfu, pmfd, zmfus, zmfds, zmfuq,& + & zmfdq, zdmfup, zdmfdp, zdpmel, plu, & + & plude, ilab) + +!---------------------------------- +!* 3.0 cloud base calculations +!---------------------------------- +!* (a) determine cloud base values in 'cutypen', +! and the cumulus type 1 or 2 +! ------------------------------------------- + call cutypen & + & ( klon, klev, klevp1, klevm1, pqen,& + & ztenh, zqenh, zqsenh, zgeoh, paph,& + & phhfl, pqhfl, pgeo, pqsen, pap,& + & pten, lndj, ptu, pqu, ilab,& + & ldcum, kcbot, ictop0, ktype, wbase, plu, kdpl) + +!* (b) assign the first guess mass flux at cloud base +! ------------------------------------------ + do jl=1,klon + zdhpbl(jl)=0.0 + upbl(jl) = 0.0 + idtop(jl)=0 + end do + + do jk=2,klev + do jl=1,klon + if(jk.ge.kcbot(jl) .and. ldcum(jl)) then + zdhpbl(jl)=zdhpbl(jl)+(alv*pqte(jl,jk)+cpd*ptte(jl,jk))& + & *(paph(jl,jk+1)-paph(jl,jk)) + if(lndj(jl) .eq. 0) then + wspeed = sqrt(puen(jl,jk)**2 + pven(jl,jk)**2) + upbl(jl) = upbl(jl) + wspeed*(paph(jl,jk+1)-paph(jl,jk)) + end if + end if + end do + end do + + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + zmfmax = (paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + if(ktype(jl) == 1) then + zmfub(jl)= 0.1*zmfmax + else if ( ktype(jl) == 2 ) then + zqumqe = pqu(jl,ikb) + plu(jl,ikb) - zqenh(jl,ikb) + zdqmin = max(0.01*zqenh(jl,ikb),1.e-10) + zdh = cpd*(ptu(jl,ikb)-ztenh(jl,ikb)) + alv*zqumqe + zdh = g*max(zdh,1.e5*zdqmin) + if ( zdhpbl(jl) > 0. ) then + zmfub(jl) = zdhpbl(jl)/zdh + zmfub(jl) = min(zmfub(jl),zmfmax) + else + zmfub(jl) = 0.1*zmfmax + ldcum(jl) = .false. + end if + end if + else + zmfub(jl) = 0. + end if + end do +!------------------------------------------------------ +!* 4.0 determine cloud ascent for entraining plume +!------------------------------------------------------ +!* (a) do ascent in 'cuasc'in absence of downdrafts +!---------------------------------------------------------- + call cuascn & + & (klon, klev, klevp1, klevm1, ztenh,& + & zqenh, puen, pven, pten, pqen,& + & pqsen, pgeo, zgeoh, pap, paph,& + & pqte, pverv, ilwmin, ldcum, zhcbase,& + & ktype, ilab, ptu, pqu, plu,& + & zuu, zvu, pmfu, zmfub,& + & zmfus, zmfuq, zmful, plude, zdmfup,& + & kcbot, kctop, ictop0, icum, ztmst,& + & zqsenh, zlglac, lndj, wup, wbase, kdpl, pmfude_rate ) + +!* (b) check cloud depth and change entrainment rate accordingly +! calculate precipitation rate (for downdraft calculation) +!------------------------------------------------------------------ + do jl=1,klon + if ( ldcum(jl) ) then + ikb = kcbot(jl) + itopm2 = kctop(jl) + zpbmpt = paph(jl,ikb) - paph(jl,itopm2) + if ( ktype(jl) == 1 .and. zpbmpt < zdnoprc ) ktype(jl) = 2 + if ( ktype(jl) == 2 .and. zpbmpt >= zdnoprc ) ktype(jl) = 1 + ictop0(jl) = kctop(jl) + end if + zrfl(jl)=zdmfup(jl,1) + end do + + do jk=2,klev + do jl=1,klon + zrfl(jl)=zrfl(jl)+zdmfup(jl,jk) + end do + end do + + do jk = 1,klev + do jl = 1,klon + pmfd(jl,jk) = 0. + zmfds(jl,jk) = 0. + zmfdq(jl,jk) = 0. + zdmfdp(jl,jk) = 0. + zdpmel(jl,jk) = 0. + end do + end do + +!----------------------------------------- +!* 6.0 cumulus downdraft calculations +!----------------------------------------- + if(lmfdd) then +!* (a) determine lfs in 'cudlfsn' +!-------------------------------------- + call cudlfsn & + & (klon, klev,& + & kcbot, kctop, lndj, ldcum, & + & ztenh, zqenh, puen, pven, & + & pten, pqsen, pgeo, & + & zgeoh, paph, ptu, pqu, plu, & + & zuu, zvu, zmfub, zrfl, & + & ztd, zqd, zud, zvd, & + & pmfd, zmfds, zmfdq, zdmfdp, & + & idtop, loddraf) +!* (b) determine downdraft t,q and fluxes in 'cuddrafn' +!------------------------------------------------------------ + call cuddrafn & + & ( klon, klev, loddraf, & + & ztenh, zqenh, puen, pven, & + & pgeo, zgeoh, paph, zrfl, & + & ztd, zqd, zud, zvd, pmfu, & + & pmfd, zmfds, zmfdq, zdmfdp, pmfdde_rate ) +!----------------------------------------------------------- + end if +! +!----------------------------------------------------------------------- +!* 6.0 closure and clean work +! ------ +!-- 6.1 recalculate cloud base massflux from a cape closure +! for deep convection (ktype=1) +! + do jl=1,klon + if(ldcum(jl) .and. ktype(jl) .eq. 1) then + ikb = kcbot(jl) + ikt = kctop(jl) + zheat(jl)=0.0 + zcape(jl)=0.0 + zcape1(jl)=0.0 + zcape2(jl)=0.0 + zmfub1(jl)=zmfub(jl) + + ztauc(jl) = (zgeoh(jl,ikt)-zgeoh(jl,ikb)) / & + ((2.+ min(15.0,wup(jl)))*g) + if(lndj(jl) .eq. 0) then + upbl(jl) = 2.+ upbl(jl)/(paph(jl,klev+1)-paph(jl,ikb)) + ztaubl(jl) = (zgeoh(jl,ikb)-zgeoh(jl,klev+1))/(g*upbl(jl)) + ztaubl(jl) = min(300., ztaubl(jl)) + else + ztaubl(jl) = ztauc(jl) + end if + end if + end do +! + do jk = 1 , klev + do jl = 1 , klon + llo1 = ldcum(jl) .and. ktype(jl) .eq. 1 + if ( llo1 .and. jk <= kcbot(jl) .and. jk > kctop(jl) ) then + ikb = kcbot(jl) + zdz = pgeo(jl,jk-1)-pgeo(jl,jk) + zdp = pap(jl,jk)-pap(jl,jk-1) + zheat(jl) = zheat(jl) + ((pten(jl,jk-1)-pten(jl,jk)+zdz*rcpd) / & + ztenh(jl,jk)+vtmpc1*(pqen(jl,jk-1)-pqen(jl,jk))) * & + (g*(pmfu(jl,jk)+pmfd(jl,jk))) + zcape1(jl) = zcape1(jl) + ((ptu(jl,jk)-ztenh(jl,jk))/ztenh(jl,jk) + & + vtmpc1*(pqu(jl,jk)-zqenh(jl,jk))-plu(jl,jk))*zdp + end if + + if ( llo1 .and. jk >= kcbot(jl) ) then + if((paph(jl,klev+1)-paph(jl,kdpl(jl)))<50.e2) then + zdp = paph(jl,jk+1)-paph(jl,jk) + zcape2(jl) = zcape2(jl) + ztaubl(jl)* & + ((1.+vtmpc1*pqen(jl,jk))*ptte(jl,jk)+vtmpc1*pten(jl,jk)*pqte(jl,jk))*zdp + end if + end if + end do + end do + + do jl=1,klon + if(ldcum(jl).and.ktype(jl).eq.1) then + ikb = kcbot(jl) + ikt = kctop(jl) + ztau = ztauc(jl) * (1.+1.33e-5*dx(jl)) + ztau = max(ztmst,ztau) + ztau = max(720.,ztau) + ztau = min(10800.,ztau) + if(isequil) then + zcape2(jl)= max(0.,zcape2(jl)) + zcape(jl) = max(0.,min(zcape1(jl)-zcape2(jl),5000.)) + else + zcape(jl) = max(0.,min(zcape1(jl),5000.)) + end if + zheat(jl) = max(1.e-4,zheat(jl)) + zmfub1(jl) = (zcape(jl)*zmfub(jl))/(zheat(jl)*ztau) + zmfub1(jl) = max(zmfub1(jl),0.001) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + zmfub1(jl)=min(zmfub1(jl),zmfmax) + end if + end do +! +!* 6.2 recalculate convective fluxes due to effect of +! downdrafts on boundary layer moist static energy budget (ktype=2) +!-------------------------------------------------------- + do jl=1,klon + if(ldcum(jl) .and. ktype(jl) .eq. 2) then + ikb=kcbot(jl) + if(pmfd(jl,ikb).lt.0.0 .and. loddraf(jl)) then + zeps=-pmfd(jl,ikb)/max(zmfub(jl),cmfcmin) + else + zeps=0. + endif + zqumqe=pqu(jl,ikb)+plu(jl,ikb)- & + & zeps*zqd(jl,ikb)-(1.-zeps)*zqenh(jl,ikb) + zdqmin=max(0.01*zqenh(jl,ikb),cmfcmin) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 +! using moist static engergy closure instead of moisture closure + zdh=cpd*(ptu(jl,ikb)-zeps*ztd(jl,ikb)- & + & (1.-zeps)*ztenh(jl,ikb))+alv*zqumqe + zdh=g*max(zdh,1.e5*zdqmin) + if(zdhpbl(jl).gt.0.)then + zmfub1(jl)=zdhpbl(jl)/zdh + else + zmfub1(jl) = zmfub(jl) + end if + zmfub1(jl) = min(zmfub1(jl),zmfmax) + end if + +!* 6.3 mid-level convection - nothing special +!--------------------------------------------------------- + if(ldcum(jl) .and. ktype(jl) .eq. 3 ) then + zmfub1(jl) = zmfub(jl) + end if + + end do + +!* 6.4 scaling the downdraft mass flux +!--------------------------------------------------------- + do jk=1,klev + do jl=1,klon + if( ldcum(jl) ) then + zfac=zmfub1(jl)/max(zmfub(jl),cmfcmin) + pmfd(jl,jk)=pmfd(jl,jk)*zfac + zmfds(jl,jk)=zmfds(jl,jk)*zfac + zmfdq(jl,jk)=zmfdq(jl,jk)*zfac + zdmfdp(jl,jk)=zdmfdp(jl,jk)*zfac + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zfac + end if + end do + end do + +!* 6.5 scaling the updraft mass flux +! -------------------------------------------------------- + do jl = 1,klon + if ( ldcum(jl) ) zmfs(jl) = zmfub1(jl)/max(cmfcmin,zmfub(jl)) + end do + do jk = 2 , klev + do jl = 1,klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + ikb = kcbot(jl) + if ( jk>ikb ) then + zdz = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) + pmfu(jl,jk) = pmfu(jl,ikb)*zdz + end if + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + if ( pmfu(jl,jk)*zmfs(jl) > zmfmax ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + do jk = 2 , klev + do jl = 1,klon + if ( ldcum(jl) .and. jk <= kcbot(jl) .and. jk >= kctop(jl)-1 ) then + pmfu(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfus(jl,jk) = zmfus(jl,jk)*zmfs(jl) + zmfuq(jl,jk) = zmfuq(jl,jk)*zmfs(jl) + zmful(jl,jk) = zmful(jl,jk)*zmfs(jl) + zdmfup(jl,jk) = zdmfup(jl,jk)*zmfs(jl) + plude(jl,jk) = plude(jl,jk)*zmfs(jl) + pmfude_rate(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) + end if + end do + end do + +!* 6.6 if ktype = 2, kcbot=kctop is not allowed +! --------------------------------------------------- + do jl = 1,klon + if ( ktype(jl) == 2 .and. & + kcbot(jl) == kctop(jl) .and. kcbot(jl) >= klev-1 ) then + ldcum(jl) = .false. + ktype(jl) = 0 + end if + end do + + if ( .not. lmfscv .or. .not. lmfpen ) then + do jl = 1,klon + llo2(jl) = .false. + if ( (.not. lmfscv .and. ktype(jl) == 2) .or. & + (.not. lmfpen .and. ktype(jl) == 1) ) then + llo2(jl) = .true. + ldcum(jl) = .false. + end if + end do + end if + +!* 6.7 set downdraft mass fluxes to zero above cloud top +!---------------------------------------------------- + do jl = 1,klon + if ( loddraf(jl) .and. idtop(jl) <= kctop(jl) ) then + idtop(jl) = kctop(jl) + 1 + end if + end do + do jk = 2 , klev + do jl = 1,klon + if ( loddraf(jl) ) then + if ( jk < idtop(jl) ) then + pmfd(jl,jk) = 0. + zmfds(jl,jk) = 0. + zmfdq(jl,jk) = 0. + pmfdde_rate(jl,jk) = 0. + zdmfdp(jl,jk) = 0. + else if ( jk == idtop(jl) ) then + pmfdde_rate(jl,jk) = 0. + end if + end if + end do + end do + + itopm2 = 2 +!---------------------------------------------------------- +!* 7.0 determine final convective fluxes in 'cuflx' +!---------------------------------------------------------- + call cuflxn & + & ( klon, klev, ztmst & + & , pten, pqen, pqsen, ztenh, zqenh & + & , paph, pap, zgeoh, lndj, ldcum & + & , kcbot, kctop, idtop, itopm2 & + & , ktype, loddraf & + & , pmfu, pmfd, zmfus, zmfds & + & , zmfuq, zmfdq, zmful, plude & + & , zdmfup, zdmfdp, zdpmel, zlglac & + & , prain, pmfdde_rate, pmflxr, pmflxs ) + +! some adjustments needed + do jl=1,klon + zmfs(jl) = 1. + zmfuub(jl)=0. + end do + do jk = 2 , klev + do jl = 1,klon + if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then + zmfmax = pmfu(jl,jk)*0.98 + if ( pmfd(jl,jk)+zmfmax+1.e-15 < 0. ) then + zmfs(jl) = min(zmfs(jl),-zmfmax/pmfd(jl,jk)) + end if + end if + end do + end do + + do jk = 2 , klev + do jl = 1 , klon + if ( zmfs(jl) < 1. .and. jk >= idtop(jl)-1 ) then + pmfd(jl,jk) = pmfd(jl,jk)*zmfs(jl) + zmfds(jl,jk) = zmfds(jl,jk)*zmfs(jl) + zmfdq(jl,jk) = zmfdq(jl,jk)*zmfs(jl) + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) + zmfuub(jl) = zmfuub(jl) - (1.-zmfs(jl))*zdmfdp(jl,jk) + pmflxr(jl,jk+1) = pmflxr(jl,jk+1) + zmfuub(jl) + zdmfdp(jl,jk) = zdmfdp(jl,jk)*zmfs(jl) + end if + end do + end do + + do jk = 2 , klev - 1 + do jl = 1, klon + if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then + zerate = -pmfd(jl,jk) + pmfd(jl,jk-1) + pmfdde_rate(jl,jk) + if ( zerate < 0. ) then + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk) - zerate + end if + end if + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zerate = pmfu(jl,jk) - pmfu(jl,jk+1) + pmfude_rate(jl,jk) + if ( zerate < 0. ) then + pmfude_rate(jl,jk) = pmfude_rate(jl,jk) - zerate + end if + zdmfup(jl,jk) = pmflxr(jl,jk+1) + pmflxs(jl,jk+1) - & + pmflxr(jl,jk) - pmflxs(jl,jk) + zdmfdp(jl,jk) = 0. + end if + end do + end do + +! avoid negative humidities at ddraught top + do jl = 1,klon + if ( loddraf(jl) ) then + jk = idtop(jl) + ik = min(jk+1,klev) + if ( zmfdq(jl,jk) < 0.3*zmfdq(jl,ik) ) then + zmfdq(jl,jk) = 0.3*zmfdq(jl,ik) + end if + end if + end do + +! avoid negative humidities near cloud top because gradient of precip flux +! and detrainment / liquid water flux are too large + do jk = 2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 .and. jk < kcbot(jl) ) then + zdz = ztmst*g/(paph(jl,jk+1)-paph(jl,jk)) + zmfa = zmfuq(jl,jk+1) + zmfdq(jl,jk+1) - & + zmfuq(jl,jk) - zmfdq(jl,jk) + & + zmful(jl,jk+1) - zmful(jl,jk) + zdmfup(jl,jk) + zmfa = (zmfa-plude(jl,jk))*zdz + if ( pqen(jl,jk)+zmfa < 0. ) then + plude(jl,jk) = plude(jl,jk) + 2.*(pqen(jl,jk)+zmfa)/zdz + end if + if ( plude(jl,jk) < 0. ) plude(jl,jk) = 0. + end if + if ( .not. ldcum(jl) ) pmfude_rate(jl,jk) = 0. + if ( abs(pmfd(jl,jk-1)) < 1.0e-20 ) pmfdde_rate(jl,jk) = 0. + end do + end do + + do jl=1,klon + prsfc(jl) = pmflxr(jl,klev+1) + pssfc(jl) = pmflxs(jl,klev+1) + end do + +!---------------------------------------------------------------- +!* 8.0 update tendencies for t and q in subroutine cudtdq +!---------------------------------------------------------------- + call cudtdqn(klon,klev,itopm2,kctop,idtop,ldcum,loddraf, & + ztmst,paph,zgeoh,pgeo,pten,ztenh,pqen,zqenh,pqsen, & + zlglac,plude,pmfu,pmfd,zmfus,zmfds,zmfuq,zmfdq,zmful, & + zdmfup,zdmfdp,zdpmel,ptte,pqte,pcte) +!---------------------------------------------------------------- +!* 9.0 update tendencies for u and u in subroutine cududv +!---------------------------------------------------------------- + if(lmfdudv) then + do jk = klev-1 , 2 , -1 + ik = jk + 1 + do jl = 1,klon + if ( ldcum(jl) ) then + if ( jk == kcbot(jl) .and. ktype(jl) < 3 ) then + ikb = kdpl(jl) + zuu(jl,jk) = puen(jl,ikb-1) + zvu(jl,jk) = pven(jl,ikb-1) + else if ( jk == kcbot(jl) .and. ktype(jl) == 3 ) then + zuu(jl,jk) = puen(jl,jk-1) + zvu(jl,jk) = pven(jl,jk-1) + end if + if ( jk < kcbot(jl) .and. jk >= kctop(jl) ) then + if(momtrans .eq. 1)then + zfac = 0. + if ( ktype(jl) == 1 .or. ktype(jl) == 3 ) zfac = 2. + if ( ktype(jl) == 1 .and. jk <= kctop(jl)+2 ) zfac = 3. + zerate = pmfu(jl,jk) - pmfu(jl,ik) + & + (1.+zfac)*pmfude_rate(jl,jk) + zderate = (1.+zfac)*pmfude_rate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & + zerate*puen(jl,jk)-zderate*zuu(jl,ik))*zmfa + zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & + zerate*pven(jl,jk)-zderate*zvu(jl,ik))*zmfa + else + if(ktype(jl) == 1 .or. ktype(jl) == 3) then + pgf_u = -0.7*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& + pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) + pgf_v = -0.7*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& + pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) + else + pgf_u = 0. + pgf_v = 0. + end if + zerate = pmfu(jl,jk) - pmfu(jl,ik) + pmfude_rate(jl,jk) + zderate = pmfude_rate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & + zerate*puen(jl,jk)-zderate*zuu(jl,ik)+pgf_u)*zmfa + zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & + zerate*pven(jl,jk)-zderate*zvu(jl,ik)+pgf_v)*zmfa + end if + end if + end if + end do + end do + + if(lmfdd) then + do jk = 3 , klev + ik = jk - 1 + do jl = 1,klon + if ( ldcum(jl) ) then + if ( jk == idtop(jl) ) then + zud(jl,jk) = 0.5*(zuu(jl,jk)+puen(jl,ik)) + zvd(jl,jk) = 0.5*(zvu(jl,jk)+pven(jl,ik)) + else if ( jk > idtop(jl) ) then + zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pmfdde_rate(jl,jk) + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zud(jl,jk) = (zud(jl,ik)*pmfd(jl,ik) - & + zerate*puen(jl,ik)+pmfdde_rate(jl,jk)*zud(jl,ik))*zmfa + zvd(jl,jk) = (zvd(jl,ik)*pmfd(jl,ik) - & + zerate*pven(jl,ik)+pmfdde_rate(jl,jk)*zvd(jl,ik))*zmfa + end if + end if + end do + end do + end if +! -------------------------------------------------- +! rescale massfluxes for stability in Momentum +!------------------------------------------------------------------------ + zmfs(:) = 1. + do jk = 2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons + if ( pmfu(jl,jk) > zmfmax .and. jk >= kctop(jl) ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + do jk = 1 , klev + do jl = 1, klon + zmfuus(jl,jk) = pmfu(jl,jk) + zmfdus(jl,jk) = pmfd(jl,jk) + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) + end if + end do + end do +!* 9.1 update u and v in subroutine cududvn +!------------------------------------------------------------------- + do jk = 1 , klev + do jl = 1, klon + ztenu(jl,jk) = pvom(jl,jk) + ztenv(jl,jk) = pvol(jl,jk) + end do + end do + + call cududvn(klon,klev,itopm2,ktype,kcbot,kctop, & + ldcum,ztmst,paph,puen,pven,zmfuus,zmfdus,zuu, & + zud,zvu,zvd,pvom,pvol) + +! calculate KE dissipation + do jl = 1, klon + zsum12(jl) = 0. + zsum22(jl) = 0. + end do + do jk = 1 , klev + do jl = 1, klon + zuv2(jl,jk) = 0. + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zdz = (paph(jl,jk+1)-paph(jl,jk)) + zduten = pvom(jl,jk) - ztenu(jl,jk) + zdvten = pvol(jl,jk) - ztenv(jl,jk) + zuv2(jl,jk) = sqrt(zduten**2+zdvten**2) + zsum22(jl) = zsum22(jl) + zuv2(jl,jk)*zdz + zsum12(jl) = zsum12(jl) - & + (puen(jl,jk)*zduten+pven(jl,jk)*zdvten)*zdz + end if + end do + end do + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk>=kctop(jl)-1 ) then + ztdis = rcpd*zsum12(jl)*zuv2(jl,jk)/max(1.e-15,zsum22(jl)) + ptte(jl,jk) = ptte(jl,jk) + ztdis + end if + end do + end do + + end if + +!---------------------------------------------------------------------- +!* 10. IN CASE THAT EITHER DEEP OR SHALLOW IS SWITCHED OFF +! NEED TO SET SOME VARIABLES A POSTERIORI TO ZERO +! --------------------------------------------------- + if ( .not. lmfscv .or. .not. lmfpen ) then + do jk = 2 , klev + do jl = 1, klon + if ( llo2(jl) .and. jk >= kctop(jl)-1 ) then + ptu(jl,jk) = pten(jl,jk) + pqu(jl,jk) = pqen(jl,jk) + plu(jl,jk) = 0. + pmfude_rate(jl,jk) = 0. + pmfdde_rate(jl,jk) = 0. + end if + end do + end do + do jl = 1, klon + if ( llo2(jl) ) then + kctop(jl) = klev - 1 + kcbot(jl) = klev - 1 + end if + end do + end if + + !---------------------------------------------------------------------- + !* 11.0 CHEMICAL TRACER TRANSPORT + ! ------------------------- + + if ( ktrac > 0 ) then + ! transport switched off for mid-level convection + do jl = 1, klon + if ( ldcum(jl) .and. ktype(jl) /= 3 .and. & + kcbot(jl)-kctop(jl) >= 1 ) then + lldcum(jl) = .true. + llddraf3(jl) = loddraf(jl) + else + lldcum(jl) = .false. + llddraf3(jl) = .false. + end if + end do + ! check and correct mass fluxes for CFL criterium + zmfs(:) = 1. + do jk = 2 , klev + do jl = 1, klon + if ( lldcum(jl) .and. jk >= kctop(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*0.8*zcons + if ( pmfu(jl,jk) > zmfmax ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + + do jk = 1, klev + do jl = 1, klon + if ( lldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfudr(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) + else + zmfuus(jl,jk) = 0. + zmfudr(jl,jk) = 0. + end if + if ( llddraf3(jl) .and. jk >= idtop(jl)-1 ) then + zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) + zmfddr(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) + else + zmfdus(jl,jk) = 0. + zmfddr(jl,jk) = 0. + end if + end do + end do + + call cuctracer(klon,klev,ktrac,kctop,idtop, & + lldcum,llddraf3,ztmst,paph,zmfuus,zmfdus, & + zmfudr,zmfddr,pcen,ptenc) + end if + + return + end subroutine cumastrn + +!********************************************** +! level 3 subroutine cuinin +!********************************************** +! + subroutine cuinin & + & (klon, klev, klevp1, klevm1, pten,& + & pqen, pqsen, puen, pven, pverv,& + & pgeo, paph, pgeoh, ptenh, pqenh,& + & pqsenh, klwmin, ptu, pqu, ptd,& + & pqd, puu, pvu, pud, pvd,& + & pmfu, pmfd, pmfus, pmfds, pmfuq,& + & pmfdq, pdmfup, pdmfdp, pdpmel, plu,& + & plude, klab) + implicit none +! m.tiedtke e.c.m.w.f. 12/89 +!***purpose +! ------- +! this routine interpolates large-scale fields of t,q etc. +! to half levels (i.e. grid for massflux scheme), +! and initializes values for updrafts and downdrafts +!***interface +! --------- +! this routine is called from *cumastr*. +!***method. +! -------- +! for extrapolation to half levels see tiedtke(1989) +!***externals +! --------- +! *cuadjtq* to specify qs at half levels +! ---------------------------------------------------------------- + integer klon,klev,klevp1,klevm1 + real(kind=kind_phys) pten(klon,klev), pqen(klon,klev),& + & puen(klon,klev), pven(klon,klev),& + & pqsen(klon,klev), pverv(klon,klev),& + & pgeo(klon,klev), pgeoh(klon,klevp1),& + & paph(klon,klevp1), ptenh(klon,klev),& + & pqenh(klon,klev), pqsenh(klon,klev) + real(kind=kind_phys) ptu(klon,klev), pqu(klon,klev),& + & ptd(klon,klev), pqd(klon,klev),& + & puu(klon,klev), pud(klon,klev),& + & pvu(klon,klev), pvd(klon,klev),& + & pmfu(klon,klev), pmfd(klon,klev),& + & pmfus(klon,klev), pmfds(klon,klev),& + & pmfuq(klon,klev), pmfdq(klon,klev),& + & pdmfup(klon,klev), pdmfdp(klon,klev),& + & plu(klon,klev), plude(klon,klev) + real(kind=kind_phys) zwmax(klon), zph(klon), & + & pdpmel(klon,klev) + integer klab(klon,klev), klwmin(klon) + logical loflag(klon) +! local variables + integer jl,jk + integer icall,ik + real(kind=kind_phys) zzs +!------------------------------------------------------------ +!* 1. specify large scale parameters at half levels +!* adjust temperature fields if staticly unstable +!* find level of maximum vertical velocity +! ----------------------------------------------------------- + do jk=2,klev + do jl=1,klon + ptenh(jl,jk)=(max(cpd*pten(jl,jk-1)+pgeo(jl,jk-1), & + & cpd*pten(jl,jk)+pgeo(jl,jk))-pgeoh(jl,jk))*rcpd + pqenh(jl,jk) = pqen(jl,jk-1) + pqsenh(jl,jk)= pqsen(jl,jk-1) + zph(jl)=paph(jl,jk) + loflag(jl)=.true. + end do + + if ( jk >= klev-1 .or. jk < 2 ) cycle + ik=jk + icall=0 + call cuadjtqn(klon,klev,ik,zph,ptenh,pqsenh,loflag,icall) + do jl=1,klon + pqenh(jl,jk)=min(pqen(jl,jk-1),pqsen(jl,jk-1)) & + & +(pqsenh(jl,jk)-pqsen(jl,jk-1)) + pqenh(jl,jk)=max(pqenh(jl,jk),0.) + end do + end do + + do jl=1,klon + ptenh(jl,klev)=(cpd*pten(jl,klev)+pgeo(jl,klev)- & + & pgeoh(jl,klev))*rcpd + pqenh(jl,klev)=pqen(jl,klev) + ptenh(jl,1)=pten(jl,1) + pqenh(jl,1)=pqen(jl,1) + klwmin(jl)=klev + zwmax(jl)=0. + end do + + do jk=klevm1,2,-1 + do jl=1,klon + zzs=max(cpd*ptenh(jl,jk)+pgeoh(jl,jk), & + & cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1)) + ptenh(jl,jk)=(zzs-pgeoh(jl,jk))*rcpd + end do + end do + + do jk=klev,3,-1 + do jl=1,klon + if(pverv(jl,jk).lt.zwmax(jl)) then + zwmax(jl)=pverv(jl,jk) + klwmin(jl)=jk + end if + end do + end do +!----------------------------------------------------------- +!* 2.0 initialize values for updrafts and downdrafts +!----------------------------------------------------------- + do jk=1,klev + ik=jk-1 + if(jk.eq.1) ik=1 + do jl=1,klon + ptu(jl,jk)=ptenh(jl,jk) + ptd(jl,jk)=ptenh(jl,jk) + pqu(jl,jk)=pqenh(jl,jk) + pqd(jl,jk)=pqenh(jl,jk) + plu(jl,jk)=0. + puu(jl,jk)=puen(jl,ik) + pud(jl,jk)=puen(jl,ik) + pvu(jl,jk)=pven(jl,ik) + pvd(jl,jk)=pven(jl,ik) + klab(jl,jk)=0 + end do + end do + return + end subroutine cuinin + +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cutypen & + & ( klon, klev, klevp1, klevm1, pqen,& + & ptenh, pqenh, pqsenh, pgeoh, paph,& + & hfx, qfx, pgeo, pqsen, pap,& + & pten, lndj, cutu, cuqu, culab,& + & ldcum, cubot, cutop, ktype, wbase, culu, kdpl ) +! zhang & wang iprc 2011-2013 +!***purpose. +! -------- +! to produce first guess updraught for cu-parameterizations +! calculates condensation level, and sets updraught base variables and +! first guess cloud type +!***interface +! --------- +! this routine is called from *cumastr*. +! input are environm. values of t,q,p,phi at half levels. +! it returns cloud types as follows; +! ktype=1 for deep cumulus +! ktype=2 for shallow cumulus +!***method. +! -------- +! based on a simplified updraught equation +! partial(hup)/partial(z)=eta(h - hup) +! eta is the entrainment rate for test parcel +! h stands for dry static energy or the total water specific humidity +! references: christian jakob, 2003: a new subcloud model for +! mass-flux convection schemes +! influence on triggering, updraft properties, and model +! climate, mon.wea.rev. +! 131, 2765-2778 +! and +! ifs documentation - cy36r1,cy38r1 +!***input variables: +! ptenh [ztenh] - environment temperature on half levels. (cuini) +! pqenh [zqenh] - env. specific humidity on half levels. (cuini) +! pgeoh [zgeoh] - geopotential on half levels, (mssflx) +! paph - pressure of half levels. (mssflx) +! rho - density of the lowest model level +! qfx - net upward moisture flux at the surface (kg/m^2/s) +! hfx - net upward heat flux at the surface (w/m^2) +!***variables output by cutype: +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! information for updraft parcel (ptu,pqu,plu,kcbot,klab,kdpl...) +! ---------------------------------------------------------------- +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- + integer klon, klev, klevp1, klevm1 + real(kind=kind_phys) ptenh(klon,klev), pqenh(klon,klev),& + & pqsen(klon,klev), pqsenh(klon,klev),& + & pgeoh(klon,klevp1), paph(klon,klevp1),& + & pap(klon,klev), pqen(klon,klev) + real(kind=kind_phys) pten(klon,klev) + real(kind=kind_phys) ptu(klon,klev),pqu(klon,klev),plu(klon,klev) + real(kind=kind_phys) pgeo(klon,klev) + integer klab(klon,klev) + integer kctop(klon),kcbot(klon) + + real(kind=kind_phys) qfx(klon),hfx(klon) + real(kind=kind_phys) zph(klon) + integer lndj(klon) + logical loflag(klon), deepflag(klon), resetflag(klon) + +! output variables + real(kind=kind_phys) cutu(klon,klev), cuqu(klon,klev), culu(klon,klev) + integer culab(klon,klev) + real(kind=kind_phys) wbase(klon) + integer ktype(klon),cubot(klon),cutop(klon),kdpl(klon) + logical ldcum(klon) + +! local variables + real(kind=kind_phys) zqold(klon) + real(kind=kind_phys) rho, part1, part2, root, conw, deltt, deltq + real(kind=kind_phys) eta(klon),dz(klon),coef(klon) + real(kind=kind_phys) dhen(klon,klev), dh(klon,klev) + real(kind=kind_phys) plude(klon,klev) + real(kind=kind_phys) kup(klon,klev) + real(kind=kind_phys) vptu(klon,klev),vten(klon,klev) + real(kind=kind_phys) zbuo(klon,klev),abuoy(klon,klev) + + real(kind=kind_phys) zz,zdken,zdq + real(kind=kind_phys) fscale,crirh1,pp + real(kind=kind_phys) atop1,atop2,abot + real(kind=kind_phys) tmix,zmix,qmix,pmix + real(kind=kind_phys) zlglac,dp + integer nk,is,ikb,ikt + + real(kind=kind_phys) zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp + real(kind=kind_phys) zpdifftop, zpdiffbot + integer zcbase(klon), itoppacel(klon) + integer jl,jk,ik,icall,levels + logical needreset, lldcum(klon) +!-------------------------------------------------------------- + do jl=1,klon + kcbot(jl)=klev + kctop(jl)=klev + kdpl(jl) =klev + ktype(jl)=0 + wbase(jl)=0. + ldcum(jl)=.false. + end do + +!----------------------------------------------------------- +! let's do test,and check the shallow convection first +! the first level is klev +! define deltat and deltaq +!----------------------------------------------------------- + do jk=1,klev + do jl=1,klon + plu(jl,jk)=culu(jl,jk) ! parcel liquid water + ptu(jl,jk)=cutu(jl,jk) ! parcel temperature + pqu(jl,jk)=cuqu(jl,jk) ! parcel specific humidity + klab(jl,jk)=culab(jl,jk) + dh(jl,jk)=0.0 ! parcel dry static energy + dhen(jl,jk)=0.0 ! environment dry static energy + kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + vptu(jl,jk)=0.0 ! parcel virtual temperature considering water-loading + vten(jl,jk)=0.0 ! environment virtual temperature + zbuo(jl,jk)=0.0 ! parcel buoyancy + abuoy(jl,jk)=0.0 + end do + end do + + do jl=1,klon + zqold(jl) = 0. + lldcum(jl) = .false. + loflag(jl) = .true. + end do + +! check the levels from lowest level to second top level + do jk=klevm1,2,-1 + +! define the variables at the first level + if(jk .eq. klevm1) then + do jl=1,klon + rho=pap(jl,klev)/ & + & (rd*(pten(jl,klev)*(1.+vtmpc1*pqen(jl,klev)))) + hfx(jl) = hfx(jl)*rho*cpd + qfx(jl) = qfx(jl)*rho + part1 = 1.5*0.4*pgeo(jl,klev)/ & + & (rho*pten(jl,klev)) + part2 = -hfx(jl)*rcpd-vtmpc1*pten(jl,klev)*qfx(jl) + root = 0.001-part1*part2 + if(part2 .lt. 0.) then + conw = 1.2*(root)**t13 + deltt = max(1.5*hfx(jl)/(rho*cpd*conw),0.) + deltq = max(1.5*qfx(jl)/(rho*conw),0.) + kup(jl,klev) = 0.5*(conw**2) + pqu(jl,klev)= pqenh(jl,klev) + deltq + dhen(jl,klev)= pgeoh(jl,klev) + ptenh(jl,klev)*cpd + dh(jl,klev) = dhen(jl,klev) + deltt*cpd + ptu(jl,klev) = (dh(jl,klev)-pgeoh(jl,klev))*rcpd + vptu(jl,klev)=ptu(jl,klev)*(1.+vtmpc1*pqu(jl,klev)) + vten(jl,klev)=ptenh(jl,klev)*(1.+vtmpc1*pqenh(jl,klev)) + zbuo(jl,klev)=(vptu(jl,klev)-vten(jl,klev))/vten(jl,klev) + klab(jl,klev) = 1 + else + loflag(jl) = .false. + end if + end do + end if + + is=0 + do jl=1,klon + if(loflag(jl))then + is=is+1 + endif + enddo + if(is.eq.0) exit + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(loflag(jl)) then + eta(jl) = 0.55/(pgeo(jl,jk)*zrg)+1.e-4 + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= 0.5*eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& + & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) + pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& + & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) + ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd + zqold(jl) = pqu(jl,jk) + zph(jl)=paph(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + do jl=1,klon + if( loflag(jl) ) then + zdq = max((zqold(jl) - pqu(jl,jk)),0.) + plu(jl,jk) = plu(jl,jk+1) + zdq + zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & + (1.-foealfa(ptu(jl,jk+1)))) + plu(jl,jk) = min(plu(jl,jk),5.e-3) + dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) +! compute the updraft speed + vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& + ralfdcp*zlglac + vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) + abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g + atop1 = 1.0 - 2.*coef(jl) + atop2 = 2.0*dz(jl)*abuoy(jl,jk) + abot = 1.0 + 2.*coef(jl) + kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot + +! let's find the exact cloud base + if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then + ik = jk + 1 + zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) + zqsu = min(0.5,zqsu) + zcor = 1./(1.-vtmpc1*zqsu) + zqsu = zqsu*zcor + zdq = min(0.,pqu(jl,ik)-zqsu) + zalfaw = foealfa(ptu(jl,ik)) + zfacw = c5les/((ptu(jl,ik)-c4les)**2) + zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) + zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci + zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) + zcor = 1./(1.-vtmpc1*zesdp) + zdqsdt = zfac*zcor*zqsu + zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) + zdp = zdq/(zdqsdt*zdtdp) + zcbase(jl) = paph(jl,ik) + zdp +! chose nearest half level as cloud base (jk or jk+1) + zpdifftop = zcbase(jl) - paph(jl,jk) + zpdiffbot = paph(jl,jk+1) - zcbase(jl) + if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then + ikb = min(klev-1,jk+1) + klab(jl,ikb) = 2 + klab(jl,jk) = 2 + kcbot(jl) = ikb + plu(jl,jk+1) = 1.0e-8 + else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then + klab(jl,jk) = 2 + kcbot(jl) = jk + end if + end if + + if(kup(jl,jk) .lt. 0.)then + loflag(jl) = .false. + if(plu(jl,jk+1) .gt. 0.) then + kctop(jl) = jk + lldcum(jl) = .true. + else + lldcum(jl) = .false. + end if + else + if(plu(jl,jk) .gt. 0.)then + klab(jl,jk)=2 + else + klab(jl,jk)=1 + end if + end if + end if + end do + + end do ! end all the levels + + do jl=1,klon + ikb = kcbot(jl) + ikt = kctop(jl) + if(paph(jl,ikb) - paph(jl,ikt) > zdnoprc) lldcum(jl) = .false. + if(lldcum(jl)) then + ktype(jl) = 2 + ldcum(jl) = .true. + wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) + cubot(jl) = ikb + cutop(jl) = ikt + kdpl(jl) = klev + else + cutop(jl) = -1 + cubot(jl) = -1 + kdpl(jl) = klev - 1 + ldcum(jl) = .false. + wbase(jl) = 0. + end if + end do + + do jk=klev,1,-1 + do jl=1,klon + ikt = kctop(jl) + if(jk .ge. ikt)then + culab(jl,jk) = klab(jl,jk) + cutu(jl,jk) = ptu(jl,jk) + cuqu(jl,jk) = pqu(jl,jk) + culu(jl,jk) = plu(jl,jk) + end if + end do + end do + +!----------------------------------------------------------- +! next, let's check the deep convection +! the first level is klevm1-1 +! define deltat and deltaq +!---------------------------------------------------------- +! we check the parcel starting level by level +! assume the mix-layer is 60hPa + deltt = 0.2 + deltq = 1.0e-4 + do jl=1,klon + deepflag(jl) = .false. + end do + + do jk=klev,1,-1 + do jl=1,klon + if((paph(jl,klev+1)-paph(jl,jk)) .lt. 350.e2) itoppacel(jl) = jk + end do + end do + + do levels=klevm1-1,klevm1-20,-1 ! loop starts + do jk=1,klev + do jl=1,klon + plu(jl,jk)=0.0 ! parcel liquid water + ptu(jl,jk)=0.0 ! parcel temperature + pqu(jl,jk)=0.0 ! parcel specific humidity + dh(jl,jk)=0.0 ! parcel dry static energy + dhen(jl,jk)=0.0 ! environment dry static energy + kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + vptu(jl,jk)=0.0 ! parcel virtual temperature consideringwater-loading + vten(jl,jk)=0.0 ! environment virtual temperature + abuoy(jl,jk)=0.0 + zbuo(jl,jk)=0.0 + klab(jl,jk)=0 + end do + end do + + do jl=1,klon + kcbot(jl) = levels + kctop(jl) = levels + zqold(jl) = 0. + lldcum(jl) = .false. + resetflag(jl)= .false. + loflag(jl) = (.not. deepflag(jl)) .and. (levels.ge.itoppacel(jl)) + end do + +! start the inner loop to search the deep convection points + do jk=levels,2,-1 + is=0 + do jl=1,klon + if(loflag(jl))then + is=is+1 + endif + enddo + if(is.eq.0) exit + +! define the variables at the departure level + if(jk .eq. levels) then + do jl=1,klon + if(loflag(jl)) then + if((paph(jl,klev+1)-paph(jl,jk)) < 60.e2) then + tmix=0. + qmix=0. + zmix=0. + pmix=0. + do nk=jk+2,jk,-1 + if(pmix < 50.e2) then + dp = paph(jl,nk) - paph(jl,nk-1) + tmix=tmix+dp*ptenh(jl,nk) + qmix=qmix+dp*pqenh(jl,nk) + zmix=zmix+dp*pgeoh(jl,nk) + pmix=pmix+dp + end if + end do + tmix=tmix/pmix + qmix=qmix/pmix + zmix=zmix/pmix + else + tmix=ptenh(jl,jk+1) + qmix=pqenh(jl,jk+1) + zmix=pgeoh(jl,jk+1) + end if + + pqu(jl,jk+1) = qmix + deltq + dhen(jl,jk+1)= zmix + tmix*cpd + dh(jl,jk+1) = dhen(jl,jk+1) + deltt*cpd + ptu(jl,jk+1) = (dh(jl,jk+1)-pgeoh(jl,jk+1))*rcpd + kup(jl,jk+1) = 0.5 + klab(jl,jk+1)= 1 + vptu(jl,jk+1)=ptu(jl,jk+1)*(1.+vtmpc1*pqu(jl,jk+1)) + vten(jl,jk+1)=ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1)) + zbuo(jl,jk+1)=(vptu(jl,jk+1)-vten(jl,jk+1))/vten(jl,jk+1) + end if + end do + end if + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(loflag(jl)) then +! define the fscale + fscale = min(1.,(pqsen(jl,jk)/pqsen(jl,levels))**3) + eta(jl) = 1.75e-3*fscale + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= 0.5*eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& + & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) + pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& + & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) + ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd + zqold(jl) = pqu(jl,jk) + zph(jl)=paph(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + + do jl=1,klon + if( loflag(jl) ) then + zdq = max((zqold(jl) - pqu(jl,jk)),0.) + plu(jl,jk) = plu(jl,jk+1) + zdq + zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & + (1.-foealfa(ptu(jl,jk+1)))) + plu(jl,jk) = 0.5*plu(jl,jk) + dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) +! compute the updraft speed + vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& + ralfdcp*zlglac + vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) + abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g + atop1 = 1.0 - 2.*coef(jl) + atop2 = 2.0*dz(jl)*abuoy(jl,jk) + abot = 1.0 + 2.*coef(jl) + kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot +! let's find the exact cloud base + if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then + ik = jk + 1 + zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) + zqsu = min(0.5,zqsu) + zcor = 1./(1.-vtmpc1*zqsu) + zqsu = zqsu*zcor + zdq = min(0.,pqu(jl,ik)-zqsu) + zalfaw = foealfa(ptu(jl,ik)) + zfacw = c5les/((ptu(jl,ik)-c4les)**2) + zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) + zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci + zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) + zcor = 1./(1.-vtmpc1*zesdp) + zdqsdt = zfac*zcor*zqsu + zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) + zdp = zdq/(zdqsdt*zdtdp) + zcbase(jl) = paph(jl,ik) + zdp +! chose nearest half level as cloud base (jk or jk+1) + zpdifftop = zcbase(jl) - paph(jl,jk) + zpdiffbot = paph(jl,jk+1) - zcbase(jl) + if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then + ikb = min(klev-1,jk+1) + klab(jl,ikb) = 2 + klab(jl,jk) = 2 + kcbot(jl) = ikb + plu(jl,jk+1) = 1.0e-8 + else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then + klab(jl,jk) = 2 + kcbot(jl) = jk + end if + end if + + if(kup(jl,jk) .lt. 0.)then + loflag(jl) = .false. + if(plu(jl,jk+1) .gt. 0.) then + kctop(jl) = jk + lldcum(jl) = .true. + else + lldcum(jl) = .false. + end if + else + if(plu(jl,jk) .gt. 0.)then + klab(jl,jk)=2 + else + klab(jl,jk)=1 + end if + end if + end if + end do + + end do ! end all the levels + + needreset = .false. + do jl=1,klon + ikb = kcbot(jl) + ikt = kctop(jl) + if(paph(jl,ikb) - paph(jl,ikt) < zdnoprc) lldcum(jl) = .false. + if(lldcum(jl)) then + ktype(jl) = 1 + ldcum(jl) = .true. + deepflag(jl) = .true. + wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) + cubot(jl) = ikb + cutop(jl) = ikt + kdpl(jl) = levels+1 + needreset = .true. + resetflag(jl)= .true. + end if + end do + + if(needreset) then + do jk=klev,1,-1 + do jl=1,klon + if(resetflag(jl)) then + ikt = kctop(jl) + ikb = kdpl(jl) + if(jk .le. ikb .and. jk .ge. ikt )then + culab(jl,jk) = klab(jl,jk) + cutu(jl,jk) = ptu(jl,jk) + cuqu(jl,jk) = pqu(jl,jk) + culu(jl,jk) = plu(jl,jk) + else + culab(jl,jk) = 1 + cutu(jl,jk) = ptenh(jl,jk) + cuqu(jl,jk) = pqenh(jl,jk) + culu(jl,jk) = 0. + end if + if ( jk .lt. ikt ) culab(jl,jk) = 0 + end if + end do + end do + end if + + end do ! end all cycles + + return + end subroutine cutypen + +!----------------------------------------------------------------- +! level 3 subroutines 'cuascn' +!----------------------------------------------------------------- + subroutine cuascn & + & (klon, klev, klevp1, klevm1, ptenh,& + & pqenh, puen, pven, pten, pqen,& + & pqsen, pgeo, pgeoh, pap, paph,& + & pqte, pverv, klwmin, ldcum, phcbase,& + & ktype, klab, ptu, pqu, plu,& + & puu, pvu, pmfu, pmfub, & + & pmfus, pmfuq, pmful, plude, pdmfup,& + & kcbot, kctop, kctop0, kcum, ztmst,& + & pqsenh, plglac, lndj, wup, wbase, kdpl, pmfude_rate) + implicit none +! this routine does the calculations for cloud ascents +! for cumulus parameterization +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 +! y.wang iprc 11/01 modif. +! c.zhang iprc 05/12 modif. +!***purpose. +! -------- +! to produce cloud ascents for cu-parametrization +! (vertical profiles of t,q,l,u and v and corresponding +! fluxes as well as precipitation rates) +!***interface +! --------- +! this routine is called from *cumastr*. +!***method. +! -------- +! lift surface air dry-adiabatically to cloud base +! and then calculate moist ascent for +! entraining/detraining plume. +! entrainment and detrainment rates differ for +! shallow and deep cumulus convection. +! in case there is no penetrative or shallow convection +! check for possibility of mid level convection +! (cloud base values calculated in *cubasmc*) +!***externals +! --------- +! *cuadjtqn* adjust t and q due to condensation in ascent +! *cuentrn* calculate entrainment/detrainment rates +! *cubasmcn* calculate cloud base values for midlevel convection +!***reference +! --------- +! (tiedtke,1989) +!***input variables: +! ptenh [ztenh] - environ temperature on half levels. (cuini) +! pqenh [zqenh] - env. specific humidity on half levels. (cuini) +! puen - environment wind u-component. (mssflx) +! pven - environment wind v-component. (mssflx) +! pten - environment temperature. (mssflx) +! pqen - environment specific humidity. (mssflx) +! pqsen - environment saturation specific humidity. (mssflx) +! pgeo - geopotential. (mssflx) +! pgeoh [zgeoh] - geopotential on half levels, (mssflx) +! pap - pressure in pa. (mssflx) +! paph - pressure of half levels. (mssflx) +! pqte - moisture convergence (delta q/delta t). (mssflx) +! pverv - large scale vertical velocity (omega). (mssflx) +! klwmin [ilwmin] - level of minimum omega. (cuini) +! klab [ilab] - level label - 1: sub-cloud layer. +! 2: condensation level (cloud base) +! pmfub [zmfub] - updraft mass flux at cloud base. (cumastr) +!***variables modified by cuasc: +! ldcum - logical denoting profiles. (cubase) +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! ptu - cloud temperature. +! pqu - cloud specific humidity. +! plu - cloud liquid water (moisture condensed out) +! puu [zuu] - cloud momentum u-component. +! pvu [zvu] - cloud momentum v-component. +! pmfu - updraft mass flux. +! pmfus [zmfus] - updraft flux of dry static energy. (cubasmc) +! pmfuq [zmfuq] - updraft flux of specific humidity. +! pmful [zmful] - updraft flux of cloud liquid water. +! plude - liquid water returned to environment by detrainment. +! pdmfup [zmfup] - +! kcbot - cloud base level. (cubase) +! kctop - cloud top level +! kctop0 [ictop0] - estimate of cloud top. (cumastr) +! kcum [icum] - flag to control the call + + integer klev,klon,klevp1,klevm1 + real(kind=kind_phys) ptenh(klon,klev), pqenh(klon,klev), & + & puen(klon,klev), pven(klon,klev),& + & pten(klon,klev), pqen(klon,klev),& + & pgeo(klon,klev), pgeoh(klon,klevp1),& + & pap(klon,klev), paph(klon,klevp1),& + & pqsen(klon,klev), pqte(klon,klev),& + & pverv(klon,klev), pqsenh(klon,klev) + real(kind=kind_phys) ptu(klon,klev), pqu(klon,klev),& + & puu(klon,klev), pvu(klon,klev),& + & pmfu(klon,klev), zph(klon),& + & pmfub(klon), & + & pmfus(klon,klev), pmfuq(klon,klev),& + & plu(klon,klev), plude(klon,klev),& + & pmful(klon,klev), pdmfup(klon,klev) + real(kind=kind_phys) zdmfen(klon), zdmfde(klon),& + & zmfuu(klon), zmfuv(klon),& + & zpbase(klon), zqold(klon) + real(kind=kind_phys) phcbase(klon), zluold(klon) + real(kind=kind_phys) zprecip(klon), zlrain(klon,klev) + real(kind=kind_phys) zbuo(klon,klev), kup(klon,klev) + real(kind=kind_phys) wup(klon) + real(kind=kind_phys) wbase(klon), zodetr(klon,klev) + real(kind=kind_phys) plglac(klon,klev) + + real(kind=kind_phys) eta(klon),dz(klon) + + integer klwmin(klon), ktype(klon),& + & klab(klon,klev), kcbot(klon),& + & kctop(klon), kctop0(klon) + integer lndj(klon) + logical ldcum(klon), loflag(klon) + logical llo2,llo3, llo1(klon) + + integer kdpl(klon) + real(kind=kind_phys) zoentr(klon), zdpmean(klon) + real(kind=kind_phys) pdmfen(klon,klev), pmfude_rate(klon,klev) +! local variables + integer jl,jk + integer ikb,icum,itopm2,ik,icall,is,kcum,jlm,jll + integer jlx(klon) + real(kind=kind_phys) ztmst,zcons2,zfacbuo,zprcdgw,z_cwdrag,z_cldmax,z_cwifrac,z_cprc2 + real(kind=kind_phys) zmftest,zmfmax,zqeen,zseen,zscde,zqude + real(kind=kind_phys) zmfusk,zmfuqk,zmfulk + real(kind=kind_phys) zbc,zbe,zkedke,zmfun,zwu,zprcon,zdt,zcbf,zzco + real(kind=kind_phys) zlcrit,zdfi,zc,zd,zint,zlnew,zvw,zvi,zalfaw,zrold + real(kind=kind_phys) zrnew,zz,zdmfeu,zdmfdu,dp + real(kind=kind_phys) zfac,zbuoc,zdkbuo,zdken,zvv,zarg,zchange,zxe,zxs,zdshrd + real(kind=kind_phys) atop1,atop2,abot +!-------------------------------- +!* 1. specify parameters +!-------------------------------- + zcons2=3./(g*ztmst) + zfacbuo = 0.5/(1.+0.5) + zprcdgw = cprcon*zrg + z_cldmax = 5.e-3 + z_cwifrac = 0.5 + z_cprc2 = 0.5 + z_cwdrag = (3.0/8.0)*0.506/0.2 +!--------------------------------- +! 2. set default values +!--------------------------------- + llo3 = .false. + do jl=1,klon + zluold(jl)=0. + wup(jl)=0. + zdpmean(jl)=0. + zoentr(jl)=0. + if(.not.ldcum(jl)) then + ktype(jl)=0 + kcbot(jl) = -1 + pmfub(jl) = 0. + pqu(jl,klev) = 0. + end if + end do + + ! initialize variout quantities + do jk=1,klev + do jl=1,klon + if(jk.ne.kcbot(jl)) plu(jl,jk)=0. + pmfu(jl,jk)=0. + pmfus(jl,jk)=0. + pmfuq(jl,jk)=0. + pmful(jl,jk)=0. + plude(jl,jk)=0. + plglac(jl,jk)=0. + pdmfup(jl,jk)=0. + zlrain(jl,jk)=0. + zbuo(jl,jk)=0. + kup(jl,jk)=0. + pdmfen(jl,jk) = 0. + pmfude_rate(jl,jk) = 0. + if(.not.ldcum(jl).or.ktype(jl).eq.3) klab(jl,jk)=0 + if(.not.ldcum(jl).and.paph(jl,jk).lt.4.e4) kctop0(jl)=jk + end do + end do + + do jl = 1,klon + if ( ktype(jl) == 3 ) ldcum(jl) = .false. + end do +!------------------------------------------------ +! 3.0 initialize values at cloud base level +!------------------------------------------------ + do jl=1,klon + kctop(jl)=kcbot(jl) + if(ldcum(jl)) then + ikb = kcbot(jl) + kup(jl,ikb) = 0.5*wbase(jl)**2 + pmfu(jl,ikb) = pmfub(jl) + pmfus(jl,ikb) = pmfub(jl)*(cpd*ptu(jl,ikb)+pgeoh(jl,ikb)) + pmfuq(jl,ikb) = pmfub(jl)*pqu(jl,ikb) + pmful(jl,ikb) = pmfub(jl)*plu(jl,ikb) + end if + end do +! +!----------------------------------------------------------------- +! 4. do ascent: subcloud layer (klab=1) ,clouds (klab=2) +! by doing first dry-adiabatic ascent and then +! by adjusting t,q and l accordingly in *cuadjtqn*, +! then check for buoyancy and set flags accordingly +!----------------------------------------------------------------- +! + do jk=klevm1,3,-1 +! specify cloud base values for midlevel convection +! in *cubasmc* in case there is not already convection +! --------------------------------------------------------------------- + ik=jk + call cubasmcn& + & (klon, klev, klevm1, ik, pten,& + & pqen, pqsen, puen, pven, pverv,& + & pgeo, pgeoh, ldcum, ktype, klab, zlrain,& + & pmfu, pmfub, kcbot, ptu,& + & pqu, plu, puu, pvu, pmfus,& + & pmfuq, pmful, pdmfup) + is = 0 + jlm = 0 + do jl = 1,klon + loflag(jl) = .false. + zprecip(jl) = 0. + llo1(jl) = .false. + is = is + klab(jl,jk+1) + if ( klab(jl,jk+1) == 0 ) klab(jl,jk) = 0 + if ( (ldcum(jl) .and. klab(jl,jk+1) == 2) .or. & + (ktype(jl) == 3 .and. klab(jl,jk+1) == 1) ) then + loflag(jl) = .true. + jlm = jlm + 1 + jlx(jlm) = jl + end if + zph(jl) = paph(jl,jk) + if ( ktype(jl) == 3 .and. jk == kcbot(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + if ( pmfub(jl) > zmfmax ) then + zfac = zmfmax/pmfub(jl) + pmfu(jl,jk+1) = pmfu(jl,jk+1)*zfac + pmfus(jl,jk+1) = pmfus(jl,jk+1)*zfac + pmfuq(jl,jk+1) = pmfuq(jl,jk+1)*zfac + pmfub(jl) = zmfmax + end if + pmfub(jl)=min(pmfub(jl),zmfmax) + end if + end do + + if(is.gt.0) llo3 = .true. +! +!* specify entrainment rates in *cuentr* +! ------------------------------------- + ik=jk + call cuentrn(klon,klev,ik,kcbot,ldcum,llo3, & + pgeoh,pmfu,zdmfen,zdmfde) +! +! do adiabatic ascent for entraining/detraining plume + if(llo3) then +! ------------------------------------------------------- +! + do jl = 1,klon + zqold(jl) = 0. + end do + do jll = 1 , jlm + jl = jlx(jll) + zdmfde(jl) = min(zdmfde(jl),0.75*pmfu(jl,jk+1)) + if ( jk == kcbot(jl) ) then + zoentr(jl) = -1.75e-3*(min(1.,pqen(jl,jk)/pqsen(jl,jk)) - & + 1.)*(pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk+1) + end if + if ( jk < kcbot(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + zxs = max(pmfu(jl,jk+1)-zmfmax,0.) + wup(jl) = wup(jl) + kup(jl,jk+1)*(pap(jl,jk+1)-pap(jl,jk)) + zdpmean(jl) = zdpmean(jl) + pap(jl,jk+1) - pap(jl,jk) + zdmfen(jl) = zoentr(jl) + if ( ktype(jl) >= 2 ) then + zdmfen(jl) = 2.0*zdmfen(jl) + zdmfde(jl) = zdmfen(jl) + end if + zdmfde(jl) = zdmfde(jl) * & + (1.6-min(1.,pqen(jl,jk)/pqsen(jl,jk))) + zmftest = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + zchange = max(zmftest-zmfmax,0.) + zxe = max(zchange-zxs,0.) + zdmfen(jl) = zdmfen(jl) - zxe + zchange = zchange - zxe + zdmfde(jl) = zdmfde(jl) + zchange + end if + pdmfen(jl,jk) = zdmfen(jl) - zdmfde(jl) + pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + zqeen = pqenh(jl,jk+1)*zdmfen(jl) + zseen = (cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*zdmfen(jl) + zscde = (cpd*ptu(jl,jk+1)+pgeoh(jl,jk+1))*zdmfde(jl) + zqude = pqu(jl,jk+1)*zdmfde(jl) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + zmfusk = pmfus(jl,jk+1) + zseen - zscde + zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude + zmfulk = pmful(jl,jk+1) - plude(jl,jk) + plu(jl,jk) = zmfulk*(1./max(cmfcmin,pmfu(jl,jk))) + pqu(jl,jk) = zmfuqk*(1./max(cmfcmin,pmfu(jl,jk))) + ptu(jl,jk) = (zmfusk * & + (1./max(cmfcmin,pmfu(jl,jk)))-pgeoh(jl,jk))*rcpd + ptu(jl,jk) = max(100.,ptu(jl,jk)) + ptu(jl,jk) = min(400.,ptu(jl,jk)) + zqold(jl) = pqu(jl,jk) + zlrain(jl,jk) = zlrain(jl,jk+1)*(pmfu(jl,jk+1)-zdmfde(jl)) * & + (1./max(cmfcmin,pmfu(jl,jk))) + zluold(jl) = plu(jl,jk) + end do +! reset to environmental values if below departure level + do jl = 1,klon + if ( jk > kdpl(jl) ) then + ptu(jl,jk) = ptenh(jl,jk) + pqu(jl,jk) = pqenh(jl,jk) + plu(jl,jk) = 0. + zluold(jl) = plu(jl,jk) + end if + end do +!* do corrections for moist ascent +!* by adjusting t,q and l in *cuadjtq* +!------------------------------------------------ + ik=jk + icall=1 +! + if ( jlm > 0 ) then + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + end if +! compute the upfraft speed in cloud layer + do jll = 1 , jlm + jl = jlx(jll) + if ( pqu(jl,jk) /= zqold(jl) ) then + plglac(jl,jk) = plu(jl,jk) * & + ((1.-foealfa(ptu(jl,jk)))- & + (1.-foealfa(ptu(jl,jk+1)))) + ptu(jl,jk) = ptu(jl,jk) + ralfdcp*plglac(jl,jk) + end if + end do + do jll = 1 , jlm + jl = jlx(jll) + if ( pqu(jl,jk) /= zqold(jl) ) then + klab(jl,jk) = 2 + plu(jl,jk) = plu(jl,jk) + zqold(jl) - pqu(jl,jk) + zbc = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk+1) - & + zlrain(jl,jk+1)) + zbe = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = zbc - zbe +! set flags for the case of midlevel convection + if ( ktype(jl) == 3 .and. klab(jl,jk+1) == 1 ) then + if ( zbuo(jl,jk) > -0.5 ) then + ldcum(jl) = .true. + kctop(jl) = jk + kup(jl,jk) = 0.5 + else + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + plude(jl,jk) = 0. + plu(jl,jk) = 0. + end if + end if + if ( klab(jl,jk+1) == 2 ) then + if ( zbuo(jl,jk) < 0. ) then + ptenh(jl,jk) = 0.5*(pten(jl,jk)+pten(jl,jk-1)) + pqenh(jl,jk) = 0.5*(pqen(jl,jk)+pqen(jl,jk-1)) + zbuo(jl,jk) = zbc - ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + end if + zbuoc = (zbuo(jl,jk) / & + (ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)))+zbuo(jl,jk+1) / & + (ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1))))*0.5 + zdkbuo = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zfacbuo*zbuoc +! mixing and "pressure" gradient term in upper troposphere + if ( zdmfen(jl) > 0. ) then + zdken = min(1.,(1.+z_cwdrag)*zdmfen(jl) / & + max(cmfcmin,pmfu(jl,jk+1))) + else + zdken = min(1.,(1.+z_cwdrag)*zdmfde(jl) / & + max(cmfcmin,pmfu(jl,jk+1))) + end if + kup(jl,jk) = (kup(jl,jk+1)*(1.-zdken)+zdkbuo) / & + (1.+zdken) + if ( zbuo(jl,jk) < 0. ) then + zkedke = kup(jl,jk)/max(1.e-10,kup(jl,jk+1)) + zkedke = max(0.,min(1.,zkedke)) + zmfun = sqrt(zkedke)*pmfu(jl,jk+1) !* (1.6-min(1.,pqen(jl,jk) / & + ! pqsen(jl,jk))) + zdmfde(jl) = max(zdmfde(jl),pmfu(jl,jk+1)-zmfun) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + end if + if ( zbuo(jl,jk) > -0.2 ) then + ikb = kcbot(jl) + zoentr(jl) = 1.75e-3*(0.3-(min(1.,pqen(jl,jk-1) / & + pqsen(jl,jk-1))-1.))*(pgeoh(jl,jk-1)-pgeoh(jl,jk)) * & + zrg*min(1.,pqsen(jl,jk)/pqsen(jl,ikb))**3 + zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk) + else + zoentr(jl) = 0. + end if +! erase values if below departure level + if ( jk > kdpl(jl) ) then + pmfu(jl,jk) = pmfu(jl,jk+1) + kup(jl,jk) = 0.5 + end if + if ( kup(jl,jk) > 0. .and. pmfu(jl,jk) > 0. ) then + kctop(jl) = jk + llo1(jl) = .true. + else + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + kup(jl,jk) = 0. + zdmfde(jl) = pmfu(jl,jk+1) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + end if +! save detrainment rates for updraught + if ( pmfu(jl,jk+1) > 0. ) pmfude_rate(jl,jk) = zdmfde(jl) + end if + else if ( ktype(jl) == 2 .and. pqu(jl,jk) == zqold(jl) ) then + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + kup(jl,jk) = 0. + zdmfde(jl) = pmfu(jl,jk+1) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + pmfude_rate(jl,jk) = zdmfde(jl) + end if + end do + + do jl = 1,klon + if ( llo1(jl) ) then +! conversions only proceeds if plu is greater than a threshold liquid water +! content of 0.3 g/kg over water and 0.5 g/kg over land to prevent precipitation +! generation from small water contents. + if ( lndj(jl).eq.1 ) then + zdshrd = 5.e-4 + else + zdshrd = 3.e-4 + end if + ikb=kcbot(jl) + if ( plu(jl,jk) > zdshrd )then +! if ((paph(jl,ikb)-paph(jl,jk))>zdnoprc) then + zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk+1)))) + zprcon = zprcdgw/(0.75*zwu) +! PARAMETERS FOR BERGERON-FINDEISEN PROCESS (T < -5C) + zdt = min(rtber-rtice,max(rtber-ptu(jl,jk),0.)) + zcbf = 1. + z_cprc2*sqrt(zdt) + zzco = zprcon*zcbf + zlcrit = zdshrd/zcbf + zdfi = pgeoh(jl,jk) - pgeoh(jl,jk+1) + zc = (plu(jl,jk)-zluold(jl)) + zarg = (plu(jl,jk)/zlcrit)**2 + if ( zarg < 25.0 ) then + zd = zzco*(1.-exp(-zarg))*zdfi + else + zd = zzco*zdfi + end if + zint = exp(-zd) + zlnew = zluold(jl)*zint + zc/zd*(1.-zint) + zlnew = max(0.,min(plu(jl,jk),zlnew)) + zlnew = min(z_cldmax,zlnew) + zprecip(jl) = max(0.,zluold(jl)+zc-zlnew) + pdmfup(jl,jk) = zprecip(jl)*pmfu(jl,jk) + zlrain(jl,jk) = zlrain(jl,jk) + zprecip(jl) + plu(jl,jk) = zlnew + end if + end if + end do + do jl = 1, klon + if ( llo1(jl) ) then + if ( zlrain(jl,jk) > 0. ) then + zvw = 21.18*zlrain(jl,jk)**0.2 + zvi = z_cwifrac*zvw + zalfaw = foealfa(ptu(jl,jk)) + zvv = zalfaw*zvw + (1.-zalfaw)*zvi + zrold = zlrain(jl,jk) - zprecip(jl) + zc = zprecip(jl) + zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk)))) + zd = zvv/zwu + zint = exp(-zd) + zrnew = zrold*zint + zc/zd*(1.-zint) + zrnew = max(0.,min(zlrain(jl,jk),zrnew)) + zlrain(jl,jk) = zrnew + end if + end if + end do + do jll = 1 , jlm + jl = jlx(jll) + pmful(jl,jk) = plu(jl,jk)*pmfu(jl,jk) + pmfus(jl,jk) = (cpd*ptu(jl,jk)+pgeoh(jl,jk))*pmfu(jl,jk) + pmfuq(jl,jk) = pqu(jl,jk)*pmfu(jl,jk) + end do + end if + end do +!---------------------------------------------------------------------- +! 5. final calculations +! ------------------ + do jl = 1,klon + if ( kctop(jl) == -1 ) ldcum(jl) = .false. + kcbot(jl) = max(kcbot(jl),kctop(jl)) + if ( ldcum(jl) ) then + wup(jl) = max(1.e-2,wup(jl)/max(1.,zdpmean(jl))) + wup(jl) = sqrt(2.*wup(jl)) + end if + end do + + return + end subroutine cuascn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cudlfsn & + & (klon, klev, & + & kcbot, kctop, lndj, ldcum, & + & ptenh, pqenh, puen, pven, & + & pten, pqsen, pgeo, & + & pgeoh, paph, ptu, pqu, plu,& + & puu, pvu, pmfub, prfl, & + & ptd, pqd, pud, pvd, & + & pmfd, pmfds, pmfdq, pdmfdp, & + & kdtop, lddraf) + +! this routine calculates level of free sinking for +! cumulus downdrafts and specifies t,q,u and v values + +! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 + +! purpose. +! -------- +! to produce lfs-values for cumulus downdrafts +! for massflux cumulus parameterization + +! interface +! --------- +! this routine is called from *cumastr*. +! input are environmental values of t,q,u,v,p,phi +! and updraft values t,q,u and v and also +! cloud base massflux and cu-precipitation rate. +! it returns t,q,u and v values and massflux at lfs. + +! method. + +! check for negative buoyancy of air of equal parts of +! moist environmental air and cloud air. + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kcbot* cloud base level +! *kctop* cloud top level + +! input parameters (logical): + +! *lndj* land sea mask (1 for land) +! *ldcum* flag: .true. for convective points + +! input parameters (real(kind=kind_phys)): + +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *puen* provisional environment u-velocity (t+1) m/s +! *pven* provisional environment v-velocity (t+1) m/s +! *pten* provisional environment temperature (t+1) k +! *pqsen* environment spec. saturation humidity (t+1) kg/kg +! *pgeo* geopotential m2/s2 +! *pgeoh* geopotential on half levels m2/s2 +! *paph* provisional pressure on half levels pa +! *ptu* temperature in updrafts k +! *pqu* spec. humidity in updrafts kg/kg +! *plu* liquid water content in updrafts kg/kg +! *puu* u-velocity in updrafts m/s +! *pvu* v-velocity in updrafts m/s +! *pmfub* massflux in updrafts at cloud base kg/(m2*s) + +! updated parameters (real(kind=kind_phys)): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real(kind=kind_phys)): + +! *ptd* temperature in downdrafts k +! *pqd* spec. humidity in downdrafts kg/kg +! *pud* u-velocity in downdrafts m/s +! *pvd* v-velocity in downdrafts m/s +! *pmfd* massflux in downdrafts kg/(m2*s) +! *pmfds* flux of dry static energy in downdrafts j/(m2*s) +! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) +! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + +! output parameters (integer): + +! *kdtop* top level of downdrafts + +! output parameters (logical): + +! *lddraf* .true. if downdrafts exist + +! externals +! --------- +! *cuadjtq* for calculating wet bulb t and q at lfs +!---------------------------------------------------------------------- + implicit none + + integer klev,klon + real(kind=kind_phys) ptenh(klon,klev), pqenh(klon,klev), & + & puen(klon,klev), pven(klon,klev), & + & pten(klon,klev), pqsen(klon,klev), & + & pgeo(klon,klev), & + & pgeoh(klon,klev+1), paph(klon,klev+1),& + & ptu(klon,klev), pqu(klon,klev), & + & puu(klon,klev), pvu(klon,klev), & + & plu(klon,klev), & + & pmfub(klon), prfl(klon) + + real(kind=kind_phys) ptd(klon,klev), pqd(klon,klev), & + & pud(klon,klev), pvd(klon,klev), & + & pmfd(klon,klev), pmfds(klon,klev), & + & pmfdq(klon,klev), pdmfdp(klon,klev) + integer kcbot(klon), kctop(klon), & + & kdtop(klon), ikhsmin(klon) + logical ldcum(klon), & + & lddraf(klon) + integer lndj(klon) + + real(kind=kind_phys) ztenwb(klon,klev), zqenwb(klon,klev), & + & zcond(klon), zph(klon), & + & zhsmin(klon) + logical llo2(klon) +! local variables + integer jl,jk + integer is,ik,icall,ike + real(kind=kind_phys) zhsk,zttest,zqtest,zbuo,zmftop + +!---------------------------------------------------------------------- + +! 1. set default values for downdrafts +! --------------------------------- + do jl=1,klon + lddraf(jl)=.false. + kdtop(jl)=klev+1 + ikhsmin(jl)=klev+1 + zhsmin(jl)=1.e8 + enddo +!---------------------------------------------------------------------- + +! 2. determine level of free sinking: +! downdrafts shall start at model level of minimum +! of saturation moist static energy or below +! respectively + +! for every point and proceed as follows: + +! (1) determine level of minimum of hs +! (2) determine wet bulb environmental t and q +! (3) do mixing with cumulus cloud air +! (4) check for negative buoyancy +! (5) if buoyancy>0 repeat (2) to (4) for next +! level below + +! the assumption is that air of downdrafts is mixture +! of 50% cloud air + 50% environmental air at wet bulb +! temperature (i.e. which became saturated due to +! evaporation of rain and cloud water) +! ---------------------------------------------------- + do jk=3,klev-2 + do jl=1,klon + zhsk=cpd*pten(jl,jk)+pgeo(jl,jk) + & + & foelhm(pten(jl,jk))*pqsen(jl,jk) + if(zhsk .lt. zhsmin(jl)) then + zhsmin(jl) = zhsk + ikhsmin(jl)= jk + end if + end do + end do + + + ike=klev-3 + do jk=3,ike + +! 2.1 calculate wet-bulb temperature and moisture +! for environmental air in *cuadjtq* +! ------------------------------------------- + is=0 + do jl=1,klon + ztenwb(jl,jk)=ptenh(jl,jk) + zqenwb(jl,jk)=pqenh(jl,jk) + zph(jl)=paph(jl,jk) + llo2(jl)=ldcum(jl).and.prfl(jl).gt.0..and..not.lddraf(jl).and. & + & (jk.lt.kcbot(jl).and.jk.gt.kctop(jl)).and. jk.ge.ikhsmin(jl) + if(llo2(jl))then + is=is+1 + endif + enddo + if(is.eq.0) cycle + + ik=jk + icall=2 + call cuadjtqn & + & ( klon, klev, ik, zph, ztenwb, zqenwb, llo2, icall) + +! 2.2 do mixing of cumulus and environmental air +! and check for negative buoyancy. +! then set values for downdraft at lfs. +! ---------------------------------------- + do jl=1,klon + if(llo2(jl)) then + zttest=0.5*(ptu(jl,jk)+ztenwb(jl,jk)) + zqtest=0.5*(pqu(jl,jk)+zqenwb(jl,jk)) + zbuo=zttest*(1.+vtmpc1 *zqtest)- & + & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) + zcond(jl)=pqenh(jl,jk)-zqenwb(jl,jk) + zmftop=-cmfdeps*pmfub(jl) + if(zbuo.lt.0..and.prfl(jl).gt.10.*zmftop*zcond(jl)) then + kdtop(jl)=jk + lddraf(jl)=.true. + ptd(jl,jk)=zttest + pqd(jl,jk)=zqtest + pmfd(jl,jk)=zmftop + pmfds(jl,jk)=pmfd(jl,jk)*(cpd*ptd(jl,jk)+pgeoh(jl,jk)) + pmfdq(jl,jk)=pmfd(jl,jk)*pqd(jl,jk) + pdmfdp(jl,jk-1)=-0.5*pmfd(jl,jk)*zcond(jl) + prfl(jl)=prfl(jl)+pdmfdp(jl,jk-1) + endif + endif + enddo + + enddo + + return + end subroutine cudlfsn + +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- +!********************************************** +! subroutine cuddrafn +!********************************************** + subroutine cuddrafn & + & ( klon, klev, lddraf & + & , ptenh, pqenh, puen, pven & + & , pgeo, pgeoh, paph, prfl & + & , ptd, pqd, pud, pvd, pmfu & + & , pmfd, pmfds, pmfdq, pdmfdp, pmfdde_rate ) + +! this routine calculates cumulus downdraft descent + +! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 + +! purpose. +! -------- +! to produce the vertical profiles for cumulus downdrafts +! (i.e. t,q,u and v and fluxes) + +! interface +! --------- + +! this routine is called from *cumastr*. +! input is t,q,p,phi,u,v at half levels. +! it returns fluxes of s,q and evaporation rate +! and u,v at levels where downdraft occurs + +! method. +! -------- +! calculate moist descent for entraining/detraining plume by +! a) moving air dry-adiabatically to next level below and +! b) correcting for evaporation to obtain saturated state. + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels + +! input parameters (logical): + +! *lddraf* .true. if downdrafts exist + +! input parameters (real(kind=kind_phys)): + +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *puen* provisional environment u-velocity (t+1) m/s +! *pven* provisional environment v-velocity (t+1) m/s +! *pgeo* geopotential m2/s2 +! *pgeoh* geopotential on half levels m2/s2 +! *paph* provisional pressure on half levels pa +! *pmfu* massflux updrafts kg/(m2*s) + +! updated parameters (real(kind=kind_phys)): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real(kind=kind_phys)): + +! *ptd* temperature in downdrafts k +! *pqd* spec. humidity in downdrafts kg/kg +! *pud* u-velocity in downdrafts m/s +! *pvd* v-velocity in downdrafts m/s +! *pmfd* massflux in downdrafts kg/(m2*s) +! *pmfds* flux of dry static energy in downdrafts j/(m2*s) +! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) +! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + +! externals +! --------- +! *cuadjtq* for adjusting t and q due to evaporation in +! saturated descent +!---------------------------------------------------------------------- + implicit none + + integer klev,klon + real(kind=kind_phys) ptenh(klon,klev), pqenh(klon,klev), & + & puen(klon,klev), pven(klon,klev), & + & pgeoh(klon,klev+1), paph(klon,klev+1), & + & pgeo(klon,klev), pmfu(klon,klev) + + real(kind=kind_phys) ptd(klon,klev), pqd(klon,klev), & + & pud(klon,klev), pvd(klon,klev), & + & pmfd(klon,klev), pmfds(klon,klev), & + & pmfdq(klon,klev), pdmfdp(klon,klev), & + & prfl(klon) + real(kind=kind_phys) pmfdde_rate(klon,klev) + logical lddraf(klon) + + real(kind=kind_phys) zdmfen(klon), zdmfde(klon), & + & zcond(klon), zoentr(klon), & + & zbuoy(klon) + real(kind=kind_phys) zph(klon) + logical llo2(klon) + logical llo1 +! local variables + integer jl,jk + integer is,ik,icall,ike, itopde(klon) + real(kind=kind_phys) zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp + real(kind=kind_phys) zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk + +!---------------------------------------------------------------------- +! 1. calculate moist descent for cumulus downdraft by +! (a) calculating entrainment/detrainment rates, +! including organized entrainment dependent on +! negative buoyancy and assuming +! linear decrease of massflux in pbl +! (b) doing moist descent - evaporative cooling +! and moistening is calculated in *cuadjtq* +! (c) checking for negative buoyancy and +! specifying final t,q,u,v and downward fluxes +! ------------------------------------------------- + do jl=1,klon + zoentr(jl)=0. + zbuoy(jl)=0. + zdmfen(jl)=0. + zdmfde(jl)=0. + enddo + + do jk=klev,1,-1 + do jl=1,klon + pmfdde_rate(jl,jk) = 0. + if((paph(jl,klev+1)-paph(jl,jk)).lt. 60.e2) itopde(jl) = jk + end do + end do + + do jk=3,klev + is=0 + do jl=1,klon + zph(jl)=paph(jl,jk) + llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0. + if(llo2(jl)) then + is=is+1 + endif + enddo + if(is.eq.0) cycle + + do jl=1,klon + if(llo2(jl)) then + zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zdmfen(jl)=zentr + zdmfde(jl)=zentr + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + if(jk.gt.itopde(jl)) then + zdmfen(jl)=0. + zdmfde(jl)=pmfd(jl,itopde(jl))* & + & (paph(jl,jk)-paph(jl,jk-1))/ & + & (paph(jl,klev+1)-paph(jl,itopde(jl))) + endif + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + if(jk.le.itopde(jl)) then + zdz=-(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zzentr=zoentr(jl)*zdz*pmfd(jl,jk-1) + zdmfen(jl)=zdmfen(jl)+zzentr + zdmfen(jl)=max(zdmfen(jl),0.3*pmfd(jl,jk-1)) + zdmfen(jl)=max(zdmfen(jl),-0.75*pmfu(jl,jk)- & + & (pmfd(jl,jk-1)-zdmfde(jl))) + zdmfen(jl)=min(zdmfen(jl),0.) + endif + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + pmfd(jl,jk)=pmfd(jl,jk-1)+zdmfen(jl)-zdmfde(jl) + zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl) + zqeen=pqenh(jl,jk-1)*zdmfen(jl) + zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl) + zqdde=pqd(jl,jk-1)*zdmfde(jl) + zmfdsk=pmfds(jl,jk-1)+zseen-zsdde + zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde + pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk))) + ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))-& + & pgeoh(jl,jk))*rcpd + ptd(jl,jk)=min(400.,ptd(jl,jk)) + ptd(jl,jk)=max(100.,ptd(jl,jk)) + zcond(jl)=pqd(jl,jk) + endif + enddo + + ik=jk + icall=2 + call cuadjtqn(klon, klev, ik, zph, ptd, pqd, llo2, icall ) + + do jl=1,klon + if(llo2(jl)) then + zcond(jl)=zcond(jl)-pqd(jl,jk) + zbuo=ptd(jl,jk)*(1.+vtmpc1 *pqd(jl,jk))- & + & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) + if(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then + zrain=prfl(jl)/pmfu(jl,jk) + zbuo=zbuo-ptd(jl,jk)*zrain + endif + if(zbuo.ge.0 .or. prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then + pmfd(jl,jk)=0. + zbuo=0. + endif + pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk) + pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk) + zdmfdp=-pmfd(jl,jk)*zcond(jl) + pdmfdp(jl,jk-1)=zdmfdp + prfl(jl)=prfl(jl)+zdmfdp + +! compute organized entrainment for use at next level + zbuoyz=zbuo/ptenh(jl,jk) + zbuoyz=min(zbuoyz,0.0) + zdz=-(pgeo(jl,jk-1)-pgeo(jl,jk)) + zbuoy(jl)=zbuoy(jl)+zbuoyz*zdz + zoentr(jl)=g*zbuoyz*0.5/(1.+zbuoy(jl)) + pmfdde_rate(jl,jk) = -zdmfde(jl) + endif + enddo + + enddo + + return + end subroutine cuddrafn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cuflxn & + & ( klon, klev, ztmst & + & , pten, pqen, pqsen, ptenh, pqenh & + & , paph, pap, pgeoh, lndj, ldcum & + & , kcbot, kctop, kdtop, ktopm2 & + & , ktype, lddraf & + & , pmfu, pmfd, pmfus, pmfds & + & , pmfuq, pmfdq, pmful, plude & + & , pdmfup, pdmfdp, pdpmel, plglac & + & , prain, pmfdde_rate, pmflxr, pmflxs ) + +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 + +! purpose +! ------- + +! this routine does the final calculation of convective +! fluxes in the cloud layer and in the subcloud layer + +! interface +! --------- +! this routine is called from *cumastr*. + + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kcbot* cloud base level +! *kctop* cloud top level +! *kdtop* top level of downdrafts + +! input parameters (logical): + +! *lndj* land sea mask (1 for land) +! *ldcum* flag: .true. for convective points + +! input parameters (real(kind=kind_phys)): + +! *ztmst* time step for the physics s +! *pten* provisional environment temperature (t+1) k +! *pqen* provisional environment spec. humidity (t+1) kg/kg +! *pqsen* environment spec. saturation humidity (t+1) kg/kg +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *paph* provisional pressure on half levels pa +! *pap* provisional pressure on full levels pa +! *pgeoh* geopotential on half levels m2/s2 + +! updated parameters (integer): + +! *ktype* set to zero if ldcum=.false. + +! updated parameters (logical): + +! *lddraf* set to .false. if ldcum=.false. or kdtop= kdtop(jl) + if ( llddraf .and.jk.ge.kdtop(jl)) then + pmfds(jl,jk) = pmfds(jl,jk)-pmfd(jl,jk) * & + (cpd*ptenh(jl,jk)+pgeoh(jl,jk)) + pmfdq(jl,jk) = pmfdq(jl,jk)-pmfd(jl,jk)*pqenh(jl,jk) + else + pmfd(jl,jk) = 0. + pmfds(jl,jk) = 0. + pmfdq(jl,jk) = 0. + pdmfdp(jl,jk-1) = 0. + end if + if ( llddraf .and. pmfd(jl,jk) < 0. .and. & + abs(pmfd(jl,ikb)) < 1.e-20 ) then + idbas(jl) = jk + end if + else + pmfu(jl,jk)=0. + pmfd(jl,jk)=0. + pmfus(jl,jk)=0. + pmfds(jl,jk)=0. + pmfuq(jl,jk)=0. + pmfdq(jl,jk)=0. + pmful(jl,jk)=0. + plglac(jl,jk)=0. + pdmfup(jl,jk-1)=0. + pdmfdp(jl,jk-1)=0. + plude(jl,jk-1)=0. + endif + enddo + enddo + + do jl=1,klon + pmflxr(jl,klev+1) = 0. + pmflxs(jl,klev+1) = 0. + end do + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + ik=ikb+1 + zzp=((paph(jl,klev+1)-paph(jl,ik))/ & + & (paph(jl,klev+1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + pmfu(jl,ik)=pmfu(jl,ikb)*zzp + pmfus(jl,ik)=(pmfus(jl,ikb)- & + & foelhm(ptenh(jl,ikb))*pmful(jl,ikb))*zzp + pmfuq(jl,ik)=(pmfuq(jl,ikb)+pmful(jl,ikb))*zzp + pmful(jl,ik)=0. + endif + enddo + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.gt.kcbot(jl)+1) then + ikb=kcbot(jl)+1 + zzp=((paph(jl,klev+1)-paph(jl,jk))/ & + & (paph(jl,klev+1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + pmfu(jl,jk)=pmfu(jl,ikb)*zzp + pmfus(jl,jk)=pmfus(jl,ikb)*zzp + pmfuq(jl,jk)=pmfuq(jl,ikb)*zzp + pmful(jl,jk)=0. + endif + ik = idbas(jl) + llddraf = lddraf(jl) .and. jk > ik .and. ik < klev + if ( llddraf .and. ik == kcbot(jl)+1 ) then + zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ik))) + if ( ktype(jl) == 3 ) zzp = zzp*zzp + pmfd(jl,jk) = pmfd(jl,ik)*zzp + pmfds(jl,jk) = pmfds(jl,ik)*zzp + pmfdq(jl,jk) = pmfdq(jl,ik)*zzp + pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) + else if ( llddraf .and. ik /= kcbot(jl)+1 .and. jk == ik+1 ) then + pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) + end if + enddo + enddo +!* 2. calculate rain/snow fall rates +!* calculate melting of snow +!* calculate evaporation of precip +! ------------------------------- + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl) .and. jk >=kctop(jl)-1 ) then + prain(jl)=prain(jl)+pdmfup(jl,jk) + if(pmflxs(jl,jk).gt.0..and.pten(jl,jk).gt.tmelt) then + zcons1=zcons1a*(1.+0.5*(pten(jl,jk)-tmelt)) + zfac=zcons1*(paph(jl,jk+1)-paph(jl,jk)) + zsnmlt=min(pmflxs(jl,jk),zfac*(pten(jl,jk)-tmelt)) + pdpmel(jl,jk)=zsnmlt + pqsen(jl,jk)=foeewm(pten(jl,jk)-zsnmlt/zfac)/pap(jl,jk) + endif + zalfaw=foealfa(pten(jl,jk)) + ! + ! No liquid precipitation above melting level + ! + if ( pten(jl,jk) < tmelt .and. zalfaw > 0. ) then + plglac(jl,jk) = plglac(jl,jk)+zalfaw*(pdmfup(jl,jk)+pdmfdp(jl,jk)) + zalfaw = 0. + end if + pmflxr(jl,jk+1)=pmflxr(jl,jk)+zalfaw* & + & (pdmfup(jl,jk)+pdmfdp(jl,jk))+pdpmel(jl,jk) + pmflxs(jl,jk+1)=pmflxs(jl,jk)+(1.-zalfaw)* & + & (pdmfup(jl,jk)+pdmfdp(jl,jk))-pdpmel(jl,jk) + if(pmflxr(jl,jk+1)+pmflxs(jl,jk+1).lt.0.0) then + pdmfdp(jl,jk)=-(pmflxr(jl,jk)+pmflxs(jl,jk)+pdmfup(jl,jk)) + pmflxr(jl,jk+1)=0.0 + pmflxs(jl,jk+1)=0.0 + pdpmel(jl,jk) =0.0 + else if ( pmflxr(jl,jk+1) < 0. ) then + pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) + pmflxr(jl,jk+1) = 0. + else if ( pmflxs(jl,jk+1) < 0. ) then + pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) + pmflxs(jl,jk+1) = 0. + end if + endif + enddo + enddo + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.ge.kcbot(jl)) then + zrfl=pmflxr(jl,jk)+pmflxs(jl,jk) + if(zrfl.gt.1.e-20) then + zdrfl1=zcpecons*max(0.,pqsen(jl,jk)-pqen(jl,jk))*zcucov* & + & (sqrt(paph(jl,jk)/paph(jl,klev+1))/5.09e-3* & + & zrfl/zcucov)**0.5777* & + & (paph(jl,jk+1)-paph(jl,jk)) + zrnew=zrfl-zdrfl1 + zrmin=zrfl-zcucov*max(0.,rhevap(jl)*pqsen(jl,jk) & + & -pqen(jl,jk)) *zcons2*(paph(jl,jk+1)-paph(jl,jk)) + zrnew=max(zrnew,zrmin) + zrfln=max(zrnew,0.) + zdrfl=min(0.,zrfln-zrfl) + zdenom=1./max(1.e-20,pmflxr(jl,jk)+pmflxs(jl,jk)) + zalfaw=foealfa(pten(jl,jk)) + if ( pten(jl,jk) < tmelt ) zalfaw = 0. + zpdr=zalfaw*pdmfdp(jl,jk) + zpds=(1.-zalfaw)*pdmfdp(jl,jk) + pmflxr(jl,jk+1)=pmflxr(jl,jk)+zpdr & + & +pdpmel(jl,jk)+zdrfl*pmflxr(jl,jk)*zdenom + pmflxs(jl,jk+1)=pmflxs(jl,jk)+zpds & + & -pdpmel(jl,jk)+zdrfl*pmflxs(jl,jk)*zdenom + pdmfup(jl,jk)=pdmfup(jl,jk)+zdrfl + if ( pmflxr(jl,jk+1)+pmflxs(jl,jk+1) < 0. ) then + pdmfup(jl,jk) = pdmfup(jl,jk)-(pmflxr(jl,jk+1)+pmflxs(jl,jk+1)) + pmflxr(jl,jk+1) = 0. + pmflxs(jl,jk+1) = 0. + pdpmel(jl,jk) = 0. + else if ( pmflxr(jl,jk+1) < 0. ) then + pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) + pmflxr(jl,jk+1) = 0. + else if ( pmflxs(jl,jk+1) < 0. ) then + pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) + pmflxs(jl,jk+1) = 0. + end if + else + pmflxr(jl,jk+1)=0.0 + pmflxs(jl,jk+1)=0.0 + pdmfdp(jl,jk)=0.0 + pdpmel(jl,jk)=0.0 + endif + endif + enddo + enddo + + return + end subroutine cuflxn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & + lddraf,ztmst,paph,pgeoh,pgeo,pten,ptenh,pqen, & + pqenh,pqsen,plglac,plude,pmfu,pmfd,pmfus,pmfds, & + pmfuq,pmfdq,pmful,pdmfup,pdmfdp,pdpmel,ptent,ptenq,pcte) + implicit none + integer klon,klev,ktopm2 + integer kctop(klon), kdtop(klon) + logical ldcum(klon), lddraf(klon) + real(kind=kind_phys) ztmst + real(kind=kind_phys) paph(klon,klev+1), pgeoh(klon,klev+1) + real(kind=kind_phys) pgeo(klon,klev), pten(klon,klev), & + pqen(klon,klev), ptenh(klon,klev),& + pqenh(klon,klev), pqsen(klon,klev),& + plglac(klon,klev), plude(klon,klev) + real(kind=kind_phys) pmfu(klon,klev), pmfd(klon,klev),& + pmfus(klon,klev), pmfds(klon,klev),& + pmfuq(klon,klev), pmfdq(klon,klev),& + pmful(klon,klev), pdmfup(klon,klev),& + pdpmel(klon,klev), pdmfdp(klon,klev) + real(kind=kind_phys) ptent(klon,klev), ptenq(klon,klev) + real(kind=kind_phys) pcte(klon,klev) + +! local variables + integer jk , ik , jl + real(kind=kind_phys) zalv , zzp + real(kind=kind_phys) zdtdt(klon,klev) , zdqdt(klon,klev) , zdp(klon,klev) + !* 1.0 SETUP AND INITIALIZATIONS + ! ------------------------- + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + end if + end do + end do + + !----------------------------------------------------------------------- + !* 2.0 COMPUTE TENDENCIES + ! ------------------ + do jk = ktopm2 , klev + if ( jk < klev ) then + do jl = 1,klon + if ( ldcum(jl) ) then + zalv = foelhm(pten(jl,jk)) + zdtdt(jl,jk) = zdp(jl,jk)*rcpd * & + (pmfus(jl,jk+1)-pmfus(jl,jk)+pmfds(jl,jk+1) - & + pmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk))) + zdqdt(jl,jk) = zdp(jl,jk)*(pmfuq(jl,jk+1) - & + pmfuq(jl,jk)+pmfdq(jl,jk+1)-pmfdq(jl,jk)+pmful(jl,jk+1) - & + pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk)) + end if + end do + else + do jl = 1,klon + if ( ldcum(jl) ) then + zalv = foelhm(pten(jl,jk)) + zdtdt(jl,jk) = -zdp(jl,jk)*rcpd * & + (pmfus(jl,jk)+pmfds(jl,jk)+alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)+plude(jl,jk))) + zdqdt(jl,jk) = -zdp(jl,jk)*(pmfuq(jl,jk) + plude(jl,jk) + & + pmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) + end if + end do + end if + end do + !--------------------------------------------------------------- + !* 3.0 UPDATE TENDENCIES + ! ----------------- + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + ptent(jl,jk) = ptent(jl,jk) + zdtdt(jl,jk) + ptenq(jl,jk) = ptenq(jl,jk) + zdqdt(jl,jk) + pcte(jl,jk) = zdp(jl,jk)*plude(jl,jk) + end if + end do + end do + + return + end subroutine cudtdqn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & + ztmst,paph,puen,pven,pmfu,pmfd,puu,pud,pvu,pvd,ptenu, & + ptenv) + implicit none + integer klon,klev,ktopm2 + integer ktype(klon), kcbot(klon), kctop(klon) + logical ldcum(klon) + real(kind=kind_phys) ztmst + real(kind=kind_phys) paph(klon,klev+1) + real(kind=kind_phys) puen(klon,klev), pven(klon,klev),& + pmfu(klon,klev), pmfd(klon,klev),& + puu(klon,klev), pud(klon,klev),& + pvu(klon,klev), pvd(klon,klev) + real(kind=kind_phys) ptenu(klon,klev), ptenv(klon,klev) + +!local variables + real(kind=kind_phys) zuen(klon,klev) , zven(klon,klev) , zmfuu(klon,klev), & + zmfdu(klon,klev), zmfuv(klon,klev), zmfdv(klon,klev) + + integer ik , ikb , jk , jl + real(kind=kind_phys) zzp, zdtdt + + real(kind=kind_phys) zdudt(klon,klev), zdvdt(klon,klev), zdp(klon,klev) +! + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + zuen(jl,jk) = puen(jl,jk) + zven(jl,jk) = pven(jl,jk) + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + end if + end do + end do +!---------------------------------------------------------------------- +!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES +! ---------------------------------------------- + do jk = ktopm2 , klev + ik = jk - 1 + do jl = 1,klon + if ( ldcum(jl) ) then + zmfuu(jl,jk) = pmfu(jl,jk)*(puu(jl,jk)-zuen(jl,ik)) + zmfuv(jl,jk) = pmfu(jl,jk)*(pvu(jl,jk)-zven(jl,ik)) + zmfdu(jl,jk) = pmfd(jl,jk)*(pud(jl,jk)-zuen(jl,ik)) + zmfdv(jl,jk) = pmfd(jl,jk)*(pvd(jl,jk)-zven(jl,ik)) + end if + end do + end do + ! linear fluxes below cloud + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk > kcbot(jl) ) then + ikb = kcbot(jl) + zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) + if ( ktype(jl) == 3 ) zzp = zzp*zzp + zmfuu(jl,jk) = zmfuu(jl,ikb)*zzp + zmfuv(jl,jk) = zmfuv(jl,ikb)*zzp + zmfdu(jl,jk) = zmfdu(jl,ikb)*zzp + zmfdv(jl,jk) = zmfdv(jl,ikb)*zzp + end if + end do + end do +!---------------------------------------------------------------------- +!* 2.0 COMPUTE TENDENCIES +! ------------------ + do jk = ktopm2 , klev + if ( jk < klev ) then + ik = jk + 1 + do jl = 1,klon + if ( ldcum(jl) ) then + zdudt(jl,jk) = zdp(jl,jk) * & + (zmfuu(jl,ik)-zmfuu(jl,jk)+zmfdu(jl,ik)-zmfdu(jl,jk)) + zdvdt(jl,jk) = zdp(jl,jk) * & + (zmfuv(jl,ik)-zmfuv(jl,jk)+zmfdv(jl,ik)-zmfdv(jl,jk)) + end if + end do + else + do jl = 1,klon + if ( ldcum(jl) ) then + zdudt(jl,jk) = -zdp(jl,jk)*(zmfuu(jl,jk)+zmfdu(jl,jk)) + zdvdt(jl,jk) = -zdp(jl,jk)*(zmfuv(jl,jk)+zmfdv(jl,jk)) + end if + end do + end if + end do +!--------------------------------------------------------------------- +!* 3.0 UPDATE TENDENCIES +! ----------------- + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + ptenu(jl,jk) = ptenu(jl,jk) + zdudt(jl,jk) + ptenv(jl,jk) = ptenv(jl,jk) + zdvdt(jl,jk) + end if + end do + end do +!---------------------------------------------------------------------- + return + end subroutine cududvn + +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cuctracer(klon,klev,ktrac,kctop,kdtop, & + ldcum,lddraf,ztmst,paph,pmfu,pmfd, & + pudrate,pddrate,pcen,ptenc) + implicit none + integer klon,klev,ktrac + integer kctop(klon), kdtop(klon) + logical ldcum(klon), lddraf(klon) + real(kind=kind_phys) ztmst + real(kind=kind_phys) paph(klon,klev+1) + real(kind=kind_phys) pmfu(klon,klev) + real(kind=kind_phys) pmfd(klon,klev) + real(kind=kind_phys) pudrate(klon,klev) + real(kind=kind_phys) pddrate(klon,klev) + real(kind=kind_phys) pcen(klon,klev,ktrac) + real(kind=kind_phys) ptenc(klon,klev,ktrac) + !---------------------------------------------------------------------- + integer ik , jk , jl , jn + real(kind=kind_phys) zzp , zmfa , zerate , zposi + ! ALLOCATABLE ARAYS + real(kind=kind_phys) , dimension(:,:,:) , allocatable :: zcen , zcu , zcd , & + ztenc , zmfc + real(kind=kind_phys) , dimension(:,:) , allocatable :: zdp + logical , dimension(:,:) , allocatable :: llcumask , llcumbas + !---------------------------------------------------------------------- + allocate (zcen(klon,klev,ktrac)) ! Half-level environmental values + allocate (zcu(klon,klev,ktrac)) ! Updraft values + allocate (zcd(klon,klev,ktrac)) ! Downdraft values + allocate (ztenc(klon,klev,ktrac)) ! Tendency + allocate (zmfc(klon,klev,ktrac)) ! Fluxes + allocate (zdp(klon,klev)) ! Pressure difference + allocate (llcumask(klon,klev)) ! Mask for convection + ! Initialize Cumulus mask + some setups + do jk = 2, klev + do jl = 1, klon + llcumask(jl,jk) = .false. + if ( ldcum(jl) ) then + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + if ( jk >= kctop(jl)-1 ) llcumask(jl,jk) = .true. + end if + end do + end do + !---------------------------------------------------------------------- + do jn = 1 , ktrac + !* 1.0 DEFINE TRACERS AT HALF LEVELS + ! ----------------------------- + do jk = 2 , klev + ik = jk - 1 + do jl = 1, klon + zcen(jl,jk,jn) = pcen(jl,jk,jn) + zcd(jl,jk,jn) = pcen(jl,ik,jn) + zcu(jl,jk,jn) = pcen(jl,ik,jn) + zmfc(jl,jk,jn) = 0. + ztenc(jl,jk,jn)= 0. + end do + end do + + do jl = 1, klon + zcu(jl,klev,jn) = pcen(jl,klev,jn) + end do + !* 2.0 COMPUTE UPDRAFT VALUES + ! ---------------------- + do jk = klev - 1 , 3 , -1 + ik = jk + 1 + do jl = 1, klon + if ( llcumask(jl,jk) ) then + zerate = pmfu(jl,jk) - pmfu(jl,ik) + pudrate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + if ( jk >= kctop(jl) ) then + zcu(jl,jk,jn) = (pmfu(jl,ik)*zcu(jl,ik,jn) + & + zerate*pcen(jl,jk,jn)-pudrate(jl,jk)*zcu(jl,ik,jn))*zmfa + end if + end if + end do + end do + !* 3.0 COMPUTE DOWNDRAFT VALUES + ! ------------------------ + do jk = 3 , klev + ik = jk - 1 + do jl = 1, klon + if ( lddraf(jl) .and. jk == kdtop(jl) ) then + ! Nota: in order to avoid final negative Tracer values at LFS + ! the allowed value of ZCD depends on the jump in mass flux + ! at the LFS + zcd(jl,jk,jn) = 0.1*zcu(jl,jk,jn) + 0.9*pcen(jl,ik,jn) + else if ( lddraf(jl).and.jk>kdtop(jl) ) then + zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pddrate(jl,jk) + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zcd(jl,jk,jn) = (pmfd(jl,ik)*zcd(jl,ik,jn) - & + zerate*pcen(jl,ik,jn)+pddrate(jl,jk)*zcd(jl,ik,jn))*zmfa + end if + end do + end do + ! In order to avoid negative Tracer at KLEV adjust ZCD + jk = klev + ik = jk - 1 + do jl = 1, klon + if ( lddraf(jl) ) then + zposi = -zdp(jl,jk) *(pmfu(jl,jk)*zcu(jl,jk,jn) + & + pmfd(jl,jk)*zcd(jl,jk,jn)-(pmfu(jl,jk)+pmfd(jl,jk))*pcen(jl,ik,jn)) + if ( pcen(jl,jk,jn)+zposi*ztmst < 0. ) then + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zcd(jl,jk,jn) = ((pmfu(jl,jk)+pmfd(jl,jk))*pcen(jl,ik,jn) - & + pmfu(jl,jk)*zcu(jl,jk,jn)+pcen(jl,jk,jn) / & + (ztmst*zdp(jl,jk)))*zmfa + end if + end if + end do + end do + !---------------------------------------------------------------------- + do jn = 1 , ktrac + !* 4.0 COMPUTE FLUXES + ! -------------- + do jk = 2 , klev + ik = jk - 1 + do jl = 1, klon + if ( llcumask(jl,jk) ) then + zmfa = pmfu(jl,jk) + pmfd(jl,jk) + zmfc(jl,jk,jn) = pmfu(jl,jk)*zcu(jl,jk,jn) + & + pmfd(jl,jk)*zcd(jl,jk,jn) - zmfa*zcen(jl,ik,jn) + end if + end do + end do + !* 5.0 COMPUTE TENDENCIES = RHS + ! ------------------------ + do jk = 2 , klev - 1 + ik = jk + 1 + do jl = 1, klon + if ( llcumask(jl,jk) ) then + ztenc(jl,jk,jn) = zdp(jl,jk)*(zmfc(jl,ik,jn)-zmfc(jl,jk,jn)) + end if + end do + end do + jk = klev + do jl = 1, klon + if ( ldcum(jl) ) ztenc(jl,jk,jn) = -zdp(jl,jk)*zmfc(jl,jk,jn) + end do + end do + !* 6.0 UPDATE TENDENCIES + ! ----------------- + do jn = 1, ktrac + do jk = 2, klev + do jl = 1, klon + if ( llcumask(jl,jk) ) then + ptenc(jl,jk,jn) = ptenc(jl,jk,jn)+ztenc(jl,jk,jn) + end if + end do + end do + end do + !--------------------------------------------------------------------------- + deallocate (llcumask) + deallocate (zdp) + deallocate (zmfc) + deallocate (ztenc) + deallocate (zcd) + deallocate (zcu) + deallocate (zcen) + end subroutine cuctracer + +!--------------------------------------------------------- +! level 4 souroutines +!-------------------------------------------------------- + subroutine cuadjtqn & + & (klon, klev, kk, psp, pt, pq, ldflag, kcall) +! m.tiedtke e.c.m.w.f. 12/89 +! purpose. +! -------- +! to produce t,q and l values for cloud ascent + +! interface +! --------- +! this routine is called from subroutines: +! *cond* (t and q at condensation level) +! *cubase* (t and q at condensation level) +! *cuasc* (t and q at cloud levels) +! *cuini* (environmental t and qs values at half levels) +! input are unadjusted t and q values, +! it returns adjusted values of t and q + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kk* level +! *kcall* defines calculation as +! kcall=0 env. t and qs in*cuini* +! kcall=1 condensation in updrafts (e.g. cubase, cuasc) +! kcall=2 evaporation in downdrafts (e.g. cudlfs,cuddraf) +! input parameters (real(kind=kind_phys)): + +! *psp* pressure pa + +! updated parameters (real(kind=kind_phys)): + +! *pt* temperature k +! *pq* specific humidity kg/kg +! externals +! --------- +! for condensation calculations. +! the tables are initialised in *suphec*. + +!---------------------------------------------------------------------- + + implicit none + + integer klev,klon + real(kind=kind_phys) pt(klon,klev), pq(klon,klev), & + & psp(klon) + logical ldflag(klon) +! local variables + integer jl,jk + integer isum,kcall,kk + real(kind=kind_phys) zqmax,zqsat,zcor,zqp,zcond,zcond1,zl,zi,zf +!---------------------------------------------------------------------- +! 1. define constants +! ---------------- + zqmax=0.5 + +! 2. calculate condensation and adjust t and q accordingly +! ----------------------------------------------------- + + if ( kcall == 1 ) then + do jl = 1,klon + if ( ldflag(jl) ) then + zqp = 1./psp(jl) + zl = 1./(pt(jl,kk)-c4les) + zi = 1./(pt(jl,kk)-c4ies) + zqsat = c2es*(foealfa(pt(jl,kk))*exp(c3les*(pt(jl,kk)-tmelt)*zl) + & + (1.-foealfa(pt(jl,kk)))*exp(c3ies*(pt(jl,kk)-tmelt)*zi)) + zqsat = zqsat*zqp + zqsat = min(0.5,zqsat) + zcor = 1. - vtmpc1*zqsat + zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & + (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 + zcond = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) + if ( zcond > 0. ) then + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond + pq(jl,kk) = pq(jl,kk) - zcond + zl = 1./(pt(jl,kk)-c4les) + zi = 1./(pt(jl,kk)-c4ies) + zqsat = c2es*(foealfa(pt(jl,kk)) * & + exp(c3les*(pt(jl,kk)-tmelt)*zl)+(1.-foealfa(pt(jl,kk))) * & + exp(c3ies*(pt(jl,kk)-tmelt)*zi)) + zqsat = zqsat*zqp + zqsat = min(0.5,zqsat) + zcor = 1. - vtmpc1*zqsat + zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & + (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 + zcond1 = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) + if ( abs(zcond) < 1.e-20 ) zcond1 = 0. + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end if + end if + end do + elseif ( kcall == 2 ) then + do jl = 1,klon + if ( ldflag(jl) ) then + zqp = 1./psp(jl) + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + zcond = min(zcond,0.) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond + pq(jl,kk) = pq(jl,kk) - zcond + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + if ( abs(zcond) < 1.e-20 ) zcond1 = min(zcond1,0.) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end if + end do + else if ( kcall == 0 ) then + do jl = 1,klon + zqp = 1./psp(jl) + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end do + end if + + return + end subroutine cuadjtqn +!--------------------------------------------------------- +! level 4 souroutines +!-------------------------------------------------------- + subroutine cubasmcn & + & (klon, klev, klevm1, kk, pten,& + & pqen, pqsen, puen, pven, pverv,& + & pgeo, pgeoh, ldcum, ktype, klab, plrain,& + & pmfu, pmfub, kcbot, ptu,& + & pqu, plu, puu, pvu, pmfus,& + & pmfuq, pmful, pdmfup) + implicit none +! m.tiedtke e.c.m.w.f. 12/89 +! c.zhang iprc 05/2012 +!***purpose. +! -------- +! this routine calculates cloud base values +! for midlevel convection +!***interface +! --------- +! this routine is called from *cuasc*. +! input are environmental values t,q etc +! it returns cloudbase values for midlevel convection +!***method. +! ------- +! s. tiedtke (1989) +!***externals +! --------- +! none +! ---------------------------------------------------------------- + real(kind=kind_phys) pten(klon,klev), pqen(klon,klev),& + & puen(klon,klev), pven(klon,klev),& + & pqsen(klon,klev), pverv(klon,klev),& + & pgeo(klon,klev), pgeoh(klon,klev+1) + real(kind=kind_phys) ptu(klon,klev), pqu(klon,klev),& + & puu(klon,klev), pvu(klon,klev),& + & plu(klon,klev), pmfu(klon,klev),& + & pmfub(klon), & + & pmfus(klon,klev), pmfuq(klon,klev),& + & pmful(klon,klev), pdmfup(klon,klev),& + & plrain(klon,klev) + integer ktype(klon), kcbot(klon),& + & klab(klon,klev) + logical ldcum(klon) +! local variabels + integer jl,kk,klev,klon,klevp1,klevm1 + real(kind=kind_phys) zzzmb +!-------------------------------------------------------- +!* 1. calculate entrainment and detrainment rates +! ------------------------------------------------------- + do jl=1,klon + if(.not.ldcum(jl) .and. klab(jl,kk+1).eq.0) then + if(lmfmid .and. pqen(jl,kk) .gt. 0.80*pqsen(jl,kk).and. & + pgeo(jl,kk)*zrg .gt. 5.0e2 .and. & + & pgeo(jl,kk)*zrg .lt. 1.0e4 ) then + ptu(jl,kk+1)=(cpd*pten(jl,kk)+pgeo(jl,kk)-pgeoh(jl,kk+1))& + & *rcpd + pqu(jl,kk+1)=pqen(jl,kk) + plu(jl,kk+1)=0. + zzzmb=max(cmfcmin,-pverv(jl,kk)*zrg) + zzzmb=min(zzzmb,cmfcmax) + pmfub(jl)=zzzmb + pmfu(jl,kk+1)=pmfub(jl) + pmfus(jl,kk+1)=pmfub(jl)*(cpd*ptu(jl,kk+1)+pgeoh(jl,kk+1)) + pmfuq(jl,kk+1)=pmfub(jl)*pqu(jl,kk+1) + pmful(jl,kk+1)=0. + pdmfup(jl,kk+1)=0. + kcbot(jl)=kk + klab(jl,kk+1)=1 + plrain(jl,kk+1)=0.0 + ktype(jl)=3 + end if + end if + end do + return + end subroutine cubasmcn +! +!--------------------------------------------------------- +! level 4 souroutines +!--------------------------------------------------------- + subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, & + pgeoh,pmfu,pdmfen,pdmfde) + implicit none + integer klon,klev,kk + integer kcbot(klon) + logical ldcum(klon) + logical ldwork + real(kind=kind_phys) pgeoh(klon,klev+1) + real(kind=kind_phys) pmfu(klon,klev) + real(kind=kind_phys) pdmfen(klon) + real(kind=kind_phys) pdmfde(klon) + logical llo1 + integer jl + real(kind=kind_phys) zdz , zmf + real(kind=kind_phys) zentr(klon) + ! + !* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES + ! ------------------------------------------- + if ( ldwork ) then + do jl = 1,klon + pdmfen(jl) = 0. + pdmfde(jl) = 0. + zentr(jl) = 0. + end do + ! + !* 1.1 SPECIFY ENTRAINMENT RATES + ! ------------------------- + do jl = 1, klon + if ( ldcum(jl) ) then + zdz = (pgeoh(jl,kk)-pgeoh(jl,kk+1))*zrg + zmf = pmfu(jl,kk+1)*zdz + llo1 = kk < kcbot(jl) + if ( llo1 ) then + pdmfen(jl) = zentr(jl)*zmf + pdmfde(jl) = 0.75e-4*zmf + end if + end if + end do + end if + end subroutine cuentrn +! +!-------------------------------------------------------- +! external functions +!------------------------------------------------------ + real(kind=kind_phys) function foealfa(tt) +! foealfa is calculated to distinguish the three cases: +! +! foealfa=1 water phase +! foealfa=0 ice phase +! 0 < foealfa < 1 mixed phase +! +! input : tt = temperature +! + implicit none + real(kind=kind_phys) tt + foealfa = min(1.,((max(rtice,min(rtwat,tt))-rtice) & + & /(rtwat-rtice))**2) + + return + end function foealfa + + real(kind=kind_phys) function foelhm(tt) + implicit none + real(kind=kind_phys) tt + foelhm = foealfa(tt)*alv + (1.-foealfa(tt))*als + return + end function foelhm + + real(kind=kind_phys) function foeewm(tt) + implicit none + real(kind=kind_phys) tt + foeewm = c2es * & + & (foealfa(tt)*exp(c3les*(tt-tmelt)/(tt-c4les))+ & + & (1.-foealfa(tt))*exp(c3ies*(tt-tmelt)/(tt-c4ies))) + return + end function foeewm + + real(kind=kind_phys) function foedem(tt) + implicit none + real(kind=kind_phys) tt + foedem = foealfa(tt)*r5alvcp*(1./(tt-c4les)**2)+ & + & (1.-foealfa(tt))*r5alscp*(1./(tt-c4ies)**2) + return + end function foedem + + real(kind=kind_phys) function foeldcpm(tt) + implicit none + real(kind=kind_phys) tt + foeldcpm = foealfa(tt)*ralvdcp+ & + & (1.-foealfa(tt))*ralsdcp + return + end function foeldcpm + + real(kind=kind_phys) function foeldcp(tt) + implicit none + real(kind=kind_phys) tt + foeldcp = foedelta(tt)*ralvdcp + (1.-foedelta(tt))*ralsdcp + end function foeldcp + + real(kind=kind_phys) function foedelta(tt) + implicit none + real(kind=kind_phys) tt + foedelta = max(0.,sign(1.,tt-tmelt)) + end function foedelta + +end module cu_ntiedtke + diff --git a/physics/shinhongvdif.F90 b/physics/shinhongvdif.F90 new file mode 100644 index 000000000..c5011218b --- /dev/null +++ b/physics/shinhongvdif.F90 @@ -0,0 +1,2106 @@ +!> \file shinhongvdif.F90 +!! This file contains the CCPP-compliant Shinhong (saYSU) scheme which computes +!! subgrid vertical turbulence mixing using traditional K-profile method +!! Please refer to (Shin and Hong, 2013,2015). +!! +!! Subroutine 'shinhongvdif_run' computes subgrid vertical turbulence mixing +!! using scale-aware YSU K-profile method +!! +!---------------------------------------------------------------------- + + module shinhongvdif + contains + + subroutine shinhongvdif_init () + end subroutine shinhongvdif_init + + subroutine shinhongvdif_finalize () + end subroutine shinhongvdif_finalize + +!> \defgroup SHINHONG FV3GFS shinhongvdif_run Main +!! \brief This subroutine contains all of the logic for the +!! scale-aware Shinhong scheme. +!! +!> \section arg_table_shinhongvdif_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | ux | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | vx | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | tx | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!! | qx | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | +!! | p2d | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | p2di | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | pi2d | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | +!! | vtnp | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | utnp | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | ttnp | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | +!! | qtnp | tendency_of_tracers_due_to_model_physics | updated tendency of the tracers due to model physics | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | +!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | +!! | ndiff | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | +!! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | +!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | psfcpa | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | +!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | +!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | +!! | psim | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity function for momentum | none | 1 | real | kind_phys | in | F | +!! | psih | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity function for heat | none | 1 | real | kind_phys | in | F | +!! | landmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | heat | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | +!! | br | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | +!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | ep1 | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | ep2 | ratio_of_dry_air_to_water_vapor_gas_constants | rd/rv | none | 0 | real | kind_phys | in | F | +!! | xlv | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | +!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | kpbl1d | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | +!! | u10 | x_wind_at_10m | x component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | v10 | y_wind_at_10m | y component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!------------------------------------------------------------------------------- + subroutine shinhongvdif_run(ix,im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & + utnp,vtnp,ttnp,qtnp,ntrac,ndiff,ntcw,ntiw, & + phii,phil,psfcpa, & + zorl,stress,hpbl,psim,psih, & + landmask,heat,evap,wspd,br, & + g,rd,cp,rv,ep1,ep2,xlv, & + dusfc,dvsfc,dtsfc,dqsfc, & + dt,kpbl1d, & + u10,v10, & + dx,errmsg,errflg ) + + use machine , only : kind_phys +! +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! +! the shinhongpbl (shin and hong 2015) is based on the les study of shin +! and hong (2013). the major ingredients of the shinhongpbl are +! 1) the prescribed nonlocal heat transport profile fit to the les and +! 2) inclusion of explicit scale dependency functions for vertical +! transport in convective pbl. +! so, the shinhongpbl works at the gray zone resolution of convective pbl. +! note that honnert et al. (2011) first suggested explicit scale dependency +! function, and shin and hong (2013) further classified the function by +! stability (u*/w*) in convective pbl and calculated the function for +! nonlocal and local transport separately. +! vertical mixing in the stable boundary layer and free atmosphere follows +! hong (2010) and hong et al. (2006), same as the ysupbl scheme. +! +! shinhongpbl: +! coded and implemented by hyeyum hailey shin (ncar) +! summer 2014 +! +! ysupbl: +! coded by song-you hong (yonsei university) and implemented by +! song-you hong (yonsei university) and jimy dudhia (ncar) +! summer 2002 +! +! references: +! shin and hong (2015) mon. wea. rev. +! shin and hong (2013) j. atmos. sci. +! honnert, masson, and couvreux (2011) j. atmos. sci. +! hong (2010) quart. j. roy. met. soc +! hong, noh, and dudhia (2006), mon. wea. rev. +! +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: xkzminm = 0.1,xkzminh = 0.01 + real(kind=kind_phys),parameter :: xkzmax = 1000.,rimin = -100. + real(kind=kind_phys),parameter :: rlam = 30.,prmin = 0.25,prmax = 4. + real(kind=kind_phys),parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 + real(kind=kind_phys),parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 + real(kind=kind_phys),parameter :: phifac = 8.,sfcfrac = 0.1 + real(kind=kind_phys),parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 + real(kind=kind_phys),parameter :: h1 = 0.33333335, h2 = 0.6666667 + real(kind=kind_phys),parameter :: ckz = 0.001,zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. + real(kind=kind_phys),parameter :: tmin=1.e-2 + real(kind=kind_phys),parameter :: gamcrt = 3.,gamcrq = 2.e-3 + real(kind=kind_phys),parameter :: xka = 2.4e-5 + real(kind=kind_phys),parameter :: karman = 0.4 + real(kind=kind_phys),parameter :: corf=0.000073 + real(kind=kind_phys),parameter :: rcl = 1.0 + integer,parameter :: imvdif = 1 + integer,parameter :: shinhong_tke_diag = 0 +! +! tunable parameters for tke +! + real(kind=kind_phys),parameter :: epsq2l = 0.01,c_1 = 1.0,gamcre = 0.224 +! +! tunable parameters for prescribed nonlocal transport profile +! + real(kind=kind_phys),parameter :: mltop = 1.0,sfcfracn1 = 0.075 + real(kind=kind_phys),parameter :: nlfrac = 0.7,enlfrac = -0.4 + real(kind=kind_phys),parameter :: a11 = 1.0,a12 = -1.15 + real(kind=kind_phys),parameter :: ezfac = 1.5 + real(kind=kind_phys),parameter :: cpent = -0.4,rigsmax = 100. + real(kind=kind_phys),parameter :: entfmin = 1.0, entfmax = 5.0 +! 1D in + integer, intent(in ) :: ix,im,km,ntrac,ndiff,ntcw,ntiw + real(kind=kind_phys), intent(in ) :: g,cp,rd,rv,ep1,ep2,xlv,dt +! 3D in + real(kind=kind_phys), dimension(ix, km) , & + intent(in ) :: phil, & + pi2d, & + p2d, & + ux, & + vx, & + tx + real(kind=kind_phys), dimension( ix, km, ntrac ) , & + intent(in ) :: qx + + real(kind=kind_phys), dimension( ix, km+1 ) , & + intent(in ) :: p2di, & + phii +! 3D in&out + real(kind=kind_phys), dimension(im, km) , & + intent(inout) :: utnp, & + vtnp, & + ttnp + real(kind=kind_phys), dimension(im, km, ntrac ) , & + intent(inout) :: qtnp +! 2D in + integer, dimension(im) , & + intent(in ) :: landmask + + real(kind=kind_phys), dimension(im) , & + intent(in ) :: heat, & + evap, & + br, & + psim, & + psih, & + psfcpa, & + stress, & + zorl, & + wspd, & + u10, & + v10, & + dx +! 2D: out + integer, dimension(im) , & + intent(out ) :: kpbl1d + + real(kind=kind_phys), dimension(im) , & + intent(out ) :: hpbl, & + dusfc, & + dvsfc, & + dtsfc, & + dqsfc + +! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +! local vars +! + integer :: n,i,k,l,ic + integer :: klpbl + integer :: lmh,lmxl,kts,kte,its,ite +! + real(kind=kind_phys) :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 + real(kind=kind_phys) :: ss,ri,qmean,tmean,alpha,chi,zk,rl2,dk,sri + real(kind=kind_phys) :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz + real(kind=kind_phys) :: utend,vtend,ttend,qtend + real(kind=kind_phys) :: dtstep,govrthv + real(kind=kind_phys) :: cont, conq, conw, conwrc + real(kind=kind_phys) :: delxy,pu1,pth1,pq1 + real(kind=kind_phys) :: dex,hgame_c + real(kind=kind_phys) :: zfacdx + real(kind=kind_phys) :: amf1,amf2,bmf2,amf3,bmf3,amf4,bmf4,sflux0,snlflux0 + real(kind=kind_phys) :: mlfrac,ezfrac,sfcfracn + real(kind=kind_phys) :: uwst,uwstx,csfac + real(kind=kind_phys) :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & + dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & + prfac,prfac2,phim8z +! + integer, dimension(im) :: kpbl + real(kind=kind_phys), dimension(im) :: hol + real(kind=kind_phys), dimension(im) :: deltaoh + real(kind=kind_phys), dimension(im) :: rigs, & + enlfrac2, & + cslen + real(kind=kind_phys), dimension(im) :: & + rhox, & + govrth, & + zl1,thermal, & + wscale, & + hgamt,hgamq, & + brdn,brup, & + phim,phih, & + prpbl, & + wspd1, & + ust,hfx,qfx,znt, & + xland + real(kind=kind_phys), dimension(im) :: & + ust3, & + wstar3, & + wstar,delta, & + hgamu,hgamv, & + wm2, we, & + bfxpbl, & + hfxpbl,qfxpbl, & + ufxpbl,vfxpbl, & + dthvx + real(kind=kind_phys), dimension(im) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro + real(kind=kind_phys), dimension(im) :: & + efxpbl, & + hpbl_cbl, & + epshol, & + ct +! + real(kind=kind_phys), dimension(im,km) :: & + xkzm,xkzh, & + f1,f2, & + r1,r2, & + ad,au, & + cu, & + al, & + xkzq, & + zfac + real(kind=kind_phys), dimension(im,km) :: & + thx,thvx, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za + real(kind=kind_phys), dimension(im,km) :: & + wscalek + real(kind=kind_phys), dimension(im,km) :: & + xkzml,xkzhl, & + zfacent,entfac + real(kind=kind_phys), dimension(im,km) :: & + mf, & + zfacmf, & + entfacmf + real(kind=kind_phys), dimension(im,km) :: & + q2x, & + hgame2d, & + tflux_e, & + qflux_e, & + tvflux_e + real(kind=kind_phys), dimension( im, km+1 ) :: zq + real(kind=kind_phys), dimension( im, km, ndiff ) :: r3,f3 +! + real(kind=kind_phys), dimension( km ) :: & + uxk,vxk, & + txk,thxk,thvxk, & + q2xk, & + hgame + real(kind=kind_phys), dimension( km ) :: & + ps1d,pb1d,eps1d,pt1d, & + xkze1d,eflx_l1d,eflx_nl1d, & + ptke1 + real(kind=kind_phys), dimension( 2:km ) :: & + s2,gh,rig,el, & + akmk,akhk, & + mfk,ufxpblk,vfxpblk,qfxpblk + real(kind=kind_phys), dimension( km+1 ) :: zqk + + real(kind=kind_phys), dimension(im,km) :: dz8w2d +! + logical, dimension(im) :: pblflg, & + sfcflg, & + stable + logical, dimension( ndiff ) :: ifvmix +! +!------------------------------------------------------------------------------- +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + its = 1 + ite = im + kts = 1 + kte = km + + klpbl = kte + lmh = 1 + lmxl = 1 +! + cont=cp/g + conq=xlv/g + conw=1./g + conwrc = conw*sqrt(rcl) + conpr = bfac*karman*sfcfrac +! change xland values + do i=its,ite + if(landmask(i).eq.0) then !ocean + xland(i) = 2 + else + xland(i) = 1 !land + end if + end do +! +! k-start index for cloud and rain +! + ifvmix(:) = .true. +! + do k = kts,kte + do i = its,ite + thx(i,k) = tx(i,k)/pi2d(i,k) + enddo + enddo +! + do k = kts,kte + do i = its,ite + tvcon = (1.+ep1*qx(i,k,1)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo +! + do i = its,ite + tvcon = (1.+ep1*qx(i,1,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) + hfx(i) = heat(i)*rhox(i)*cp ! reset to the variable in WRF + qfx(i) = evap(i)*rhox(i) ! reset to the variable in WRF + ust(i) = sqrt(stress(i)) ! reset to the variable in WRF + znt(i) = 0.01*zorl(i) ! reset to the variable in WRF + enddo +! +!-----compute the height of full- and half-sigma levels above ground +! level, and the layer thicknesses. +! + do i = its,ite + zq(i,1) = 0. + enddo +! + do k = kts,kte + do i = its,ite + zq(i,k+1) = phii(i,k+1)*conw + za(i,k) = phil(i,k)*conw + enddo + enddo +! + do k = kts,kte + do i = its,ite + dzq(i,k) = zq(i,k+1)-zq(i,k) + del(i,k) = p2di(i,k)-p2di(i,k+1) + dz8w2d(i,k)=dzq(i,k) + enddo + enddo +! + do i = its,ite + dza(i,1) = za(i,1) + enddo +! + do k = kts+1,kte + do i = its,ite + dza(i,k) = za(i,k)-za(i,k-1) + enddo + enddo +! + do i = its,ite + wspd1(i) = sqrt(ux(i,1)*ux(i,1)+vx(i,1)*vx(i,1))+1.e-9 + enddo + +! write(0,*)"===CALLING shinhong; input:" +! print*,"t:",tx(1,1),tx(1,2),tx(1,km) +! print*,"u:",ux(1,1),ux(1,2),ux(1,km) +! print*,"v:",vx(1,1),vx(1,2),vx(1,km) +! print*,"q:",qx(1,1,1),qx(1,2,1),qx(1,km,1) +! print*,"exner:",pi2d(1,1),pi2d(1,2),pi2d(1,km) +! print*,"dz8w2d:",dz8w2d(1,1),dz8w2d(1,2),dz8w2d(1,km) +! print *,"del:",del(1,1),del(1,2),del(1,km) +! print*,"phii:",zq(1,1),zq(1,2),zq(1,km+1) +! print*,"phil:",za(1,1),za(1,2),za(1,km) +! print*,"p2d:",p2d(1,1),p2d(1,2),p2d(1,km) +! print*,"p2di:",p2di(1,1),p2di(1,2),p2di(1,km+1) +! print*,"znt,ust,wspd:",znt(1),ust(1),wspd(1) +! print*,"hfx,qfx,xland:",hfx(1),qfx(1),xland(1) +! print*,"rd,rv,g:",rd,rv,g +! print*,"ep1,ep2,xlv:",ep1,ep2,xlv +! print*,"br,psim,psih:",br(1),psim(1),psih(1) +! print*,"dx,u10,v10:",dx(1),u10(1),v10(1) +! print*,"psfcpa,cp:",psfcpa(1),cp +! print*,"ntrac,ndiff,ntcw,ntiw:",ntrac,ndiff,ntcw,ntiw +! +!---- compute vertical diffusion +! +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! compute preliminary variables +! + dtstep = dt + dt2 = 2.*dtstep + rdt = 1./dt2 +! + do i = its,ite + bfxpbl(i) = 0.0 + hfxpbl(i) = 0.0 + qfxpbl(i) = 0.0 + ufxpbl(i) = 0.0 + vfxpbl(i) = 0.0 + hgamu(i) = 0.0 + hgamv(i) = 0.0 + delta(i) = 0.0 + enddo +! + do i = its,ite + efxpbl(i) = 0.0 + hpbl_cbl(i) = 0.0 + epshol(i) = 0.0 + ct(i) = 0.0 + enddo +! + do i = its,ite + deltaoh(i) = 0.0 + rigs(i) = 0.0 + enlfrac2(i) = 0.0 + cslen(i) = 0.0 + enddo +! + do k = kts,klpbl + do i = its,ite + wscalek(i,k) = 0.0 + enddo + enddo +! + do k = kts,klpbl + do i = its,ite + zfac(i,k) = 0.0 + enddo + enddo +! + do k = kts,kte + do i = its,ite + q2x(i,k) = 1.e-4 + enddo + enddo +! + do k = kts,kte + do i = its,ite + hgame2d(i,k) = 0.0 + tflux_e(i,k) = 0.0 + qflux_e(i,k) = 0.0 + tvflux_e(i,k) = 0.0 + enddo + enddo +! + do k = kts,kte + do i = its,ite + mf(i,k) = 0.0 + zfacmf(i,k) = 0.0 + enddo + enddo +! + do k = kts,klpbl-1 + do i = its,ite + xkzom(i,k) = xkzminm + xkzoh(i,k) = xkzminh + enddo + enddo +! + do i = its,ite + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + enddo +! + do i = its,ite + hgamt(i) = 0. + hgamq(i) = 0. + wscale(i) = 0. + kpbl(i) = 1 + hpbl(i) = zq(i,1) + hpbl_cbl(i) = zq(i,1) + zl1(i) = za(i,1) + thermal(i)= thvx(i,1) + pblflg(i) = .true. + sfcflg(i) = .true. + sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) + if(br(i).gt.0.0) sfcflg(i) = .false. + enddo +! +! compute the first guess of pbl height +! + do i = its,ite + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + enddo +! + do i = its,ite + fm = psim(i) + fh = psih(i) + zol1(i) = max(br(i)*fm*fm/fh,rimin) + if(sfcflg(i))then + zol1(i) = min(zol1(i),-zfmin) + else + zol1(i) = max(zol1(i),zfmin) + endif + hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac + epshol(i) = hol1 + if(sfcflg(i))then + phim(i) = (1.-aphi16*hol1)**(-1./4.) + phih(i) = (1.-aphi16*hol1)**(-1./2.) + bfx0 = max(sflux(i),0.) + hfx0 = max(hfx(i)/rhox(i)/cp,0.) + qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) + wstar3(i) = (govrth(i)*bfx0*hpbl(i)) + wstar(i) = (wstar3(i))**h1 + else + phim(i) = (1.+aphi5*hol1) + phih(i) = phim(i) + wstar(i) = 0. + wstar3(i) = 0. + endif + ust3(i) = ust(i)**3. + wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + enddo +! +! compute the surface variables for pbl height estimation +! under unstable conditions +! + do i = its,ite + if(sfcflg(i).and.sflux(i).gt.0.0)then + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac + thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + else + pblflg(i) = .false. + endif + enddo +! +! enhance the pbl height by considering the thermal +! + do i = its,ite + if(pblflg(i))then + kpbl(i) = 1 + hpbl(i) = zq(i,1) + endif + enddo +! + do i = its,ite + if(pblflg(i))then + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i).and.pblflg(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + if(pblflg(i)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + uwst = abs(ust(i)/wstar(i)-0.5) + uwstx = -80.*uwst+14. + csfac = 0.5*(tanh(uwstx)+3.) + cslen(i) = csfac*hpbl(i) + endif + enddo +! +! stable boundary layer +! + do i = its,ite + hpbl_cbl(i) = hpbl(i) + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + brup(i) = br(i) + stable(i) = .false. + else + stable(i) = .true. + endif + enddo +! + do i = its,ite + if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then + wspd10 = u10(i)*u10(i) + v10(i)*v10(i) + wspd10 = sqrt(wspd10) + ross = wspd10 / (cori*znt(i)) + brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3) + endif + enddo +! + do i = its,ite + if(.not.stable(i))then + if((xland(i)-1.5).ge.0)then + brcr(i) = brcr_sbro(i) + else + brcr(i) = brcr_sb + endif + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! scale dependency for nonlocal momentum and moisture transport +! + do i = its,ite + pu1=pu(dx(i),cslen(i)) + pq1=pq(dx(i),cslen(i)) + if(pblflg(i)) then + hgamu(i) = hgamu(i)*pu1 + hgamv(i) = hgamv(i)*pu1 + hgamq(i) = hgamq(i)*pq1 + endif + enddo +! +! estimate the entrainment parameters +! + do i = its,ite + if(pblflg(i)) then + k = kpbl(i) - 1 + prpbl(i) = 1.0 + wm3 = wstar3(i) + 5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + dthx = max(thx(i,k+1)-thx(i,k),tmin) + dqx = min(qx(i,k+1,1)-qx(i,k,1),0.0) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + hfxpbl(i) = we(i)*dthx + pq1=pq(dx(i),cslen(i)) + qfxpbl(i) = we(i)*dqx*pq1 +! + pu1=pu(dx(i),cslen(i)) + dux = ux(i,k+1)-ux(i,k) + dvx = vx(i,k+1)-vx(i,k) + if(dux.gt.tmin) then + ufxpbl(i) = max(prpbl(i)*we(i)*dux*pu1,-ust(i)*ust(i)) + elseif(dux.lt.-tmin) then + ufxpbl(i) = min(prpbl(i)*we(i)*dux*pu1,ust(i)*ust(i)) + else + ufxpbl(i) = 0.0 + endif + if(dvx.gt.tmin) then + vfxpbl(i) = max(prpbl(i)*we(i)*dvx*pu1,-ust(i)*ust(i)) + elseif(dvx.lt.-tmin) then + vfxpbl(i) = min(prpbl(i)*we(i)*dvx*pu1,ust(i)*ust(i)) + else + vfxpbl(i) = 0.0 + endif + delb = govrth(i)*d3*hpbl(i) + delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) + delb = govrth(i)*dthvx(i) + deltaoh(i) = d1*hpbl(i) + d2*wm2(i)/delb + deltaoh(i) = max(ezfac*deltaoh(i),hpbl(i)-za(i,kpbl(i)-1)-1.) + deltaoh(i) = min(deltaoh(i) ,hpbl(i)) + rigs(i) = govrth(i)*dthvx(i)*deltaoh(i)/(dux**2.+dvx**2.) + rigs(i) = max(min(rigs(i), rigsmax),rimin) + enlfrac2(i) = max(min(wm3/wstar3(i)/(1.+cpent/rigs(i)),entfmax), entfmin) + enlfrac2(i) = enlfrac2(i)*enlfrac + endif + enddo +! + do k = kts,klpbl + do i = its,ite + if(pblflg(i))then + entfacmf(i,k) = sqrt(((zq(i,k+1)-hpbl(i))/deltaoh(i))**2.) + endif + if(pblflg(i).and.k.ge.kpbl(i))then + entfac(i,k) = ((zq(i,k+1)-hpbl(i))/deltaoh(i))**2. + else + entfac(i,k) = 1.e30 + endif + enddo + enddo +! +! compute diffusion coefficients below pbl +! + do k = kts,klpbl + do i = its,ite + if(k.lt.kpbl(i)) then + zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) + zfacent(i,k) = (1.-zfac(i,k))**3. + wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 + if(sfcflg(i)) then + prfac = conpr + prfac2 = 15.9*wstar3(i)/ust3(i)/(1.+4.*karman*wstar3(i)/ust3(i)) + prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. + else + prfac = 0. + prfac2 = 0. + prnumfac = 0. + phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i) + wscalek(i,k) = ust(i)/phim8z + wscalek(i,k) = max(wscalek(i,k),0.001) + endif + prnum0 = (phih(i)/phim(i)+prfac) + prnum0 = max(min(prnum0,prmax),prmin) + xkzm(i,k) = wscalek(i,k)*karman*zq(i,k+1)*zfac(i,k)**pfac + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) + prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzh(i,k) = xkzm(i,k)/prnum + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + endif + enddo + enddo +! +! compute diffusion coefficients over pbl (free atmosphere) +! + do k = kts,kte-1 + do i = its,ite + if(k.ge.kpbl(i)) then + ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) & + +(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) & + /(dza(i,k+1)*dza(i,k+1))+1.e-9 + govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) + ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) +! in cloud + if(imvdif.eq.1.and.ntcw.ge.2.and.ntiw.ge.2)then + if((qx(i,k,ntcw)+qx(i,k,ntiw)).gt.0.01e-3 & + .and.(qx(i,k+1,ntcw)+qx(i,k+1,ntiw)).gt.0.01e-3) then + qmean = 0.5*(qx(i,k,1)+qx(i,k+1,1)) + tmean = 0.5*(tx(i,k)+tx(i,k+1)) + alpha = xlv*qmean/rd/tmean + chi = xlv*xlv*qmean/cp/rv/tmean/tmean + ri = (1.+alpha)*(ri-g*g/ss/tmean/cp*((chi-alpha)/(1.+chi))) + endif + endif + zk = karman*zq(i,k+1) + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) + rlamdz = min(dza(i,k+1),rlamdz) + rl2 = (zk*rlamdz/(rlamdz+zk))**2 + dk = rl2*sqrt(ss) + if(ri.lt.0.)then +! unstable regime + ri = max(ri, rimin) + sri = sqrt(-ri) + xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) + xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) + else +! stable regime + xkzh(i,k) = dk/(1+5.*ri)**2 + prnum = 1.0+2.1*ri + prnum = min(prnum,prmax) + xkzm(i,k) = xkzh(i,k)*prnum + endif +! + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzml(i,k) = xkzm(i,k) + xkzhl(i,k) = xkzh(i,k) + endif + enddo + enddo +! +! prescribe nonlocal heat transport below pbl +! + do i = its,ite + deltaoh(i) = deltaoh(i)/hpbl(i) + enddo +! + do i = its,ite + mlfrac = mltop-deltaoh(i) + ezfrac = mltop+deltaoh(i) + zfacmf(i,1) = min(max((zq(i,2)/hpbl(i)),zfmin),1.) + sfcfracn = max(sfcfracn1,zfacmf(i,1)) +! + sflux0 = (a11+a12*sfcfracn)*sflux(i) + snlflux0 = nlfrac*sflux0 + amf1 = snlflux0/sfcfracn + amf2 = -snlflux0/(mlfrac-sfcfracn) + bmf2 = -mlfrac*amf2 + amf3 = snlflux0*enlfrac2(i)/deltaoh(i) + bmf3 = -amf3*mlfrac + hfxpbl(i) = amf3+bmf3 + pth1=pthnl(dx(i),cslen(i)) + hfxpbl(i) = hfxpbl(i)*pth1 +! + do k = kts,klpbl + zfacmf(i,k) = max((zq(i,k+1)/hpbl(i)),zfmin) + if(pblflg(i).and.k.lt.kpbl(i)) then + if(zfacmf(i,k).le.sfcfracn) then + mf(i,k) = amf1*zfacmf(i,k) + else if (zfacmf(i,k).le.mlfrac) then + mf(i,k) = amf2*zfacmf(i,k)+bmf2 + endif + mf(i,k) = mf(i,k)+hfxpbl(i)*exp(-entfacmf(i,k)) + mf(i,k) = mf(i,k)*pth1 + endif + enddo + enddo +! +! compute tridiagonal matrix elements for heat +! + do k = kts,kte + do i = its,ite + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + enddo + enddo +! + do i = its,ite + ad(i,1) = 1. + f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzh(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzt = tem1*(-mf(i,k)/xkzh(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + f1(i,k+1) = thx(i,k+1)-300. + else + f1(i,k+1) = thx(i,k+1)-300. + endif + tem1 = dsig*xkzh(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! +! scale dependency for local heat transport +! + zfacdx=0.2*hpbl(i)/zq(i,k+1) + delxy=dx(i)*max(zfacdx,1.0) + pth1=pthl(delxy,hpbl(i)) + if(pblflg(i).and.k.lt.kpbl(i)) then + au(i,k) = au(i,k)*pth1 + al(i,k) = al(i,k)*pth1 + endif + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo +! + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) +! +! recover tendencies of heat +! + do k = kte,kts,-1 + do i = its,ite + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + ttnp(i,k) = ttnp(i,k)+ttend + dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k) + if(k.eq.kte) then + tflux_e(i,k) = ttend*dz8w2d(i,k) + else + tflux_e(i,k) = tflux_e(i,k+1) + ttend*dz8w2d(i,k) + endif + enddo + enddo +! +! compute tridiagonal matrix elements for moisture, clouds, and gases +! + do k = kts,kte + do i = its,ite + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + enddo + enddo +! + do ic = 1,ndiff + do i = its,ite + do k = kts,kte + f3(i,k,ic) = 0. + enddo + enddo + enddo +! + do i = its,ite + ad(i,1) = 1. + f3(i,1,1) = qx(i,1,1)+qfx(i)*g/del(i,1)*dt2 + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do i = its,ite + f3(i,1,ic) = qx(i,1,ic) + enddo + enddo + endif +! + do k = kts,kte-1 + do i = its,ite + if(k.ge.kpbl(i)) then + xkzq(i,k) = xkzh(i,k) + endif + enddo + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzq(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k)) + f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq + f3(i,k+1,1) = qx(i,k+1,1)-dtodsu*dsdzq + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) + xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + f3(i,k+1,1) = qx(i,k+1,1) + else + f3(i,k+1,1) = qx(i,k+1,1) + endif + tem1 = dsig*xkzq(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! +! scale dependency for local moisture transport +! + zfacdx=0.2*hpbl(i)/zq(i,k+1) + delxy=dx(i)*max(zfacdx,1.0) + pq1=pq(delxy,hpbl(i)) + if(pblflg(i).and.k.lt.kpbl(i)) then + au(i,k) = au(i,k)*pq1 + al(i,k) = al(i,k)*pq1 + endif + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do k = kts,kte-1 + do i = its,ite + f3(i,k+1,ic) = qx(i,k+1,ic) + enddo + enddo + enddo + endif +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + enddo + enddo +! + do ic = 1,ndiff + do k = kts,kte + do i = its,ite + r3(i,k,ic) = f3(i,k,ic) + enddo + enddo + enddo +! +! solve tridiagonal problem for moisture, clouds, and gases +! + call tridin_ysu(al,ad,cu,r3,au,f3,its,ite,kts,kte,ndiff) +! +! recover tendencies of heat and moisture +! + do k = kte,kts,-1 + do i = its,ite + qtend = (f3(i,k,1)-qx(i,k,1))*rdt + qtnp(i,k,1) = qtnp(i,k,1)+qtend + dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + if(k.eq.kte) then + qflux_e(i,k) = qtend*dz8w2d(i,k) + else + qflux_e(i,k) = qflux_e(i,k+1) + qtend*dz8w2d(i,k) + endif + tvflux_e(i,k) = tflux_e(i,k) + qflux_e(i,k)*ep1*thx(i,k) + enddo + enddo +! print*,"qtnp:",maxval(qtnp(:,:,1)),minval(qtnp(:,:,1)) +! + do k = kts,kte + do i = its,ite + if(pblflg(i).and.k.lt.kpbl(i)) then + hgame_c=c_1*0.2*2.5*(g/thvx(i,k))*wstar(i)/(0.25*(q2x(i,k+1)+q2x(i,k))) + hgame_c=min(hgame_c,gamcre) + if(k.eq.kte)then + hgame2d(i,k)=hgame_c*0.5*tvflux_e(i,k)*hpbl(i) + hgame2d(i,k)=max(hgame2d(i,k),0.0) + else + hgame2d(i,k)=hgame_c*0.5*(tvflux_e(i,k)+tvflux_e(i,k+1))*hpbl(i) + hgame2d(i,k)=max(hgame2d(i,k),0.0) + endif + endif + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + if(ifvmix(ic)) then + do k = kte,kts,-1 + do i = its,ite + qtend = (f3(i,k,ic)-qx(i,k,ic))*rdt + qtnp(i,k,ic) = qtnp(i,k,ic)+qtend + enddo + enddo + endif + enddo + endif +! +! compute tridiagonal matrix elements for momentum +! + do i = its,ite + do k = kts,kte + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + f2(i,k) = 0. + enddo + enddo +! + do i = its,ite + ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 + f1(i,1) = ux(i,1) + f2(i,1) = vx(i,1) + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzm(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i))then + dsdzu = tem1*(-hgamu(i)/hpbl(i)-ufxpbl(i)*zfacent(i,k)/xkzm(i,k)) + dsdzv = tem1*(-hgamv(i)/hpbl(i)-vfxpbl(i)*zfacent(i,k)/xkzm(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzu + f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu + f2(i,k) = f2(i,k)+dtodsd*dsdzv + f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzm(i,k) = prpbl(i)*xkzh(i,k) + xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + else + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + endif + tem1 = dsig*xkzm(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! +! scale dependency for local momentum transport +! + zfacdx=0.2*hpbl(i)/zq(i,k+1) + delxy=dx(i)*max(zfacdx,1.0) + pu1=pu(delxy,hpbl(i)) + if(pblflg(i).and.k.lt.kpbl(i)) then + au(i,k) = au(i,k)*pu1 + al(i,k) = al(i,k)*pu1 + endif + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + r2(i,k) = f2(i,k) + enddo + enddo +! +! solve tridiagonal problem for momentum +! + call tridi1n(al,ad,cu,r1,r2,au,f1,f2,its,ite,kts,kte,1) +! +! recover tendencies of momentum +! + do k = kte,kts,-1 + do i = its,ite + utend = (f1(i,k)-ux(i,k))*rdt + vtend = (f2(i,k)-vx(i,k))*rdt + utnp(i,k) = utnp(i,k)+utend + vtnp(i,k) = vtnp(i,k)+vtend + dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) + dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) + enddo + enddo +! + do i = its,ite + kpbl1d(i) = kpbl(i) + enddo +! +!---- calculate sgs tke which is consistent with shinhongpbl algorithm +! + if (shinhong_tke_diag.eq.1) then +! + tke_calculation: do i = its,ite + do k = kts+1,kte + s2(k) = 0.0 + gh(k) = 0.0 + rig(k) = 0.0 + el(k) = 0.0 + akmk(k) = 0.0 + akhk(k) = 0.0 + mfk(k) = 0.0 + ufxpblk(k) = 0.0 + vfxpblk(k) = 0.0 + qfxpblk(k) = 0.0 + enddo +! + do k = kts,kte + uxk(k) = 0.0 + vxk(k) = 0.0 + txk(k) = 0.0 + thxk(k) = 0.0 + thvxk(k) = 0.0 + q2xk(k) = 0.0 + hgame(k) = 0.0 + ps1d(k) = 0.0 + pb1d(k) = 0.0 + eps1d(k) = 0.0 + pt1d(k) = 0.0 + xkze1d(k) = 0.0 + eflx_l1d(k) = 0.0 + eflx_nl1d(k) = 0.0 + ptke1(k) = 1.0 + enddo +! + do k = kts,kte+1 + zqk(k) = 0.0 + enddo +! + do k = kts,kte + uxk(k) = ux(i,k) + vxk(k) = vx(i,k) + txk(k) = tx(i,k) + thxk(k) = thx(i,k) + thvxk(k) = thvx(i,k) + q2xk(k) = q2x(i,k) + hgame(k) = hgame2d(i,k) + enddo +! + do k = kts,kte-1 + if(pblflg(i).and.k.le.kpbl(i)) then + zfacdx = 0.2*hpbl(i)/za(i,k) + delxy = dx(i)*max(zfacdx,1.0) + ptke1(k+1) = ptke(delxy,hpbl(i)) + endif + enddo +! + do k = kts,kte+1 + zqk(k) = zq(i,k) + enddo +! + do k = kts+1,kte + akmk(k) = xkzm(i,k-1) + akhk(k) = xkzh(i,k-1) + mfk(k) = mf(i,k-1)/xkzh(i,k-1) + ufxpblk(k) = ufxpbl(i)*zfacent(i,k-1)/xkzm(i,k-1) + vfxpblk(k) = vfxpbl(i)*zfacent(i,k-1)/xkzm(i,k-1) + qfxpblk(k) = qfxpbl(i)*zfacent(i,k-1)/xkzq(i,k-1) + enddo +! + if(pblflg(i)) then + k = kpbl(i) - 1 + dex = 0.25*(q2xk(k+2)-q2xk(k)) + efxpbl(i) = we(i)*dex + endif +! +!---- find the mixing length +! + call mixlen(lmh,uxk,vxk,txk,thxk,qx(i,kts,1),qx(i,kts,ntcw) & + ,q2xk,zqk,ust(i),corf,epshol(i) & + ,s2,gh,rig,el & + ,hpbl(i),kpbl(i),lmxl,ct(i) & + ,hgamu(i),hgamv(i),hgamq(i),pblflg(i) & + ,mfk,ufxpblk,vfxpblk,qfxpblk & + ,ep1,karman,cp & + ,kts,kte ) +! +!---- solve for the production/dissipation of the turbulent kinetic energy +! + call prodq2(lmh,dt,ust(i),s2,rig,q2xk,el,zqk,akmk,akhk & + ,uxk,vxk,thxk,thvxk & + ,hgamu(i),hgamv(i),hgamq(i),dx(i) & + ,hpbl(i),pblflg(i),kpbl(i) & + ,mfk,ufxpblk,vfxpblk,qfxpblk & + ,ep1 & + ,kts,kte ) +! +! +!---- carry out the vertical diffusion of turbulent kinetic energy +! + call vdifq(lmh,dt,q2xk,el,zqk & + ,akhk,ptke1 & + ,hgame,hpbl(i),pblflg(i),kpbl(i) & + ,efxpbl(i) & + ,kts,kte ) +! +!---- save the new tke and mixing length. +! + do k = kts,kte + q2x(i,k) = amax1(q2xk(k),epsq2l) + enddo +! + enddo tke_calculation + endif +! +!---- end of tke calculation +! +! +!---- end of vertical diffusion +! + end subroutine shinhongvdif_run +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: cm, & + r1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu, & + f1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do i = its,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f1(i,1) = fk*r1(i,1) + enddo +! + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) + enddo + enddo +! + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) + enddo +! + do it = 1,nt + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do k = n-1,kts,-1 + do i = its,l + f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) + enddo + enddo +! + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridi1n +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: cm + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do it = 1,nt + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin_ysu +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine mixlen(lmh,u,v,t,the,q,cwm,q2,z,ustar,corf,epshol, & + s2,gh,ri,el,hpbl,lpbl,lmxl,ct, & + hgamu,hgamv,hgamq,pblflg, & + mf,ufxpbl,vfxpbl,qfxpbl, & + p608,vkarman,cp, & + kts,kte) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! qnse model constants +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: blckdr=0.0063,cn=0.75 + real(kind=kind_phys),parameter :: eps1=1.e-12,epsl=0.32,epsru=1.e-7,epsrs=1.e-7 + real(kind=kind_phys),parameter :: el0max=1000.,el0min=1.,elfc=0.23*0.5 + real(kind=kind_phys),parameter :: alph=0.30,beta=1./273.,g=9.81,btg=beta*g + real(kind=kind_phys),parameter :: a1=0.659888514560862645,a2x=0.6574209922667784586 + real(kind=kind_phys),parameter :: b1=11.87799326209552761,b2=7.226971804046074028 + real(kind=kind_phys),parameter :: c1=0.000830955950095854396 + real(kind=kind_phys),parameter :: adnh= 9.*a1*a2x*a2x*(12.*a1+3.*b2)*btg*btg + real(kind=kind_phys),parameter :: adnm=18.*a1*a1*a2x*(b2-3.*a2x)*btg + real(kind=kind_phys),parameter :: bdnh= 3.*a2x*(7.*a1+b2)*btg,bdnm= 6.*a1*a1 +!------------------------------------------------------------------------------- +! free term in the equilibrium equation for (l/q)**2 +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: aeqh=9.*a1*a2x*a2x*b1*btg*btg & + +9.*a1*a2x*a2x*(12.*a1+3.*b2)*btg*btg + real(kind=kind_phys),parameter :: aeqm=3.*a1*a2x*b1*(3.*a2x+3.*b2*c1+18.*a1*c1-b2) & + *btg+18.*a1*a1*a2x*(b2-3.*a2x)*btg +!------------------------------------------------------------------------------- +! forbidden turbulence area +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: requ=-aeqh/aeqm + real(kind=kind_phys),parameter :: epsgh=1.e-9,epsgm=requ*epsgh +!------------------------------------------------------------------------------- +! near isotropy for shear turbulence, ww/q2 lower limit +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: ubryl=(18.*requ*a1*a1*a2x*b2*c1*btg & + +9.*a1*a2x*a2x*b2*btg*btg) & + /(requ*adnm+adnh) + real(kind=kind_phys),parameter :: ubry=(1.+epsrs)*ubryl,ubry3=3.*ubry + real(kind=kind_phys),parameter :: aubh=27.*a1*a2x*a2x*b2*btg*btg-adnh*ubry3 + real(kind=kind_phys),parameter :: aubm=54.*a1*a1*a2x*b2*c1*btg -adnm*ubry3 + real(kind=kind_phys),parameter :: bubh=(9.*a1*a2x+3.*a2x*b2)*btg-bdnh*ubry3 + real(kind=kind_phys),parameter :: bubm=18.*a1*a1*c1 -bdnm*ubry3 + real(kind=kind_phys),parameter :: cubr=1.-ubry3,rcubr=1./cubr +!------------------------------------------------------------------------------- +! k profile constants +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: elcbl=0.77 +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: kts,kte + integer, intent(in ) :: lmh,lmxl,lpbl +! + real(kind=kind_phys), intent(in ) :: p608,vkarman,cp + real(kind=kind_phys), intent(in ) :: hpbl,corf,ustar,hgamu,hgamv,hgamq + real(kind=kind_phys), intent(inout) :: ct,epshol +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(in ) :: cwm, & + q, & + q2, & + t, & + the, & + u, & + v +! + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(in ) :: mf, & + ufxpbl, & + vfxpbl, & + qfxpbl +! + real(kind=kind_phys), dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(out ) :: el, & + ri, & + gh, & + s2 +! + logical,intent(in) :: pblflg +! +! local vars +! + integer :: k,lpblm + real(kind=kind_phys) :: suk,svk,elocp + real(kind=kind_phys) :: a,aden,b,bden,aubr,bubr,blmx,el0,eloq2x,ghl,s2l, & + qol2st,qol2un,qdzl,rdz,sq,srel,szq,tem,thm,vkrmz,rlambda, & + rlb,rln,f + real(kind=kind_phys) :: ckp + real(kind=kind_phys), dimension( kts:kte ) :: q1, & + en2 + real(kind=kind_phys), dimension( kts+1:kte ) :: dth, & + elm, & + rel +! +!------------------------------------------------------------------------------- +! + elocp=2.72e6/cp + ct=0. +! + do k = kts,kte + q1(k) = 0. + enddo +! + do k = kts+1,kte + dth(k) = the(k)-the(k-1) + enddo +! + do k = kts+2,kte + if(dth(k)>0..and.dth(k-1)<=0.)then + dth(k)=dth(k)+ct + exit + endif + enddo +! +! compute local gradient richardson number +! + do k = kte,kts+1,-1 + rdz=2./(z(k+1)-z(k-1)) + s2l=((u(k)-u(k-1))**2+(v(k)-v(k-1))**2)*rdz*rdz ! s**2 + if(pblflg.and.k.le.lpbl)then + suk=(u(k)-u(k-1))*rdz + svk=(v(k)-v(k-1))*rdz + s2l=(suk-hgamu/hpbl-ufxpbl(k))*suk+(svk-hgamv/hpbl-vfxpbl(k))*svk + endif + s2l=max(s2l,epsgm) + s2(k)=s2l +! + tem=(t(k)+t(k-1))*0.5 + thm=(the(k)+the(k-1))*0.5 + a=thm*p608 + b=(elocp/tem-1.-p608)*thm + ghl=(dth(k)*((q(k)+q(k-1)+cwm(k)+cwm(k-1))*(0.5*p608)+1.) & + +(q(k)-q(k-1)+cwm(k)-cwm(k-1))*a & + +(cwm(k)-cwm(k-1))*b)*rdz ! dtheta/dz + if(pblflg.and.k.le.lpbl)then + ghl=ghl-mf(k)-(hgamq/hpbl+qfxpbl(k))*a + endif + if(abs(ghl)<=epsgh)ghl=epsgh +! + en2(k)=ghl*g/thm ! n**2 + gh(k)=ghl + ri(k)=en2(k)/s2l + enddo +! +! find maximum mixing lengths and the level of the pbl top +! + do k = kte,kts+1,-1 + s2l=s2(k) + ghl=gh(k) + if(ghl>=epsgh)then + if(s2l/ghl<=requ)then + elm(k)=epsl + else + aubr=(aubm*s2l+aubh*ghl)*ghl + bubr= bubm*s2l+bubh*ghl + qol2st=(-0.5*bubr+sqrt(bubr*bubr*0.25-aubr*cubr))*rcubr + eloq2x=1./qol2st + elm(k)=max(sqrt(eloq2x*q2(k)),epsl) + endif + else + aden=(adnm*s2l+adnh*ghl)*ghl + bden= bdnm*s2l+bdnh*ghl + qol2un=-0.5*bden+sqrt(bden*bden*0.25-aden) + eloq2x=1./(qol2un+epsru) ! repsr1/qol2un + elm(k)=max(sqrt(eloq2x*q2(k)),epsl) + endif + enddo +! + do k = lpbl,lmh,-1 + q1(k)=sqrt(q2(k)) + enddo +! + szq=0. + sq =0. + do k = kte,kts+1,-1 + qdzl=(q1(k)+q1(k-1))*(z(k)-z(k-1)) + szq=(z(k)+z(k-1)-z(lmh)-z(lmh))*qdzl+szq + sq=qdzl+sq + enddo +! +! computation of asymptotic l in blackadar formula +! + el0=min(alph*szq*0.5/sq,el0max) + el0=max(el0 ,el0min) +! +! above the pbl top +! + lpblm=min(lpbl+1,kte) + do k = kte,lpblm,-1 + el(k)=(z(k+1)-z(k-1))*elfc + rel(k)=el(k)/elm(k) + enddo +! +! inside the pbl +! + epshol=min(epshol,0.0) + ckp=elcbl*((1.0-8.0*epshol)**(1./3.)) + if(lpbl>lmh)then + do k = lpbl,lmh+1,-1 + vkrmz=(z(k)-z(lmh))*vkarman + if(pblflg) then + vkrmz=ckp*(z(k)-z(lmh))*vkarman + el(k)=vkrmz/(vkrmz/el0+1.) + else + el(k)=vkrmz/(vkrmz/el0+1.) + endif + rel(k)=el(k)/elm(k) + enddo + endif +! + do k = lpbl-1,lmh+2,-1 + srel=min(((rel(k-1)+rel(k+1))*0.5+rel(k))*0.5,rel(k)) + el(k)=max(srel*elm(k),epsl) + enddo +! +! mixing length for the qnse model in stable case +! + f=max(corf,eps1) + rlambda=f/(blckdr*ustar) + do k = kte,kts+1,-1 + if(en2(k)>=0.0)then ! stable case + vkrmz=(z(k)-z(lmh))*vkarman + rlb=rlambda+1./vkrmz + rln=sqrt(2.*en2(k)/q2(k))/cn + el(k)=1./(rlb+rln) + endif + enddo +! + end subroutine mixlen +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine prodq2(lmh,dtturbl,ustar,s2,ri,q2,el,z,akm,akh, & + uxk,vxk,thxk,thvxk, & + hgamu,hgamv,hgamq,delxy, & + hpbl,pblflg,kpbl, & + mf,ufxpbl,vfxpbl,qfxpbl, & + p608, & + kts,kte) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: epsq2l = 0.01,c0 = 0.55,ceps = 16.6,g = 9.81 +! + integer, intent(in ) :: kts,kte + integer, intent(in ) :: lmh,kpbl +! + real(kind=kind_phys), intent(in ) :: p608,dtturbl,ustar + real(kind=kind_phys), intent(in ) :: hgamu,hgamv,hgamq,delxy,hpbl +! + logical, intent(in ) :: pblflg +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(in ) :: uxk, & + vxk, & + thxk, & + thvxk + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(in ) :: s2, & + ri, & + akm, & + akh, & + el, & + mf, & + ufxpbl, & + vfxpbl, & + qfxpbl +! + real(kind=kind_phys), dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(inout) :: q2 +! +! local vars +! + integer :: k +! + real(kind=kind_phys) :: s2l,q2l,deltaz,akml,akhl,en2,pr,bpr,dis,rc02 + real(kind=kind_phys) :: suk,svk,gthvk,govrthvk,pru,prv + real(kind=kind_phys) :: thm,disel +! +!------------------------------------------------------------------------------- +! + rc02=2.0/(c0*c0) +! +! start of production/dissipation loop +! + main_integration: do k = kts+1,kte + deltaz=0.5*(z(k+1)-z(k-1)) + s2l=s2(k) + q2l=q2(k) + suk=(uxk(k)-uxk(k-1))/deltaz + svk=(vxk(k)-vxk(k-1))/deltaz + gthvk=(thvxk(k)-thvxk(k-1))/deltaz + govrthvk=g/(0.5*(thvxk(k)+thvxk(k-1))) + akml=akm(k) + akhl=akh(k) + en2=ri(k)*s2l !n**2 + thm=(thxk(k)+thxk(k-1))*0.5 +! +! turbulence production term +! + if(pblflg.and.k.le.kpbl)then + pru=(akml*(suk-hgamu/hpbl-ufxpbl(k)))*suk + prv=(akml*(svk-hgamv/hpbl-vfxpbl(k)))*svk + else + pru=akml*suk*suk + prv=akml*svk*svk + endif + pr=pru+prv +! +! buoyancy production +! + if(pblflg.and.k.le.kpbl)then + bpr=(akhl*(gthvk-mf(k)-(hgamq/hpbl+qfxpbl(k))*p608*thm))*govrthvk + else + bpr=akhl*gthvk*govrthvk + endif +! +! dissipation +! + disel=min(delxy,ceps*el(k)) + dis=(q2l)**1.5/disel +! + q2l=q2l+2.0*(pr-bpr-dis)*dtturbl + q2(k)=amax1(q2l,epsq2l) +! +! end of production/dissipation loop +! + enddo main_integration +! +! lower boundary condition for q2 +! + q2(kts)=amax1(rc02*ustar*ustar,epsq2l) +! + end subroutine prodq2 +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine vdifq(lmh,dtdif,q2,el,z, & + akhk,ptke1, & + hgame,hpbl,pblflg,kpbl, & + efxpbl, & + kts,kte) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: c_k=1.0,esq=5.0 +! + integer, intent(in ) :: kts,kte + integer, intent(in ) :: lmh,kpbl +! + real(kind=kind_phys), intent(in ) :: dtdif,hpbl,efxpbl +! + logical, intent(in ) :: pblflg +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(in ) :: hgame, & + ptke1 + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(in ) :: el, & + akhk + real(kind=kind_phys), dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(inout) :: q2 +! +! local vars +! + integer :: k +! + real(kind=kind_phys) :: aden,akqs,bden,besh,besm,cden,cf,dtozs,ell,eloq2,eloq4 + real(kind=kind_phys) :: elqdz,esh,esm,esqhf,ghl,gml,q1l,rden,rdz + real(kind=kind_phys) :: zak +! + real(kind=kind_phys), dimension( kts+1:kte ) :: zfacentk + real(kind=kind_phys), dimension( kts+2:kte ) :: akq, & + cm, & + cr, & + dtoz, & + rsq2 +! +!------------------------------------------------------------------------------- +! +! vertical turbulent diffusion +! + esqhf=0.5*esq + do k = kts+1,kte + zak=0.5*(z(k)+z(k-1)) !zak of vdifq = za(k-1) of shinhong2d + zfacentk(k)=(zak/hpbl)**3.0 + enddo +! + do k = kte,kts+2,-1 + dtoz(k)=(dtdif+dtdif)/(z(k+1)-z(k-1)) + akq(k)=c_k*(akhk(k)/(z(k+1)-z(k-1))+akhk(k-1)/(z(k)-z(k-2))) + akq(k)=akq(k)*ptke1(k) + cr(k)=-dtoz(k)*akq(k) + enddo +! + akqs=c_k*akhk(kts+1)/(z(kts+2)-z(kts)) + akqs=akqs*ptke1(kts+1) + cm(kte)=dtoz(kte)*akq(kte)+1. + rsq2(kte)=q2(kte) +! + do k = kte-1,kts+2,-1 + cf=-dtoz(k)*akq(k+1)/cm(k+1) + cm(k)=-cr(k+1)*cf+(akq(k+1)+akq(k))*dtoz(k)+1. + rsq2(k)=-rsq2(k+1)*cf+q2(k) + if(pblflg.and.k.lt.kpbl) then + rsq2(k)=rsq2(k)-dtoz(k)*(2.0*hgame(k)/hpbl)*akq(k+1)*(z(k+1)-z(k)) & + +dtoz(k)*(2.0*hgame(k-1)/hpbl)*akq(k)*(z(k)-z(k-1)) + rsq2(k)=rsq2(k)-dtoz(k)*2.0*efxpbl*zfacentk(k+1) & + +dtoz(k)*2.0*efxpbl*zfacentk(k) + endif + enddo +! + dtozs=(dtdif+dtdif)/(z(kts+2)-z(kts)) + cf=-dtozs*akq(lmh+2)/cm(lmh+2) +! + if(pblflg.and.((lmh+1).lt.kpbl)) then + q2(lmh+1)=(dtozs*akqs*q2(lmh)-rsq2(lmh+2)*cf+q2(lmh+1) & + -dtozs*(2.0*hgame(lmh+1)/hpbl)*akq(lmh+2)*(z(lmh+2)-z(lmh+1)) & + +dtozs*(2.0*hgame(lmh)/hpbl)*akqs*(z(lmh+1)-z(lmh))) + q2(lmh+1)=q2(lmh+1)-dtozs*2.0*efxpbl*zfacentk(lmh+2) & + +dtozs*2.0*efxpbl*zfacentk(lmh+1) + q2(lmh+1)=q2(lmh+1)/((akq(lmh+2)+akqs)*dtozs-cr(lmh+2)*cf+1.) + else + q2(lmh+1)=(dtozs*akqs*q2(lmh)-rsq2(lmh+2)*cf+q2(lmh+1)) & + /((akq(lmh+2)+akqs)*dtozs-cr(lmh+2)*cf+1.) + endif +! + do k = lmh+2,kte + q2(k)=(-cr(k)*q2(k-1)+rsq2(k))/cm(k) + enddo +! + end subroutine vdifq +!------------------------------------------------------------------------------- + function pu(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pu + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.0, a2 = 0.070, a3 = 1.0, a4 = 0.142, a5 = 0.071 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.6666667 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2 + den=a3*(doh)**b1+a4*(doh)**b2+a5 + pu=num/den + pu=max(pu,pmin) + pu=min(pu,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function pq(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pq + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.0, a2 = -0.098, a3 = 1.0, a4 = 0.106, a5 = 0.5 + real(kind=kind_phys),parameter :: b1 = 2.0 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2 + den=a3*(doh)**b1+a4 + pq=a5*num/den+(1.-a5) + pq=max(pq,pmin) + pq=min(pq,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function pthnl(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pthnl + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.936, a3 = -1.110, & + a4 = 1.000, a5 = 0.312, a6 = 0.329, a7 = 0.243 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.875 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2+a3 + den=a4*(doh)**b1+a5*(doh)**b2+a6 + pthnl=a7*num/den+(1.-a7) + pthnl=max(pthnl,pmin) + pthnl=min(pthnl,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function pthl(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pthl + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.870, a3 = -0.913, & + a4 = 1.000, a5 = 0.153, a6 = 0.278, a7 = 0.280 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.5 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2+a3 + den=a4*(doh)**b1+a5*(doh)**b2+a6 + pthl=a7*num/den+(1.-a7) + pthl=max(pthl,pmin) + pthl=min(pthl,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function ptke(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: ptke + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.070, & + a3 = 1.000, a4 = 0.142, a5 = 0.071 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.6666667 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2 + den=a3*(doh)**b1+a4*(doh)**b2+a5 + ptke=num/den + ptke=max(ptke,pmin) + ptke=min(ptke,pmax) +! + return + end function +!------------------------------------------------------------------------------- + end module shinhongvdif diff --git a/physics/ysuvdif.F90 b/physics/ysuvdif.F90 new file mode 100644 index 000000000..e76f2120b --- /dev/null +++ b/physics/ysuvdif.F90 @@ -0,0 +1,1271 @@ +!> \file ysuvdif.F90 +!! This file contains the CCPP-compliant YSU scheme which computes +!! subgrid vertical turbulence mixing using traditional K-profile method +!! Please refer to (Hong, Noh and Dudhia, 2006, MWR). +!! +!! Subroutine 'ysuvdif_run' computes subgrid vertical turbulence mixing +!! using YSU K-profile method +!! +!---------------------------------------------------------------------- + + module ysuvdif + contains + + subroutine ysuvdif_init () + end subroutine ysuvdif_init + + subroutine ysuvdif_finalize () + end subroutine ysuvdif_finalize + +!> \defgroup YSU FV3GFS ysuvdif_run Main +!! \brief This subroutine contains all of the logic for the +!! YSU scheme. +!! +!> \section arg_table_ysuvdif_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | ux | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | vx | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | tx | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!! | qx | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | +!! | p2d | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | p2di | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | pi2d | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | +!! | vtnp | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | utnp | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | ttnp | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | +!! | qtnp | tendency_of_tracers_due_to_model_physics | updated tendency of the tracers due to model physics | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | +!! | swh | tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step | total sky shortwave heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | hlw | tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step | total sky longwave heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | xmu | zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes | zenith angle temporal adjustment factor for shortwave | none | 1 | real | kind_phys | in | F | +!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | +!! | ndiff | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | +!! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | +!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | psfcpa | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | +!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | +!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | +!! | psim | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity function for momentum | none | 1 | real | kind_phys | in | F | +!! | psih | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity function for heat | none | 1 | real | kind_phys | in | F | +!! | landmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | heat | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | +!! | br | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | +!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | ep1 | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | ep2 | ratio_of_dry_air_to_water_vapor_gas_constants | rd/rv | none | 0 | real | kind_phys | in | F | +!! | xlv | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | +!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | kpbl1d | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | +!! | u10 | x_wind_at_10m | x component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | v10 | y_wind_at_10m | y component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!------------------------------------------------------------------------------- + subroutine ysuvdif_run(ix,im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & + utnp,vtnp,ttnp,qtnp, & + swh,hlw,xmu,ntrac,ndiff,ntcw,ntiw, & + phii,phil,psfcpa, & + zorl,stress,hpbl,psim,psih, & + landmask,heat,evap,wspd,br, & + g,rd,cp,rv,ep1,ep2,xlv, & + dusfc,dvsfc,dtsfc,dqsfc, & + dt,kpbl1d,u10,v10,errmsg,errflg ) + + use machine , only : kind_phys +! +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: xkzminm = 0.1,xkzminh = 0.01 + real(kind=kind_phys),parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. + real(kind=kind_phys),parameter :: rlam = 30.,prmin = 0.25,prmax = 4. + real(kind=kind_phys),parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 + real(kind=kind_phys),parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 + real(kind=kind_phys),parameter :: phifac = 8.,sfcfrac = 0.1 + real(kind=kind_phys),parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 + real(kind=kind_phys),parameter :: h1 = 0.33333335, h2 = 0.6666667 + real(kind=kind_phys),parameter :: zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. + real(kind=kind_phys),parameter :: tmin=1.e-2 + real(kind=kind_phys),parameter :: gamcrt = 3.,gamcrq = 2.e-3 + real(kind=kind_phys),parameter :: xka = 2.4e-5 + real(kind=kind_phys),parameter :: rcl = 1.0 + real(kind=kind_phys),parameter :: karman = 0.4 + integer,parameter :: imvdif = 1 + integer,parameter :: ysu_topdown_pblmix = 1 +! +!------------------------------------------------------------------------------------- +! input variables + integer, intent(in ) :: ix,im,km,ntrac,ndiff,ntcw,ntiw + real(kind=kind_phys), intent(in ) :: g,cp,rd,rv,ep1,ep2,xlv,dt + + real(kind=kind_phys), dimension( ix,km ), & + intent(in) :: pi2d,p2d,phil,ux,vx,swh,hlw,tx + + real(kind=kind_phys), dimension( ix,km,ntrac ) , & + intent(in ) :: qx + + real(kind=kind_phys), dimension( ix, km+1 ) , & + intent(in ) :: p2di,phii + + real(kind=kind_phys), dimension( im ) , & + intent(in) :: stress,zorl,heat,evap,wspd,br,psim,psih,psfcpa, & + u10,v10,xmu + integer, dimension(im) ,& + intent(in ) :: landmask +! +!---------------------------------------------------------------------------------- +! input/output variables +! + real(kind=kind_phys), dimension( im,km ) , & + intent(inout) :: utnp,vtnp,ttnp + real(kind=kind_phys), dimension( im,km,ntrac ) , & + intent(inout) :: qtnp +! +!--------------------------------------------------------------------------------- +! output variables + integer, dimension( im ), intent(out ) :: kpbl1d + real(kind=kind_phys), dimension( im ), & + intent(out) :: hpbl + + ! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +!-------------------------------------------------------------------------------- +! +! local vars +! + real(kind=kind_phys), dimension( im ) :: hol + real(kind=kind_phys), dimension( im, km+1 ) :: zq +! + real(kind=kind_phys), dimension( im, km ) :: & + thx,thvx,thlix, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za +! + real(kind=kind_phys), dimension( im ) :: & + rhox, & + govrth, & + zl1,thermal, & + wscale, & + hgamt,hgamq, & + brdn,brup, & + phim,phih, & + dusfc,dvsfc, & + dtsfc,dqsfc, & + prpbl, & + wspd1,thermalli +! + real(kind=kind_phys), dimension( im, km ) :: xkzm,xkzh, & + f1,f2, & + r1,r2, & + ad,au, & + cu, & + al, & + xkzq, & + zfac, & + rhox2, & + hgamt2 +! + real(kind=kind_phys), dimension( im ) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro +! + real(kind=kind_phys), dimension( im ) :: xland + real(kind=kind_phys), dimension( im ) :: ust + real(kind=kind_phys), dimension( im ) :: hfx + real(kind=kind_phys), dimension( im ) :: qfx + real(kind=kind_phys), dimension( im ) :: znt + real(kind=kind_phys), dimension( im ) :: uox + real(kind=kind_phys), dimension( im ) :: vox +! + real(kind=kind_phys), dimension( im, km, ndiff) :: r3,f3 + integer, dimension( im ) :: kpbl,kpblold +! + logical, dimension( im ) :: pblflg, & + sfcflg, & + stable, & + cloudflg + + logical :: definebrup +! + integer :: n,i,k,l,ic,is,kk + integer :: klpbl, ktrace1, ktrace2, ktrace3 +! +! + real(kind=kind_phys) :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 + real(kind=kind_phys) :: ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri + real(kind=kind_phys) :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz + real(kind=kind_phys) :: utend,vtend,ttend,qtend + real(kind=kind_phys) :: dtstep,govrthv + real(kind=kind_phys) :: cont, conq, conw, conwrc, rovcp +! + + real(kind=kind_phys), dimension( im, km ) :: wscalek,wscalek2 + real(kind=kind_phys), dimension( im ) :: wstar + real(kind=kind_phys), dimension( im ) :: delta + real(kind=kind_phys), dimension( im, km ) :: xkzml,xkzhl, & + zfacent,entfac + real(kind=kind_phys), dimension( im ) :: ust3, & + wstar3, & + wstar3_2, & + hgamu,hgamv, & + wm2, we, & + bfxpbl, & + hfxpbl,qfxpbl, & + ufxpbl,vfxpbl, & + dthvx + real(kind=kind_phys) :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & + dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & + prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff, & + rcldb,bruptmp,radflux +! +!------------------------------------------------------------------------------- +! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + klpbl = km +! + rovcp=rd/cp + cont=cp/g + conq=xlv/g + conw=1./g + conwrc = conw*sqrt(rcl) + conpr = bfac*karman*sfcfrac +! +! change xland values + do i=1,im + if(landmask(i).eq.0) then !ocean + xland(i) = 2 + else + xland(i) = 1 !land + end if + end do +! + do k = 1,km + do i = 1,im + thx(i,k) = tx(i,k)/pi2d(i,k) + thlix(i,k) = (tx(i,k)-xlv*qx(i,k,ntcw)/cp-2.834E6*qx(i,k,ntiw)/cp)/pi2d(i,k) + enddo + enddo +! + do k = 1,km + do i = 1,im + tvcon = (1.+ep1*qx(i,k,1)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo +! + do i = 1,im + tvcon = (1.+ep1*qx(i,1,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) + hfx(i) = heat(i)*rhox(i)*cp ! reset to the variable in WRF + qfx(i) = evap(i)*rhox(i) ! reset to the variable in WRF + ust(i) = sqrt(stress(i)) ! reset to the variable in WRF + znt(i) = 0.01*zorl(i) ! reset to the variable in WRF + uox(i) = 0.0 + vox(i) = 0.0 + enddo +! +!-----compute the height of full- and half-sigma levels above ground +! level, and the layer thicknesses. +! + do i = 1,im + zq(i,1) = 0. + enddo +! + do k = 1,km + do i = 1,im + zq(i,k+1) = phii(i,k+1)*conw + tvcon = (1.+ep1*qx(i,k,1)) + rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) + enddo + enddo +! + do k = 1,km + do i = 1,im + za(i,k) = phil(i,k)*conw + dzq(i,k) = zq(i,k+1)-zq(i,k) + del(i,k) = p2di(i,k)-p2di(i,k+1) + enddo + enddo +! + do i = 1,im + dza(i,1) = za(i,1) + enddo +! + do k = 2,km + do i = 1,im + dza(i,k) = za(i,k)-za(i,k-1) + enddo + enddo + +! write(0,*)"===CALLING ysu; input:" +! print*,"t:",tx(1,1),tx(1,2),tx(1,km) +! print*,"u:",ux(1,1),ux(1,2),ux(1,km) +! print*,"v:",vx(1,1),vx(1,2),vx(1,km) +! print*,"q:",qx(1,1,1),qx(1,2,1),qx(1,km,1) +! print*,"exner:",pi2d(1,1),pi2d(1,2),pi2d(1,km) +! print*,"phii:",zq(1,1),zq(1,2),zq(1,km+1) +! print*,"phil:",za(1,1),za(1,2),za(1,km) +! print*,"p2d:",p2d(1,1),p2d(1,2),p2d(1,km) +! print*,"p2di:",p2di(1,1),p2di(1,2),p2di(1,km+1) +! print *,"del:",del(1,1),del(1,2),del(1,km) +! print*,"znt,ust,wspd:",znt(1),ust(1),wspd(1) +! print*,"hfx,qfx,xland:",hfx(1),qfx(1),xland(1) +! print*,"rd,rv,g:",rd,rv,g +! print*,"ep1,ep2,xlv:",ep1,ep2,xlv +! print*,"br,psim,psih:",br(1),psim(1),psih(1) +! print*,"u10,v10:",u10(1),v10(1) +! print*,"psfcpa,cp:",psfcpa(1),cp +! print*,"ntrac,ndiff,ntcw,ntiw:",ntrac,ndiff,ntcw,ntiw +! +! +!-----initialize vertical tendencies and +! +! utnp(:,:) = 0. +! vtnp(:,:) = 0. +! ttnp(:,:) = 0. +! qtnp(:,:,:) = 0. +! + do i = 1,im + wspd1(i) = sqrt( (ux(i,1)-uox(i))*(ux(i,1)-uox(i)) + (vx(i,1)-vox(i))*(vx(i,1)-vox(i)) )+1.e-9 + enddo +! +!---- compute vertical diffusion +! +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! compute preliminary variables +! + dtstep = dt + dt2 = 2.*dtstep + rdt = 1./dt2 +! + do i = 1,im + bfxpbl(i) = 0.0 + hfxpbl(i) = 0.0 + qfxpbl(i) = 0.0 + ufxpbl(i) = 0.0 + vfxpbl(i) = 0.0 + hgamu(i) = 0.0 + hgamv(i) = 0.0 + delta(i) = 0.0 + wstar3_2(i) = 0.0 + enddo +! + do k = 1,klpbl + do i = 1,im + wscalek(i,k) = 0.0 + wscalek2(i,k) = 0.0 + enddo + enddo +! + do k = 1,klpbl + do i = 1,im + zfac(i,k) = 0.0 + enddo + enddo + do k = 1,klpbl-1 + do i = 1,im + xkzom(i,k) = xkzminm + xkzoh(i,k) = xkzminh + enddo + enddo +! + do i = 1,im + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + enddo +! + do i = 1,im + hgamt(i) = 0. + hgamq(i) = 0. + wscale(i) = 0. + kpbl(i) = 1 + hpbl(i) = zq(i,1) + zl1(i) = za(i,1) + thermal(i)= thvx(i,1) + thermalli(i) = thlix(i,1) + pblflg(i) = .true. + sfcflg(i) = .true. + sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) + if(br(i).gt.0.0) sfcflg(i) = .false. + enddo +! +! compute the first guess of pbl height +! + do i = 1,im + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + enddo +! + do k = 2,klpbl + do i = 1,im + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = 1,im + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + enddo +! + do i = 1,im + fm = psim(i) + fh = psih(i) + zol1(i) = max(br(i)*fm*fm/fh,rimin) + if(sfcflg(i))then + zol1(i) = min(zol1(i),-zfmin) + else + zol1(i) = max(zol1(i),zfmin) + endif + hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac + if(sfcflg(i))then + phim(i) = (1.-aphi16*hol1)**(-1./4.) + phih(i) = (1.-aphi16*hol1)**(-1./2.) + bfx0 = max(sflux(i),0.) + hfx0 = max(hfx(i)/rhox(i)/cp,0.) + qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) + wstar3(i) = (govrth(i)*bfx0*hpbl(i)) + wstar(i) = (wstar3(i))**h1 + else + phim(i) = (1.+aphi5*hol1) + phih(i) = phim(i) + wstar(i) = 0. + wstar3(i) = 0. + endif + ust3(i) = ust(i)**3. + wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + enddo +! +! compute the surface variables for pbl height estimation +! under unstable conditions +! + do i = 1,im + if(sfcflg(i).and.sflux(i).gt.0.0)then + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac + thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + thermalli(i)= thermalli(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + else + pblflg(i) = .false. + endif + enddo +! +! enhance the pbl height by considering the thermal +! + do i = 1,im + if(pblflg(i))then + kpbl(i) = 1 + hpbl(i) = zq(i,1) + endif + enddo +! + do i = 1,im + if(pblflg(i))then + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + endif + enddo +! + do k = 2,klpbl + do i = 1,im + if(.not.stable(i).and.pblflg(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! +! enhance pbl by theta-li +! + if (ysu_topdown_pblmix.eq.1)then + do i = 1,im + kpblold(i) = kpbl(i) + definebrup=.false. + do k = kpblold(i), km-1 + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + bruptmp = (thlix(i,k)-thermalli(i))*(g*za(i,k)/thlix(i,1))/spdk2 + stable(i) = bruptmp.ge.brcr(i) + if (definebrup) then + kpbl(i) = k + brup(i) = bruptmp + definebrup=.false. + endif + if (.not.stable(i)) then !overwrite brup brdn values + brdn(i)=bruptmp + definebrup=.true. + pblflg(i)=.true. + endif + enddo + enddo + endif + + do i = 1,im + if(pblflg(i)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! stable boundary layer +! + do i = 1,im + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + brup(i) = br(i) + stable(i) = .false. + else + stable(i) = .true. + endif + enddo +! + do i = 1,im + if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then + wspd10 = u10(i)*u10(i) + v10(i)*v10(i) + wspd10 = sqrt(wspd10) + ross = wspd10 / (cori*znt(i)) + brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3) + endif + enddo +! + do i = 1,im + if(.not.stable(i))then + if((xland(i)-1.5).ge.0)then + brcr(i) = brcr_sbro(i) + else + brcr(i) = brcr_sb + endif + endif + enddo +! + do k = 2,klpbl + do i = 1,im + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = 1,im + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! estimate the entrainment parameters +! + do i = 1,im + cloudflg(i)=.false. + if(pblflg(i)) then + k = kpbl(i) - 1 + wm3 = wstar3(i) + 5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + if((qx(i,k,ntcw)+qx(i,k,ntiw)).gt.0.01e-3.and.ysu_topdown_pblmix.eq.1)then + if ( kpbl(i) .ge. 2) then + cloudflg(i)=.true. + templ=thlix(i,k)*(p2di(i,k+1)/100000)**rovcp + !rvls is ws at full level + rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep2/p2di(i,k+1)) + temps=templ + ((qx(i,k,1)+qx(i,k,ntcw))-rvls)/(cp/xlv + & + ep2*xlv*rvls/(rd*templ**2)) + rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep2/p2di(i,k+1)) + rcldb=max((qx(i,k,1)+qx(i,k,ntcw))-rvls,0.) + !entrainment efficiency + dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qx(i,k+2,1)+qx(i,k+2,ntcw))) & + - (thlix(i,k) + thx(i,k) *ep1*(qx(i,k,1) +qx(i,k,ntcw))) + dthvx(i) = max(dthvx(i),0.1) + tmp1 = xlv/cp * rcldb/(pi2d(i,k)*dthvx(i)) + ent_eff = 0.2 * 8. * tmp1 +0.2 + + radsum=0. + do kk = 1,kpbl(i)-1 + radflux=swh(i,kk)*xmu(i)+hlw(i,kk) !radiative heating rate temp/s + radflux=radflux*cp/g*(p2di(i,kk)-p2di(i,kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + enddo + radsum=max(radsum,0.0) + + !recompute entrainment from sfc thermals + bfx0 = max(max(sflux(i),0.0)-radsum/rhox2(i,k)/cp,0.) + bfx0 = max(sflux(i),0.0) + wm3 = (govrth(i)*bfx0*hpbl(i))+5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + + !entrainment from PBL top thermals + bfx0 = max(radsum/rhox2(i,k)/cp-max(sflux(i),0.0),0.) + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wm3 = (g/thvx(i,k)*bfx0*hpbl(i)) ! this is wstar3(i) + wm2(i) = wm2(i)+wm3**h2 + bfxpbl(i) = - ent_eff * bfx0 + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),0.1) + we(i) = we(i) + max(bfxpbl(i)/dthvx(i),-sqrt(wm3**h2)) + + !wstar3_2 + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wstar3_2(i) = (g/thvx(i,k)*bfx0*hpbl(i)) + !recompute hgamt + wscale(i) = (ust3(i)+phifac*karman*(wstar3(i)+wstar3_2(i))*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + gamfac = bfac/rhox2(i,k)/wscale(i) + hgamt2(i,k) = min(gamfac*radsum/cp,gamcrt) + hgamt(i) = max(hgamt(i),0.0) + max(hgamt2(i,k),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*(wstar3(i)+wstar3_2(i))/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + endif + endif + prpbl(i) = 1.0 + dthx = max(thx(i,k+1)-thx(i,k),tmin) + dqx = min(qx(i,k+1,1)-qx(i,k,1),0.0) + hfxpbl(i) = we(i)*dthx + qfxpbl(i) = we(i)*dqx +! + dux = ux(i,k+1)-ux(i,k) + dvx = vx(i,k+1)-vx(i,k) + if(dux.gt.tmin) then + ufxpbl(i) = max(prpbl(i)*we(i)*dux,-ust(i)*ust(i)) + elseif(dux.lt.-tmin) then + ufxpbl(i) = min(prpbl(i)*we(i)*dux,ust(i)*ust(i)) + else + ufxpbl(i) = 0.0 + endif + if(dvx.gt.tmin) then + vfxpbl(i) = max(prpbl(i)*we(i)*dvx,-ust(i)*ust(i)) + elseif(dvx.lt.-tmin) then + vfxpbl(i) = min(prpbl(i)*we(i)*dvx,ust(i)*ust(i)) + else + vfxpbl(i) = 0.0 + endif + delb = govrth(i)*d3*hpbl(i) + delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) + endif + enddo +! + do k = 1,klpbl + do i = 1,im + if(pblflg(i).and.k.ge.kpbl(i))then + entfac(i,k) = ((zq(i,k+1)-hpbl(i))/delta(i))**2. + else + entfac(i,k) = 1.e30 + endif + enddo + enddo +! +! compute diffusion coefficients below pbl +! + do k = 1,klpbl + do i = 1,im + if(k.lt.kpbl(i)) then + zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) + zfacent(i,k) = (1.-zfac(i,k))**3. + wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 + wscalek2(i,k) = (phifac*karman*wstar3_2(i)*(zfac(i,k)))**h1 + if(sfcflg(i)) then + prfac = conpr + prfac2 = 15.9*(wstar3(i)+wstar3_2(i))/ust3(i)/(1.+4.*karman*(wstar3(i)+wstar3_2(i))/ust3(i)) + prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. + else + prfac = 0. + prfac2 = 0. + prnumfac = 0. + phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i) + wscalek(i,k) = ust(i)/phim8z + wscalek(i,k) = max(wscalek(i,k),0.001) + endif + prnum0 = (phih(i)/phim(i)+prfac) + prnum0 = max(min(prnum0,prmax),prmin) + xkzm(i,k) = wscalek(i,k) *karman* zq(i,k+1) * zfac(i,k)**pfac+ & + wscalek2(i,k)*karman*(hpbl(i)-zq(i,k+1))*(1-zfac(i,k))**pfac + !Do not include xkzm at kpbl-1 since it changes entrainment + if (k.eq.kpbl(i)-1.and.cloudflg(i).and.we(i).lt.0.0) then + xkzm(i,k) = 0.0 + endif + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) + prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzh(i,k) = xkzm(i,k)/prnum + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + endif + enddo + enddo +! +! compute diffusion coefficients over pbl (free atmosphere) +! + do k = 1,km-1 + do i = 1,im + if(k.ge.kpbl(i)) then + ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) & + +(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) & + /(dza(i,k+1)*dza(i,k+1))+1.e-9 + govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) + ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) + if(imvdif.eq.1.and.ntcw.ge.2.and.ntiw.ge.2)then + if((qx(i,k,ntcw)+qx(i,k,ntiw)).gt.0.01e-3.and.(qx(i & + ,k+1,ntcw)+qx(i,k+1,ntiw)).gt.0.01e-3)then +! in cloud + qmean = 0.5*(qx(i,k,1)+qx(i,k+1,1)) + tmean = 0.5*(tx(i,k)+tx(i,k+1)) + alph = xlv*qmean/rd/tmean + chi = xlv*xlv*qmean/cp/rv/tmean/tmean + ri = (1.+alph)*(ri-g*g/ss/tmean/cp*((chi-alph)/(1.+chi))) + endif + endif + zk = karman*zq(i,k+1) + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) + rlamdz = min(dza(i,k+1),rlamdz) + rl2 = (zk*rlamdz/(rlamdz+zk))**2 + dk = rl2*sqrt(ss) + if(ri.lt.0.)then +! unstable regime + ri = max(ri, rimin) + sri = sqrt(-ri) + xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) + xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) + else +! stable regime + xkzh(i,k) = dk/(1+5.*ri)**2 + prnum = 1.0+2.1*ri + prnum = min(prnum,prmax) + xkzm(i,k) = xkzh(i,k)*prnum + endif +! + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzml(i,k) = xkzm(i,k) + xkzhl(i,k) = xkzh(i,k) + endif + enddo + enddo +! +! compute tridiagonal matrix elements for heat +! + do k = 1,km + do i = 1,im + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + enddo + enddo +! + do i = 1,im + ad(i,1) = 1. + f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2 + enddo +! + do k = 1,km-1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzh(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzt = tem1*(-hgamt(i)/hpbl(i)-hfxpbl(i)*zfacent(i,k)/xkzh(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + f1(i,k+1) = thx(i,k+1)-300. + else + f1(i,k+1) = thx(i,k+1)-300. + endif + tem1 = dsig*xkzh(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = 1,km + do i = 1,im + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo +! + call tridin_ysu(al,ad,cu,r1,au,f1,im,km,1) +! +! recover tendencies of heat +! + do k = km,1,-1 + do i = 1,im + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + ttnp(i,k) = ttnp(i,k)+ttend + dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k) + enddo + enddo +! +! compute tridiagonal matrix elements for moisture, clouds, and gases +! + do k = 1,km + do i = 1,im + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + enddo + enddo +! + do ic = 1,ndiff + do i = 1,im + do k = 1,km + f3(i,k,ic) = 0. + enddo + enddo + enddo +! + do i = 1,im + ad(i,1) = 1. + f3(i,1,1) = qx(i,1,1)+qfx(i)*g/del(i,1)*dt2 + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do i = 1,im + f3(i,1,ic) = qx(i,1,ic) + enddo + enddo + endif +! + do k = 1,km-1 + do i = 1,im + if(k.ge.kpbl(i)) then + xkzq(i,k) = xkzh(i,k) + endif + enddo + enddo +! + do k = 1,km-1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzq(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k)) + f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq + f3(i,k+1,1) = qx(i,k+1,1)-dtodsu*dsdzq + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) + xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + f3(i,k+1,1) = qx(i,k+1,1) + else + f3(i,k+1,1) = qx(i,k+1,1) + endif + tem1 = dsig*xkzq(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do k = 1,km-1 + do i = 1,im + f3(i,k+1,ic) = qx(i,k+1,ic) + enddo + enddo + enddo + endif +! +! copies here to avoid duplicate input args for tridin +! + do k = 1,km + do i = 1,im + cu(i,k) = au(i,k) + enddo + enddo +! + do ic = 1,ndiff + do k = 1,km + do i = 1,im + r3(i,k,ic) = f3(i,k,ic) + enddo + enddo + enddo +! +! solve tridiagonal problem for moisture, clouds, and gases +! + call tridin_ysu(al,ad,cu,r3,au,f3,im,km,ndiff) +! +! recover tendencies of heat and moisture +! + do k = km,1,-1 + do i = 1,im + qtend = (f3(i,k,1)-qx(i,k,1))*rdt + qtnp(i,k,1) = qtnp(i,k,1)+qtend + dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do k = km,1,-1 + do i = 1,im + qtend = (f3(i,k,ic)-qx(i,k,ic))*rdt + qtnp(i,k,ic) = qtnp(i,k,ic)+qtend + enddo + enddo + enddo + endif +! +! compute tridiagonal matrix elements for momentum +! + do i = 1,im + do k = 1,km + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + f2(i,k) = 0. + enddo + enddo +! + do i = 1,im + ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 + f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) + f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) + enddo +! + do k = 1,km-1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzm(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i))then + dsdzu = tem1*(-hgamu(i)/hpbl(i)-ufxpbl(i)*zfacent(i,k)/xkzm(i,k)) + dsdzv = tem1*(-hgamv(i)/hpbl(i)-vfxpbl(i)*zfacent(i,k)/xkzm(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzu + f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu + f2(i,k) = f2(i,k)+dtodsd*dsdzv + f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzm(i,k) = prpbl(i)*xkzh(i,k) + xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + else + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + endif + tem1 = dsig*xkzm(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = 1,km + do i = 1,im + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + r2(i,k) = f2(i,k) + enddo + enddo +! +! solve tridiagonal problem for momentum +! + call tridi1n(al,ad,cu,r1,r2,au,f1,f2,im,km,1) +! +! recover tendencies of momentum +! + do k = km,1,-1 + do i = 1,im + utend = (f1(i,k)-ux(i,k))*rdt + vtend = (f2(i,k)-vx(i,k))*rdt + utnp(i,k) = utnp(i,k)+utend + vtnp(i,k) = vtnp(i,k)+vtend + dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) + dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) + enddo + enddo +! +!---- end of vertical diffusion +! + do i = 1,im + kpbl1d(i) = kpbl(i) + enddo +! +! + end subroutine ysuvdif_run +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,im,km,nt) + use machine , only : kind_phys +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: im, km, nt +! + real(kind=kind_phys), dimension( im, 2:km+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( im, km ) , & + intent(in ) :: cm, & + r1 + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( im, km ) , & + intent(inout) :: au, & + cu, & + f1 + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = im + n = km +! + do i = 1,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f1(i,1) = fk*r1(i,1) + enddo +! + do it = 1,nt + do i = 1,l + fk = 1./cm(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do k = 2,n-1 + do i = 1,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) + enddo + enddo +! + do it = 1,nt + do k = 2,n-1 + do i = 1,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do i = 1,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) + enddo +! + do it = 1,nt + do i = 1,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do k = n-1,1,-1 + do i = 1,l + f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) + enddo + enddo +! + do it = 1,nt + do k = n-1,1,-1 + do i = 1,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridi1n +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridin_ysu(cl,cm,cu,r2,au,f2,im,km,nt) + use machine , only : kind_phys +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: im, km, nt +! + real(kind=kind_phys), dimension( im, 2:km+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( im, km ) , & + intent(in ) :: cm + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( im, km ) , & + intent(inout) :: au, & + cu + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = im + n = km +! + do it = 1,nt + do i = 1,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do it = 1,nt + do k = 2,n-1 + do i = 1,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do it = 1,nt + do i = 1,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do it = 1,nt + do k = n-1,1,-1 + do i = 1,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin_ysu +!------------------------------------------------------------------------------- +end module ysuvdif +!------------------------------------------------------------------------------- From 5a6dfc1d23834cf2c6c9f5031533d254f9965f0a Mon Sep 17 00:00:00 2001 From: climbfuji Date: Thu, 7 Feb 2019 11:56:36 -0700 Subject: [PATCH 02/15] physics/cu_ntiedtke.F90: add reminder to replace imported constants with subroutine arguments --- physics/cu_ntiedtke.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/physics/cu_ntiedtke.F90 b/physics/cu_ntiedtke.F90 index 53f59f2b0..1b28110b0 100644 --- a/physics/cu_ntiedtke.F90 +++ b/physics/cu_ntiedtke.F90 @@ -10,6 +10,9 @@ module cu_ntiedtke !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ use machine , only : kind_phys + ! DH* TODO - replace with arguments to subroutine calls, + ! this also requires redefining derived constants in the + ! parameter section below use physcons, only:rd=>con_rd, rv=>con_rv, g=>con_g, & & cpd=>con_cp, alv=>con_hvap, alf=>con_hfus From cd045f4fb759b8b694183ba64ae567de9624c41b Mon Sep 17 00:00:00 2001 From: climbfuji Date: Thu, 7 Feb 2019 11:56:57 -0700 Subject: [PATCH 03/15] physics/m_micro_interstitial.F90: remove unused arguments imfdeepcnv and imfshalcnv --- physics/m_micro_interstitial.F90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/physics/m_micro_interstitial.F90 b/physics/m_micro_interstitial.F90 index 85b1cbfdc..259c82519 100644 --- a/physics/m_micro_interstitial.F90 +++ b/physics/m_micro_interstitial.F90 @@ -25,8 +25,6 @@ end subroutine m_micro_pre_init !! | do_shoc | flag_for_shoc | flag for SHOC | flag | 0 | logical | | in | F | !! | fprcp | number_of_frozen_precipitation_species | number of frozen precipitation species | count | 0 | integer | | in | F | !! | mg3_as_mg2 | flag_mg3_as_mg2 | flag for controlling prep for Morrison-Gettelman microphysics | flag | 0 | logical | | in | F | -!! | imfdeepcnv | flag_for_mass_flux_deep_convection_scheme | flag for mass-flux deep convection scheme | flag | 0 | integer | | in | F | -!! | imfshalcnv | flag_for_mass_flux_shallow_convection_scheme | flag for mass-flux shallow convection scheme | flag | 0 | integer | | in | F | !! | gq0_ice | ice_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of ice water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | !! | gq0_water | cloud_condensed_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of cloud condensed water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | !! | gq0_rain | rain_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of rain water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | @@ -58,14 +56,14 @@ end subroutine m_micro_pre_init !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! #endif - subroutine m_micro_pre_run (im, levs, do_shoc, fprcp, mg3_as_mg2, imfdeepcnv, imfshalcnv, gq0_ice, gq0_water, & - gq0_rain, gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, gq0_graupel_nc, cld_shoc, cnvc, cnvw, tcr, tcrf, gt0, & + subroutine m_micro_pre_run (im, levs, do_shoc, fprcp, mg3_as_mg2, gq0_ice, gq0_water, gq0_rain, & + gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, gq0_graupel_nc, cld_shoc, cnvc, cnvw, tcr, tcrf, gt0, & qrn, qsnw, qgl, ncpr, ncps, ncgl, cld_frc_MG, qlcn, qicn, cf_upi, clw_water, clw_ice, clcn, errmsg, errflg ) use machine, only : kind_phys implicit none - integer, intent(in) :: im, levs, imfdeepcnv, imfshalcnv, fprcp + integer, intent(in) :: im, levs, fprcp logical, intent(in) :: do_shoc, mg3_as_mg2 real(kind=kind_phys), intent(in) :: tcr, tcrf From 819d23b8aa1b106d6be66370102ca6f82ad0318f Mon Sep 17 00:00:00 2001 From: climbfuji Date: Thu, 7 Feb 2019 11:57:50 -0700 Subject: [PATCH 04/15] Add physics/cu_ntiedtke_pre.F90 and physics/cu_ntiedtke_post.F90, similar to the GF pre and post schemes --- physics/cu_ntiedtke_post.F90 | 53 +++++++++++++++++++++++ physics/cu_ntiedtke_pre.F90 | 84 ++++++++++++++++++++++++++++++++++++ 2 files changed, 137 insertions(+) create mode 100644 physics/cu_ntiedtke_post.F90 create mode 100644 physics/cu_ntiedtke_pre.F90 diff --git a/physics/cu_ntiedtke_post.F90 b/physics/cu_ntiedtke_post.F90 new file mode 100644 index 000000000..fdc0b8b0f --- /dev/null +++ b/physics/cu_ntiedtke_post.F90 @@ -0,0 +1,53 @@ +!> \file cu_ntiedtke_post.F90 +!! Contains code related to New Tiedtke convective scheme + +module cu_ntiedtke_post + + implicit none + + private + + public :: cu_ntiedtke_post_init, cu_ntiedtke_post_run, cu_ntiedtke_post_finalize + + contains + + subroutine cu_ntiedtke_post_init () + end subroutine cu_ntiedtke_post_init + + subroutine cu_ntiedtke_post_finalize() + end subroutine cu_ntiedtke_post_finalize + +!> \section arg_table_cu_ntiedtke_post_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|--------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | t | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | in | F | +!! | q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | prevst | temperature_from_previous_timestep | temperature from previous time step | K | 2 | real | kind_phys | out | F | +!! | prevsq | moisture_from_previous_timestep | moisture from previous time step | kg kg-1 | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_ntiedtke_post_run (t, q, prevst, prevsq, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(out) :: prevst(:,:) + real(kind_phys), intent(out) :: prevsq(:,:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + prevst(:,:) = t(:,:) + prevsq(:,:) = q(:,:) + + end subroutine cu_ntiedtke_post_run + +end module cu_ntiedtke_post diff --git a/physics/cu_ntiedtke_pre.F90 b/physics/cu_ntiedtke_pre.F90 new file mode 100644 index 000000000..725b4a351 --- /dev/null +++ b/physics/cu_ntiedtke_pre.F90 @@ -0,0 +1,84 @@ +!> \file cu_ntiedtke_pre.F90 +!! Contains code related to New Tiedtke convective scheme + +module cu_ntiedtke_pre + + implicit none + + private + + public :: cu_ntiedtke_pre_init, cu_ntiedtke_pre_run, cu_ntiedtke_pre_finalize + + contains + + subroutine cu_ntiedtke_pre_init () + end subroutine cu_ntiedtke_pre_init + + subroutine cu_ntiedtke_pre_finalize() + end subroutine cu_ntiedtke_pre_finalize + +!> \section arg_table_cu_ntiedtke_pre_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|--------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | flag_init | flag_for_first_time_step | flag signaling first time step for time integration loop | flag | 0 | logical | | in | F | +!! | flag_restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | +!! | kdt | index_of_time_step | current forecast iteration | index | 0 | integer | | in | F | +!! | fhour | forecast_time | curent forecast time | h | 0 | real | kind_phys | in | F | +!! | dtp | time_step_for_physics | physics timestep | s | 0 | real | kind_phys | in | F | +!! | t | air_temperature | model layer mean temperature | K | 2 | real | kind_phys | in | F | +!! | q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!! | prevst | temperature_from_previous_timestep | temperature from previous time step | K | 2 | real | kind_phys | in | F | +!! | prevsq | moisture_from_previous_timestep | moisture from previous time step | kg kg-1 | 2 | real | kind_phys | in | F | +!! | forcet | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | out | F | +!! | forceq | moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_ntiedtke_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & + forcet, forceq, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + logical, intent(in) :: flag_init + logical, intent(in) :: flag_restart + integer, intent(in) :: kdt + real(kind_phys), intent(in) :: fhour + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(in) :: prevst(:,:) + real(kind_phys), intent(in) :: prevsq(:,:) + real(kind_phys), intent(out) :: forcet(:,:) + real(kind_phys), intent(out) :: forceq(:,:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind=kind_phys) :: dtdyn + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! For restart runs, can assume that prevst and prevsq + ! are read from the restart files beforehand, same + ! for conv_act. + if(flag_init .and. .not.flag_restart) then + forcet(:,:)=0.0 + forceq(:,:)=0.0 + else + dtdyn=3600.0*(fhour)/kdt + if(dtp > dtdyn) then + forcet(:,:)=(t(:,:) - prevst(:,:))/dtp + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp + else + forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn + endif + endif + + end subroutine cu_ntiedtke_pre_run + +end module cu_ntiedtke_pre From b482f11daf7855add057d647b2aaec5418300ca1 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 22 Feb 2019 18:05:18 -0700 Subject: [PATCH 05/15] physics/GFS_PBL_generic.F90: add compatibility with satmedmf --- physics/GFS_PBL_generic.F90 | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index f2168834e..077519cc2 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -38,6 +38,8 @@ end subroutine GFS_PBL_generic_pre_finalize !! | imp_physics_thompson | flag_for_thompson_microphysics_scheme | choice of Thompson microphysics scheme | flag | 0 | integer | | in | F | !! | imp_physics_wsm6 | flag_for_wsm6_microphysics_scheme | choice of WSM6 microphysics scheme | flag | 0 | integer | | in | F | !! | ltaerosol | flag_for_aerosol_physics | flag for aerosol physics | flag | 0 | logical | | in | F | +!! | hybedmf | flag_for_hedmf | flag for hybrid edmf pbl scheme (moninedmf) | flag | 0 | logical | | in | F | +!! | do_shoc | flag_for_shoc | flag for SHOC | flag | 0 | logical | | in | F | !! | satmedmf | flag_for_scale_aware_TKE_moist_EDMF_PBL | flag for scale-aware TKE moist EDMF PBL scheme | flag | 0 | logical | | in | F | !! | qgrs | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | !! | vdftra | vertically_diffused_tracer_concentration | tracer concentration diffused by PBL scheme | kg kg-1 | 3 | real | kind_phys | inout | F | @@ -48,7 +50,7 @@ end subroutine GFS_PBL_generic_pre_finalize subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - ltaerosol, satmedmf, qgrs, vdftra, errmsg, errflg) + ltaerosol, hybedmf, do_shoc, satmedmf, qgrs, vdftra, errmsg, errflg) use machine, only : kind_phys @@ -57,7 +59,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, integer, intent(in) :: im, levs, nvdiff, ntrac integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntwa, ntia, ntgl, ntoz, ntke, ntkev integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 - logical, intent(in) :: ltaerosol, satmedmf + logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: qgrs real(kind=kind_phys), dimension(im, levs, nvdiff), intent(inout) :: vdftra @@ -72,7 +74,8 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, errmsg = '' errflg = 0 - if(nvdiff == ntrac) then +!DH: dvdftra is only used if nvdiff != ntrac or (nvdiff == ntrac .and. ) + if (nvdiff == ntrac .and. (hybedmf .or. do_shoc .or. satmedmf)) then vdftra = qgrs else if (imp_physics == imp_physics_wsm6) then @@ -271,7 +274,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, errmsg = '' errflg = 0 !GJF: dvdftra is only used if nvdiff != ntrac or (nvdiff == ntrac .and. ) - if (nvdiff == ntrac .and. (hybedmf .or. do_shoc)) then + if (nvdiff == ntrac .and. (hybedmf .or. do_shoc .or. satmedmf)) then dqdt = dvdftra elseif (nvdiff /= ntrac) then if (imp_physics == imp_physics_wsm6) then From b77ed10da52c3229030aa8d5ad94179fec77d85c Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 22 Feb 2019 18:06:06 -0700 Subject: [PATCH 06/15] physics/satmedmfvdif.F: use diffused tracer arrays as in moninedmf (hedmf) to support both cases nvdiff=ntrac and nvdiff/=ntrac --- physics/satmedmfvdif.F | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index c210d97a2..792895a32 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -40,7 +40,7 @@ end subroutine satmedmfvdif_finalize !! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | !! | ntrac | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | !! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | -!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | +!! | ntiw | index_for_ice_cloud_condensate_vertical_diffusion_tracer | tracer index for ice water in the vertically diffused tracer array | index | 0 | integer | | in | F | !! | ntke | index_for_turbulent_kinetic_energy_vertical_diffusion_tracer | index for turbulent kinetic energy in the vertically diffused tracer array | index | 0 | integer | | in | F | !! | grav | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | !! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | @@ -54,11 +54,11 @@ end subroutine satmedmfvdif_finalize !! | dv | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | !! | du | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | !! | tdt | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | -!! | rtg | tendency_of_tracers_due_to_model_physics | updated tendency of the tracers due to model physics | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | +!! | rtg | tendency_of_vertically_diffused_tracer_concentration | updated tendency of the tracers due to vertical diffusion in PBL scheme | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | !! | u1 | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | !! | v1 | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | !! | t1 | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!! | q1 | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | +!! | q1 | vertically_diffused_tracer_concentration | tracer concentration diffused by PBL scheme | kg kg-1 | 3 | real | kind_phys | in | F | !! | swh | tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step | total sky shortwave heating rate | K s-1 | 2 | real | kind_phys | in | F | !! | hlw | tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step | total sky longwave heating rate | K s-1 | 2 | real | kind_phys | in | F | !! | xmu | zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes | zenith angle temporal adjustment factor for shortwave | none | 1 | real | kind_phys | in | F | From c8e22a8afd98cc94441c29f28fe4aac81406d4cb Mon Sep 17 00:00:00 2001 From: climbfuji Date: Mon, 25 Feb 2019 13:02:07 -0700 Subject: [PATCH 07/15] CMakeLists.txt: introduce SCHEMES_SFX list that contains files with special compiler flags, clean up the way compiler flags are assigned to files, add special compiler flags for csawmg physics and for GFDL-MP physics when fast physics (dynamics) are compiled in 32-bit precision --- CMakeLists.txt | 103 ++++++++++++++++++++++++++----------------------- 1 file changed, 54 insertions(+), 49 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 16864dde8..2df5a8817 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -100,6 +100,8 @@ list(APPEND LIBS "ccpp") include(./CCPP_SCHEMES.cmake) # Set the sources: physics scheme caps include(./CCPP_CAPS.cmake) +# Create empty lists for schemes with special compiler flags +set(SCHEMES_SFX "") #------------------------------------------------------------------------------ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") @@ -111,10 +113,7 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") if (PROJECT STREQUAL "CCPP-FV3") if (DYN32) - set(CMAKE_Fortran_FLAGS_OPT32BIT ${CMAKE_Fortran_FLAGS}) - string(REPLACE "-fdefault-real-8" "" CMAKE_Fortran_FLAGS_OPT32BIT "${CMAKE_Fortran_FLAGS_OPT32BIT}") - SET_SOURCE_FILES_PROPERTIES(./physics/gfdl_fv_sat_adj.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT32BIT}") + message (FATAL_ERROR "The current build system does not allow building fast physics with 32-bit precision when the GNU compilers are used") endif (DYN32) endif (PROJECT STREQUAL "CCPP-FV3") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") @@ -133,6 +132,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 + ./physics/radiation_aerosols.f ./physics/cu_gf_deep.F90 ./physics/cu_gf_sh.F90 ./physics/module_bl_mynn.F90 @@ -141,11 +141,10 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/module_MYNNSFC_wrapper.F90 ./physics/module_MYNNrad_pre.F90 ./physics/module_MYNNrad_post.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -ftz") - # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files (following FV3/gfsphysics/makefile) - # for bit-for-bit reproducibility with non-CCPP builds. These may go in the future once the CCPP solution - # is fully accepted. - set(CMAKE_Fortran_FLAGS_LOPT1 ${CMAKE_Fortran_FLAGS}) + PROPERTIES COMPILE_FLAGS "-r8 -ftz") + + # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files + set(CMAKE_Fortran_FLAGS_LOPT1 ${CMAKE_Fortran_FLAGS_OPT}) string(REPLACE "-xHOST" "-xCORE-AVX-I" CMAKE_Fortran_FLAGS_LOPT1 "${CMAKE_Fortran_FLAGS_LOPT1}") @@ -156,35 +155,28 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") CMAKE_Fortran_FLAGS_LOPT1 "${CMAKE_Fortran_FLAGS_LOPT1}") SET_SOURCE_FILES_PROPERTIES(./physics/radiation_aerosols.f - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT1} -r8 -ftz") + PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT1}") + # Add all of the above files to the list of schemes with special compiler flags + list(APPEND SCHEMES_SFX ./physics/radiation_aerosols.f) + # Force consistent results of math calculations for MG microphysics; - # in Debug/Bitforbit) mode; without this flag, the results of the + # in Debug/Bitforbit mode; without this flag, the results of the # intrinsic gamma function are different for the non-CCPP and CCPP # version (on Theia with Intel 18). Note this is only required with # dynamic CCPP builds (hybrid, standalone), not with static CCPP builds. if (${CMAKE_BUILD_TYPE} MATCHES "Debug") SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 ./physics/micro_mg3_0.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS} -fimf-arch-consistency=true") + PROPERTIES COMPILE_FLAGS "-fimf-arch-consistency=true") elseif (${CMAKE_BUILD_TYPE} MATCHES "Bitforbit") SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 ./physics/micro_mg3_0.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS} -fimf-arch-consistency=true") - endif (${CMAKE_BUILD_TYPE} MATCHES "Debug") - if (DYN32) - set(CMAKE_Fortran_FLAGS_OPT32BIT ${CMAKE_Fortran_FLAGS}) - string(REPLACE "-real-size 64" "-real-size 32" CMAKE_Fortran_FLAGS_OPT32BIT "${CMAKE_Fortran_FLAGS_OPT32BIT}") - string(REPLACE "-r8" "-r4" CMAKE_Fortran_FLAGS_OPT32BIT "${CMAKE_Fortran_FLAGS_OPT32BIT}") - SET_SOURCE_FILES_PROPERTIES(./physics/gfdl_fv_sat_adj.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT32BIT}") - endif (DYN32) - - # For CCPP acceptance: selective reduction of optimization flags, hopefully - # to be removed once established that this is not a reasonable approach. - if (TRANSITION) - # Replace "-no-prec-div -no-prec-sqrt" with "-prec-div -prec-sqrt", - # replace "CORE-AVX2" with "CORE-AVX-I" - set(CMAKE_Fortran_FLAGS_LOPT2 ${CMAKE_Fortran_FLAGS}) + PROPERTIES COMPILE_FLAGS "-fimf-arch-consistency=true") + elseif (TRANSITION) + # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I, -no-prec-div with -prec-div, and + # -no-prec-sqrt with -prec-sqrt for certain files for bit-for-bit reproducibility + # with non-CCPP builds. These may go in the future once the CCPP solution is fully accepted. + set(CMAKE_Fortran_FLAGS_LOPT2 ${CMAKE_Fortran_FLAGS_OPT}) string(REPLACE "-no-prec-div" "-prec-div" CMAKE_Fortran_FLAGS_LOPT2 "${CMAKE_Fortran_FLAGS_LOPT2}") @@ -197,21 +189,39 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") string(REPLACE "-axSSE4.2,AVX,CORE-AVX2" "-axSSE4.2,AVX,CORE-AVX-I" CMAKE_Fortran_FLAGS_LOPT2 "${CMAKE_Fortran_FLAGS_LOPT2}") - SET_SOURCE_FILES_PROPERTIES(./physics/module_gfdl_cloud_microphys.F90 + SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 + ./physics/micro_mg3_0.F90 + ./physics/aer_cloud.F + ./physics/cldmacro.F + ./physics/gfdl_fv_sat_adj.F90 + ./physics/module_gfdl_cloud_microphys.F90 ./physics/sflx.f ./physics/satmedmfvdif.F + ./physics/cs_conv.F90 PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT2}") - # Replace "CORE-AVX2" with "CORE-AVX-I" - set(CMAKE_Fortran_FLAGS_LOPT3 ${CMAKE_Fortran_FLAGS}) - string(REPLACE "-xCORE-AVX2" "-xCORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT3 - "${CMAKE_Fortran_FLAGS_LOPT3}") - string(REPLACE "-axSSE4.2,AVX,CORE-AVX2" "-axSSE4.2,AVX,CORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT3 - "${CMAKE_Fortran_FLAGS_LOPT3}") - SET_SOURCE_FILES_PROPERTIES(./physics/gfdl_fv_sat_adj.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT3}") - endif (TRANSITION) + # Add all of the above files to the list of schemes with special compiler flags + list(APPEND SCHEMES_SFX ./physics/micro_mg2_0.F90 + ./physics/micro_mg3_0.F90 + ./physics/aer_cloud.F + ./physics/cldmacro.F + ./physics/module_gfdl_cloud_microphys.F90 + ./physics/sflx.f + ./physics/satmedmfvdif.F + ./physics/cs_conv.F90 + ./physics/gfdl_fv_sat_adj.F90) + endif (${CMAKE_BUILD_TYPE} MATCHES "Debug") + + # Remove files with special compiler flags from list of files with standard compiler flags + list(REMOVE_ITEM SCHEMES ${SCHEMES_SFX}) + # Assign standard compiler flags to all remaining schemes and caps + SET_SOURCE_FILES_PROPERTIES(${SCHEMES} ${CAPS} + PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT}") + + # This has to come last: append 32-bit dynamics flags to certain files that are executed + # in the dynamics (fast physics part); this will overwrite any preceding -real-size 64 + if (DYN32) + SET_PROPERTY(SOURCE ./physics/gfdl_fv_sat_adj.F90 APPEND_STRING PROPERTY COMPILE_FLAGS " -real-size 32 ") + endif (DYN32) else (PROJECT STREQUAL "CCPP-FV3") SET_SOURCE_FILES_PROPERTIES(./physics/module_bfmicrophysics.f ./physics/rascnvv2.f ./physics/sflx.f ./physics/sfc_diff.f ./physics/sfc_diag.f PROPERTIES COMPILE_FLAGS -r8) @@ -228,10 +238,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-r8") if (PROJECT STREQUAL "CCPP-FV3") if (DYN32) - set(CMAKE_Fortran_FLAGS_OPT32BIT ${CMAKE_Fortran_FLAGS}) - string(REPLACE "-r8" "-r4" CMAKE_Fortran_FLAGS_OPT32BIT "${CMAKE_Fortran_FLAGS_OPT32BIT}") - SET_SOURCE_FILES_PROPERTIES(./physics/gfdl_fv_sat_adj.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT32BIT}") + SET_PROPERTY(SOURCE ./physics/gfdl_fv_sat_adj.F90 APPEND_STRING PROPERTY COMPILE_FLAGS " -r4 ") endif (DYN32) endif (PROJECT STREQUAL "CCPP-FV3") else (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") @@ -280,7 +287,7 @@ endif (PROJECT STREQUAL "CCPP-FV3") #------------------------------------------------------------------------------ if(STATIC) - add_library(ccppphys STATIC ${SCHEMES} ${CAPS}) + add_library(ccppphys STATIC ${SCHEMES} ${SCHEMES_SFX} ${CAPS}) # Generate list of Fortran modules from defined sources foreach(source_f90 ${CAPS}) string(REGEX REPLACE ".F90" ".mod" tmp_module_f90 ${source_f90}) @@ -288,7 +295,7 @@ if(STATIC) list(APPEND MODULES_F90 ${CMAKE_CURRENT_BINARY_DIR}/../${module_f90}) endforeach() else(STATIC) - add_library(ccppphys ${SCHEMES} ${CAPS}) + add_library(ccppphys ${SCHEMES} ${SCHEMES_SFX} ${CAPS}) endif(STATIC) if (PROJECT STREQUAL "CCPP-FV3") @@ -297,9 +304,7 @@ elseif (PROJECT STREQUAL "CCPP-SCM") target_link_libraries(ccppphys LINK_PUBLIC ${LIBS} w3 sp bacio) endif (PROJECT STREQUAL "CCPP-FV3") set_target_properties(ccppphys PROPERTIES VERSION ${PROJECT_VERSION} - SOVERSION ${PROJECT_VERSION_MAJOR} - COMPILE_FLAGS "${CMAKE_Fortran_FLAGS}" - LINK_FLAGS "${CMAKE_Fortran_FLAGS}") + SOVERSION ${PROJECT_VERSION_MAJOR}) # DH* Hack for PGI compiler: rename objects in scheme cap object files for ISO_C compliancy, # this is only needed for dynamics builds - static build generates plain Fortran code. From 84fa078feb71f04882b392a96ce48abfa4a07cc7 Mon Sep 17 00:00:00 2001 From: "haiqin.li" Date: Mon, 25 Feb 2019 22:49:13 +0000 Subject: [PATCH 08/15] "latest GF and MYNN" --- cu_gf_deep.F90 | 4877 +++++++++++++++++++++++++++++++++++ cu_gf_driver.F90 | 836 ++++++ cu_gf_sh.F90 | 937 +++++++ module_bl_mynn.F90 | 6100 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 12750 insertions(+) create mode 100644 cu_gf_deep.F90 create mode 100644 cu_gf_driver.F90 create mode 100644 cu_gf_sh.F90 create mode 100644 module_bl_mynn.F90 diff --git a/cu_gf_deep.F90 b/cu_gf_deep.F90 new file mode 100644 index 000000000..d30b6b117 --- /dev/null +++ b/cu_gf_deep.F90 @@ -0,0 +1,4877 @@ +module cu_gf_deep + use machine , only : kind_phys + real(kind=kind_phys), parameter::g=9.81 + real(kind=kind_phys), parameter:: cp=1004. + real(kind=kind_phys), parameter:: xlv=2.5e6 + real(kind=kind_phys), parameter::r_v=461. + real(kind=kind_phys), parameter :: tcrit=258. +! tuning constant for cloudwater/ice detrainment + real(kind=kind_phys), parameter:: c1= 0.003 !.002 ! .0005 +! parameter to turn on or off evaporation of rainwater as done in sas + integer, parameter :: irainevap=0 +! max allowed fractional coverage (frh_thresh) + real(kind=kind_phys), parameter::frh_thresh = .9 +! rh threshold. if fractional coverage ~ frh_thres, do not use cupa any further + real(kind=kind_phys), parameter::rh_thresh = .97 +! tuning constant for j. brown closure (ichoice = 4,5,6) + real(kind=kind_phys), parameter::betajb=1.2 +! tuning for shallow and mid convection. ec uses 1.5 + integer, parameter:: use_excess=0 + real(kind=kind_phys), parameter :: fluxtune=1.5 +! flag to turn off or modify mom transport by downdrafts + !real(kind=kind_phys), parameter :: pgcd = 1. + real(kind=kind_phys), parameter :: pgcd = 0.1 +! +! aerosol awareness, do not user yet! +! + integer, parameter :: autoconv=1 + integer, parameter :: aeroevap=1 + real(kind=kind_phys), parameter :: ccnclean=250. +! still 16 ensembles for clousres + integer, parameter:: maxens3=16 + +!---meltglac------------------------------------------------- + logical, parameter :: melt_glac = .true. !- turn on/off ice phase/melting + real(kind=kind_phys), parameter :: & + t_0 = 273.16, & ! k + t_ice = 250.16, & ! k + xlf = 0.333e6 ! latent heat of freezing (j k-1 kg-1) +!---meltglac------------------------------------------------- +!-----srf-08aug2017-----begin + real(kind=kind_phys), parameter :: qrc_crit= 2.e-4 +!-----srf-08aug2017-----end + +contains + + subroutine cu_gf_deep_run( & + itf,ktf,its,ite, kts,kte & + + ,dicycle & ! diurnal cycle flag + ,ichoice & ! choice of closure, use "0" for ensemble average + ,ipr & ! this flag can be used for debugging prints + ,ccn & ! not well tested yet + ,dtime & + ,imid & ! flag to turn on mid level convection + + ,kpbl & ! level of boundary layer height + ,dhdt & ! boundary layer forcing (one closure for shallow) + ,xland & ! land mask + + ,zo & ! heights above surface + ,forcing & ! only diagnostic + ,t & ! t before forcing + ,q & ! q before forcing + ,z1 & ! terrain + ,tn & ! t including forcing + ,qo & ! q including forcing + ,po & ! pressure (mb) + ,psur & ! surface pressure (mb) + ,us & ! u on mass points + ,vs & ! v on mass points + ,rho & ! density + ,hfx & ! w/m2, positive upward + ,qfx & ! w/m2, positive upward + ,dx & ! dx is grid point dependent here + ,mconv & ! integrated vertical advection of moisture + ,omeg & ! omega (pa/s) + + ,csum & ! used to implement memory, set to zero if not avail + ,cnvwt & ! gfs needs this + ,zuo & ! nomalized updraft mass flux + ,zdo & ! nomalized downdraft mass flux + ,zdm & ! nomalized downdraft mass flux from mid scheme + ,edto & + ,edtm & + ,xmb_out & !the xmb's may be needed for dicycle + ,xmbm_in & + ,xmbs_in & + ,pre & + ,outu & ! momentum tendencies at mass points + ,outv & + ,outt & ! temperature tendencies + ,outq & ! q tendencies + ,outqc & ! ql/qice tendencies + ,kbcon & + ,ktop & + ,cupclw & ! used for direct coupling to radiation, but with tuning factors + ,ierr & ! ierr flags are error flags, used for debugging + ,ierrc & +! the following should be set to zero if not available + ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist + ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist + ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist + ,nranflag & ! flag to what you want perturbed + ! 1 = momentum transport + ! 2 = normalized vertical mass flux profile + ! 3 = closures + ! more is possible, talk to developer or + ! implement yourself. pattern is expected to be + ! betwee -1 and +1 +#if ( wrf_dfi_radar == 1 ) + ,do_capsuppress,cap_suppress_j & +#endif + ,k22 & + ,jmin,tropics) + + implicit none + + integer & + ,intent (in ) :: & + nranflag,itf,ktf,its,ite, kts,kte,ipr,imid + integer, intent (in ) :: & + ichoice + real(kind=kind_phys), dimension (its:ite,4) & + ,intent (in ) :: rand_clos + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: rand_mom,rand_vmas + +#if ( wrf_dfi_radar == 1 ) +! +! option of cap suppress: +! do_capsuppress = 1 do +! do_capsuppress = other don't +! +! + integer, intent(in ) ,optional :: do_capsuppress + real(kind=kind_phys), dimension( its:ite ) :: cap_suppress_j +#endif + ! + ! + ! + real(kind=kind_phys), dimension (its:ite,1:maxens3) :: xf_ens,pr_ens + ! outtem = output temp tendency (per s) + ! outq = output q tendency (per s) + ! outqc = output qc tendency (per s) + ! pre = output precip + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + cnvwt,outu,outv,outt,outq,outqc,cupclw + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + pre,xmb_out + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + hfx,qfx,xmbm_in,xmbs_in + integer, dimension (its:ite) & + ,intent (inout ) :: & + kbcon,ktop + integer, dimension (its:ite) & + ,intent (in ) :: & + kpbl,tropics + ! + ! basic environmental input includes moisture convergence (mconv) + ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off + ! convection for this call only and at that particular gridpoint + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + dhdt,rho,t,po,us,vs,tn + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + omeg + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + q,qo,zuo,zdo,zdm + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + dx,ccn,z1,psur,xland + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + mconv + + + real(kind=kind_phys) & + ,intent (in ) :: & + dtime + + +! +! local ensemble dependent variables in this routine +! + real(kind=kind_phys), dimension (its:ite,1) :: & + xaa0_ens + real(kind=kind_phys), dimension (its:ite,1) :: & + edtc + real(kind=kind_phys), dimension (its:ite,kts:kte,1) :: & + dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens +! +! +! +!***************** the following are your basic environmental +! variables. they carry a "_cup" if they are +! on model cloud levels (staggered). they carry +! an "o"-ending (z becomes zo), if they are the forced +! variables. they are preceded by x (z becomes xz) +! to indicate modification by some typ of cloud +! + ! z = heights of model levels + ! q = environmental mixing ratio + ! qes = environmental saturation mixing ratio + ! t = environmental temp + ! p = environmental pressure + ! he = environmental moist static energy + ! hes = environmental saturation moist static energy + ! z_cup = heights of model cloud levels + ! q_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! p_cup = environmental pressure + ! he_cup = moist static energy on model cloud levels + ! hes_cup = saturation moist static energy on model cloud levels + ! gamma_cup = gamma on model cloud levels +! +! + ! hcd = moist static energy in downdraft + ! zd normalized downdraft mass flux + ! dby = buoancy term + ! entr = entrainment rate + ! zd = downdraft normalized mass flux + ! entr= entrainment rate + ! hcd = h in model cloud + ! bu = buoancy term + ! zd = normalized downdraft mass flux + ! gamma_cup = gamma on model cloud levels + ! qcd = cloud q (including liquid water) after entrainment + ! qrch = saturation q in cloud + ! pwd = evaporate at that level + ! pwev = total normalized integrated evaoprate (i2) + ! entr= entrainment rate + ! z1 = terrain elevation + ! entr = downdraft entrainment rate + ! jmin = downdraft originating level + ! kdet = level above ground where downdraft start detraining + ! psur = surface pressure + ! z1 = terrain elevation + ! pr_ens = precipitation ensemble + ! xf_ens = mass flux ensembles + ! omeg = omega from large scale model + ! mconv = moisture convergence from large scale model + ! zd = downdraft normalized mass flux + ! zu = updraft normalized mass flux + ! dir = "storm motion" + ! mbdt = arbitrary numerical parameter + ! dtime = dt over which forcing is applied + ! kbcon = lfc of parcel from k22 + ! k22 = updraft originating level + ! ichoice = flag if only want one closure (usually set to zero!) + ! dby = buoancy term + ! ktop = cloud top (output) + ! xmb = total base mass flux + ! hc = cloud moist static energy + ! hkb = moist static energy at originating level + + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & + xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & + p_cup,gamma_cup,t_cup, qeso_cup,qo_cup,heo_cup,heso_cup, & + zo_cup,po_cup,gammao_cup,tn_cup, & + xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & + xt_cup, dby,hc,zu,clw_all, & + dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco, & + dbyt,xdby,xhc,xzu, & + + ! cd = detrainment function for updraft + ! cdd = detrainment function for downdraft + ! dellat = change of temperature per unit mass flux of cloud ensemble + ! dellaq = change of q per unit mass flux of cloud ensemble + ! dellaqc = change of qc per unit mass flux of cloud ensemble + + cd,cdd,dellah,dellaq,dellat,dellaqc, & + u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv + + ! aa0 cloud work function for downdraft + ! edt = epsilon + ! aa0 = cloud work function without forcing effects + ! aa1 = cloud work function with forcing effects + ! xaa0 = cloud work function with cloud effects (ensemble dependent) + ! edt = epsilon + + real(kind=kind_phys), dimension (its:ite) :: & + edt,edto,edtm,aa1,aa0,xaa0,hkb, & + hkbo,xhkb, & + xmb,pwavo, & + pwevo,bu,bud,cap_max, & + cap_max_increment,closure_n,psum,psumh,sig,sigd + real(kind=kind_phys), dimension (its:ite) :: & + axx,edtmax,edtmin,entr_rate + integer, dimension (its:ite) :: & + kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & + ktopdby,kbconx,ierr2,ierr3,kbmax + + integer, dimension (its:ite), intent(inout) :: ierr + integer, dimension (its:ite), intent(in) :: csum + integer :: & + iloop,nens3,ki,kk,i,k + real(kind=kind_phys) :: & + dz,dzo,mbdt,radius, & + zcutdown,depth_min,zkbmax,z_detr,zktop, & + dh,cap_maxs,trash,trash2,frh,sig_thresh + real(kind=kind_phys) entdo,dp,subin,detdo,entup, & + detup,subdown,entdoj,entupk,detupk,totmas + + real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec + + integer :: jprnt,jmini,start_k22 + logical :: keep_going,flg(its:ite) + + character*50 :: ierrc(its:ite) + character*4 :: cumulus + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + up_massentr,up_massdetr,c1d & + ,up_massentro,up_massdetro,dd_massentro,dd_massdetro + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + up_massentru,up_massdetru,dd_massentru,dd_massdetru + real(kind=kind_phys) c1_max,buo_flux,pgcon,pgc,blqe + + real(kind=kind_phys) :: xff_mid(its:ite,2) + integer :: iversion=1 + real(kind=kind_phys) :: denom,h_entr,umean,t_star,dq + integer, intent(in) :: dicycle + real(kind=kind_phys), dimension (its:ite) :: aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean + real(kind=kind_phys), dimension (its:ite,kts:kte) :: tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl & + ,qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl & + ,gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl + real(kind=kind_phys), dimension(its:ite) :: xf_dicycle + real(kind=kind_phys), intent(inout), dimension(its:ite,10) :: forcing + integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) + real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz + integer, dimension (its:ite,kts:kte) :: k_inv_layers + +! rainevap from sas + real(kind=kind_phys) zuh2(40) + real(kind=kind_phys), dimension (its:ite) :: rntot,delqev,delq2,qevap,rn,qcond + real(kind=kind_phys) :: rain,t1,q1,elocp,evef,el2orc,evfact,evfactl,g_rain,e_dn,c_up + real(kind=kind_phys) :: pgeoh,dts,fp,fpi,pmin,x_add,beta,beta_u + real(kind=kind_phys) :: cbeg,cmid,cend,const_a,const_b,const_c +!---meltglac------------------------------------------------- + + real(kind=kind_phys), dimension (its:ite,kts:kte) :: p_liq_ice,melting_layer,melting + +!---meltglac------------------------------------------------- + melting_layer(:,:)=0. + melting(:,:)=0. + flux_tun(:)=fluxtune +! if(imid.eq.1)flux_tun(:)=fluxtune+.5 + cumulus='deep' + if(imid.eq.1)cumulus='mid' + pmin=150. + if(imid.eq.1)pmin=75. + ktopdby(:)=0 + c1_max=c1 + elocp=xlv/cp + el2orc=xlv*xlv/(r_v*cp) + evfact=.2 + evfactl=.2 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!proportionality constant to estimate pressure gradient of updraft (zhang and wu, 2003, jas +! +! ecmwf + pgcon=0. + lambau(:)=2.0 + if(imid.eq.1)lambau(:)=2.0 +! here random must be between -1 and 1 + if(nranflag == 1)then + lambau(:)=1.5+rand_mom(:) + endif +! sas +! lambau=0. +! pgcon=-.55 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ztexec(:) = 0. + zqexec(:) = 0. + zws(:) = 0. + + do i=its,itf + !- buoyancy flux (h+le) + buo_flux= (hfx(i)/cp+0.608*t(i,1)*qfx(i)/xlv)/rho(i,1) + pgeoh = zo(i,2)*g + !-convective-scale velocity w* + zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,2)*g/t(i,1)) + if(zws(i) > tiny(pgeoh)) then + !-convective-scale velocity w* + zws(i) = 1.2*zws(i)**.3333 + !- temperature excess + ztexec(i) = max(flux_tun(i)*hfx(i)/(rho(i,1)*zws(i)*cp),0.0) + !- moisture excess + zqexec(i) = max(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.) + endif + !- zws for shallow convection closure (grant 2001) + !- height of the pbl + zws(i) = max(0.,.001-flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i))) + zws(i) = 1.2*zws(i)**.3333 + zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct + enddo +! cap_maxs=225. +! if(imid.eq.1)cap_maxs=150. + cap_maxs=75. ! 150. +! if(imid.eq.1)cap_maxs=100. + do i=its,itf + edto(i)=0. + closure_n(i)=16. + xmb_out(i)=0. + cap_max(i)=cap_maxs + cap_max_increment(i)=20. +! if(imid.eq.1)cap_max_increment(i)=10. +! +! for water or ice +! + xland1(i)=int(xland(i)+.0001) ! 1. + if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then + xland1(i)=0 +! if(imid.eq.0)cap_max(i)=cap_maxs-25. +! if(imid.eq.1)cap_max(i)=cap_maxs-50. + cap_max_increment(i)=20. + else + if(ztexec(i).gt.0.)cap_max(i)=cap_max(i)+25. + if(ztexec(i).lt.0.)cap_max(i)=cap_max(i)-25. + endif + ierrc(i)=" " +! cap_max_increment(i)=1. + enddo + if(use_excess == 0 )then + ztexec(:)=0 + zqexec(:)=0 + endif +! +!--- initial entrainment rate (these may be changed later on in the +!--- program +! + start_level(:)=kte + do i=its,ite + c1d(i,:)= 0. !c1 ! 0. ! c1 ! max(.003,c1+float(csum(i))*.0001) + entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 + if(xland1(i) == 0)entr_rate(i)=7.e-5 + if(imid.eq.1)entr_rate(i)=3.e-4 +! if(imid.eq.1)c1d(i,:)=c1 ! comment to test warm bias 08/14/17 + radius=.2/entr_rate(i) + frh=min(1.,3.14*radius*radius/dx(i)/dx(i)) + if(frh > frh_thresh)then + frh=frh_thresh + radius=sqrt(frh*dx(i)*dx(i)/3.14) + entr_rate(i)=.2/radius + endif + sig(i)=(1.-frh)**2 + enddo + sig_thresh = (1.-frh_thresh)**2 + + +! +!--- entrainment of mass +! +! +!--- initial detrainmentrates +! + do k=kts,ktf + do i=its,itf + cnvwt(i,k)=0. + zuo(i,k)=0. + zdo(i,k)=0. + z(i,k)=zo(i,k) + xz(i,k)=zo(i,k) + cupclw(i,k)=0. + cd(i,k)=.1*entr_rate(i) !1.e-9 ! 1.*entr_rate + if(imid.eq.1)cd(i,k)=.5*entr_rate(i) + cdd(i,k)=1.e-9 + hcdo(i,k)=0. + qrcdo(i,k)=0. + dellaqc(i,k)=0. + enddo + enddo +! +!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft +! base mass flux +! + edtmax(:)=1. + if(imid.eq.1)edtmax(:)=.15 + edtmin(:)=.1 + if(imid.eq.1)edtmin(:)=.05 +! +!--- minimum depth (m), clouds must have +! + depth_min=1000. + if(imid.eq.1)depth_min=500. +! +!--- maximum depth (mb) of capping +!--- inversion (larger cap = no convection) +! + do i=its,itf +! if(imid.eq.0)then +! edtmax(i)=max(0.5,.8-float(csum(i))*.015) !.3) +! if(xland1(i) == 1 )edtmax(i)=max(0.7,1.-float(csum(i))*.015) !.3) +! endif + kbmax(i)=1 + aa0(i)=0. + aa1(i)=0. + edt(i)=0. + kstabm(i)=ktf-1 + ierr2(i)=0 + ierr3(i)=0 + x_add=0. + enddo +! do i=its,itf +! cap_max(i)=cap_maxs +! cap_max3(i)=25. + +! enddo +! +!--- max height(m) above ground where updraft air can originate +! + zkbmax=4000. + if(imid.eq.1)zkbmax=2000. +! +!--- height(m) above which no downdrafts are allowed to originate +! + zcutdown=4000. +! +!--- depth(m) over which downdraft detrains all its mass +! + z_detr=500. +! if(imid.eq.1)z_detr=800. +! + +! +!--- environmental conditions, first heights +! + do i=its,itf + do k=1,maxens3 + xf_ens(i,k)=0. + pr_ens(i,k)=0. + enddo + enddo + +! +!--- calculate moist static energy, heights, qes +! + call cup_env(z,qes,he,hes,t,q,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + +! +!--- environmental values on cloud levels +! + call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, & + hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, & + heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) +!---meltglac------------------------------------------------- +!--- partition between liq/ice cloud contents + call get_partition_liq_ice(ierr,tn,po_cup,p_liq_ice,melting_layer,& + itf,ktf,its,ite,kts,kte,cumulus) +!---meltglac------------------------------------------------- + do i=its,itf + if(ierr(i).eq.0)then + if(kpbl(i).gt.5 .and. imid.eq.1)cap_max(i)=po_cup(i,kpbl(i)) + u_cup(i,kts)=us(i,kts) + v_cup(i,kts)=vs(i,kts) + do k=kts+1,ktf + u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) + v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) + enddo + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + if(zo_cup(i,k).gt.zkbmax+z1(i))then + kbmax(i)=k + go to 25 + endif + enddo + 25 continue +! +!--- level where detrainment for downdraft starts +! + do k=kts,ktf + if(zo_cup(i,k).gt.z_detr+z1(i))then + kdet(i)=k + go to 26 + endif + enddo + 26 continue +! + endif + enddo +! +! +! +!------- determine level with highest moist static energy content - k22 +! + start_k22=2 + do 36 i=its,itf + if(ierr(i).eq.0)then + k22(i)=maxloc(heo_cup(i,start_k22:kbmax(i)+2),1)+start_k22-1 + if(k22(i).ge.kbmax(i))then + ierr(i)=2 + ierrc(i)="could not find k22" + ktop(i)=0 + k22(i)=0 + kbcon(i)=0 + endif + endif + 36 continue +! +!--- determine the level of convective cloud base - kbcon +! + + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + call get_cloud_bc(kte,heo_cup (i,1:kte),hkbo (i),k22(i),x_add) + endif ! ierr + enddo + jprnt=0 + iloop=1 + if(imid.eq.1)iloop=5 + call cup_kbcon(ierrc,cap_max_increment,iloop,k22,kbcon,heo_cup,heso_cup, & + hkbo,ierr,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + jprnt,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid) +! +!--- increase detrainment in stable layers +! + call cup_minimi(heso_cup,kbcon,kstabm,kstabi,ierr, & + itf,ktf, & + its,ite, kts,kte) + do i=its,itf + if(ierr(i) == 0)then + frh = min(qo_cup(i,kbcon(i))/qeso_cup(i,kbcon(i)),1.) + if(frh >= rh_thresh .and. sig(i) <= sig_thresh )then + ierr(i)=231 + cycle + endif +! +! never go too low... +! +! if(imid.eq.0 .and. xland1(i).eq.0)x_add=150. + x_add=0. + do k=kbcon(i)+1,ktf + if(po(i,kbcon(i))-po(i,k) > pmin+x_add)then + pmin_lev(i)=k + exit + endif + enddo +! +! initial conditions for updraft +! + start_level(i)=k22(i) + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + endif + enddo +! +!--- get inversion layers for mid level cloud tops +! + if(imid.eq.1)then + call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers, & + kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) + endif + do i=its,itf + if(kstabi(i).lt.kbcon(i))then + kbcon(i)=1 + ierr(i)=42 + endif + do k=kts,ktf + entr_rate_2d(i,k)=entr_rate(i) + enddo + if(ierr(i).eq.0)then +! if(imid.eq.0 .and. pmin_lev(i).lt.kbcon(i)+3)pmin_lev(i)=kbcon(i)+3 + kbcon(i)=max(2,kbcon(i)) + do k=kts+1,ktf + frh = min(qo_cup(i,k)/qeso_cup(i,k),1.) + entr_rate_2d(i,k)=entr_rate(i) *(1.3-frh) + enddo + if(imid.eq.1)then + if(k_inv_layers(i,2).gt.0 .and. & + (po_cup(i,k22(i))-po_cup(i,k_inv_layers(i,2))).lt.500.)then + + ktop(i)=min(kstabi(i),k_inv_layers(i,2)) + ktopdby(i)=ktop(i) + else + do k=kbcon(i)+1,ktf + if((po_cup(i,k22(i))-po_cup(i,k)).gt.500.)then + ktop(i)=k + ktopdby(i)=ktop(i) + exit + endif + enddo + endif ! k_inv_lay + endif + + endif + enddo +! +!-- get normalized mass flux, entrainment and detrainmentrates for updraft +! + i=0 + !- for mid level clouds we do not allow clouds taller than where stability + !- changes + if(imid.eq.1)then + call rates_up_pdf(rand_vmas,ipr,'mid',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & + xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev) + else + call rates_up_pdf(rand_vmas,ipr,'deep',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & + xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kbcon,ktopdby,csum,pmin_lev) + endif +! +! +! + do i=its,itf + if(ierr(i).eq.0)then + + if(k22(i).gt.1)then + do k=1,k22(i) -1 + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif + do k=k22(i),ktop(i) + xzu(i,k)= zuo(i,k) + zu (i,k)= zuo(i,k) + enddo + do k=ktop(i)+1,kte + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif + enddo +! +! calculate mass entrainment and detrainment +! + if(imid.eq.1)then + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,'mid',kbcon,k22,up_massentru,up_massdetru,lambau) + else + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,'deep',kbcon,k22,up_massentru,up_massdetru,lambau) + endif + + +! +! note: ktop here already includes overshooting, ktopdby is without +! overshooting +! + do k=kts,ktf + do i=its,itf + uc (i,k)=0. + vc (i,k)=0. + hc (i,k)=0. + dby (i,k)=0. + hco (i,k)=0. + dbyo(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + do k=1,start_level(i) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + enddo + do k=1,start_level(i)-1 + hc (i,k)=he_cup(i,k) + hco(i,k)=heo_cup(i,k) + enddo + k=start_level(i) + hc (i,k)=hkb(i) + hco(i,k)=hkbo(i) + endif + enddo + +! +!---meltglac------------------------------------------------- + ! + !--- 1st guess for moist static energy and dbyo (not including ice phase) + ! + do i=its,itf + ktopkeep(i)=0 + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle + ktopkeep(i)=ktop(i) + do k=start_level(i) +1,ktop(i) !mass cons option + + denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) + if(denom.lt.1.e-8)then + ierr(i)=51 + exit + endif + hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & + up_massentro(i,k-1)*heo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + dbyo(i,k)=hco(i,k)-heso_cup(i,k) + enddo + ! for now no overshooting (only very little) + kk=maxloc(dbyt(i,:),1) + ki=maxloc(zuo(i,:),1) + do k=ktop(i)-1,kbcon(i),-1 + if(dbyo(i,k).gt.0.)then + ktopkeep(i)=k+1 + exit + endif + enddo + ktop(i)=ktopkeep(i) + if(ierr(i).eq.0)ktop(i)=ktopkeep(i) + enddo + do 37 i=its,itf + kzdown(i)=0 + if(ierr(i).eq.0)then + zktop=(zo_cup(i,ktop(i))-z1(i))*.6 + if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4 + zktop=min(zktop+z1(i),zcutdown+z1(i)) + do k=kts,ktf + if(zo_cup(i,k).gt.zktop)then + kzdown(i)=k + kzdown(i)=min(kzdown(i),kstabi(i)-1) ! + go to 37 + endif + enddo + endif + 37 continue +! +!--- downdraft originating level - jmin +! + call cup_minimi(heso_cup,k22,kzdown,jmin,ierr, & + itf,ktf, & + its,ite, kts,kte) + do 100 i=its,itf + if(ierr(i).eq.0)then +! +!-----srf-08aug2017-----begin +! if(imid .ne. 1 .and. melt_glac) jmin(i)=max(jmin(i),maxloc(melting_layer(i,:),1)) +!-----srf-08aug2017-----end + +!--- check whether it would have buoyancy, if there where +!--- no entrainment/detrainment +! + jmini = jmin(i) + keep_going = .true. + do while ( keep_going ) + keep_going = .false. + if ( jmini - 1 .lt. kdet(i) ) kdet(i) = jmini-1 + if ( jmini .ge. ktop(i)-1 ) jmini = ktop(i) - 2 + ki = jmini + hcdo(i,ki)=heso_cup(i,ki) + dz=zo_cup(i,ki+1)-zo_cup(i,ki) + dh=0. + do k=ki-1,1,-1 + hcdo(i,k)=heso_cup(i,jmini) + dz=zo_cup(i,k+1)-zo_cup(i,k) + dh=dh+dz*(hcdo(i,k)-heso_cup(i,k)) + if(dh.gt.0.)then + jmini=jmini-1 + if ( jmini .gt. 5 ) then + keep_going = .true. + else + ierr(i) = 9 + ierrc(i) = "could not find jmini9" + exit + endif + endif + enddo + enddo + jmin(i) = jmini + if ( jmini .le. 5 ) then + ierr(i)=4 + ierrc(i) = "could not find jmini4" + endif + endif +100 continue + do i=its,itf + if(ierr(i) /= 0) cycle + do k=ktop(i)+1,ktf + hco(i,k)=heso_cup(i,k) + dbyo(i,k)=0. + enddo + enddo + ! + !--- calculate moisture properties of updraft + ! + if(imid.eq.1)then + call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & + p_cup,kbcon,ktop,dbyo,clw_all,xland1, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & + zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & + 1,itf,ktf, & + its,ite, kts,kte) + else + call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & + p_cup,kbcon,ktop,dbyo,clw_all,xland1, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & + zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & + 1,itf,ktf, & + its,ite, kts,kte) + endif +! !--- get melting profile +! call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & +! ,pwo,edto,pwdo,melting & +! ,itf,ktf,its,ite, kts,kte, cumulus ) +!---meltglac------------------------------------------------- + + + do i=its,itf + + ktopkeep(i)=0 + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle + ktopkeep(i)=ktop(i) + do k=start_level(i) +1,ktop(i) !mass cons option + + denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) + if(denom.lt.1.e-8)then + ierr(i)=51 + exit + endif + + hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & + up_massentr(i,k-1)*he(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetru(i,k-1)*uc(i,k-1)+ & + up_massentru(i,k-1)*us(i,k-1) & + -pgcon*.5*(zu(i,k)+zu(i,k-1))*(u_cup(i,k)-u_cup(i,k-1))) / & + (zu(i,k-1)-.5*up_massdetru(i,k-1)+up_massentru(i,k-1)) + vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetru(i,k-1)*vc(i,k-1)+ & + up_massentru(i,k-1)*vs(i,k-1) & + -pgcon*.5*(zu(i,k)+zu(i,k-1))*(v_cup(i,k)-v_cup(i,k-1))) / & + (zu(i,k-1)-.5*up_massdetru(i,k-1)+up_massentru(i,k-1)) + dby(i,k)=hc(i,k)-hes_cup(i,k) + hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & + up_massentro(i,k-1)*heo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) +!---meltglac------------------------------------------------- + ! + !- include glaciation effects on hc,hco + ! ------ ice content -------- + hc (i,k)= hc (i,k)+(1.-p_liq_ice(i,k))*qrco(i,k)*xlf + hco(i,k)= hco(i,k)+(1.-p_liq_ice(i,k))*qrco(i,k)*xlf + + dby(i,k)=hc(i,k)-hes_cup(i,k) +!---meltglac------------------------------------------------- + dbyo(i,k)=hco(i,k)-heso_cup(i,k) + dz=zo_cup(i,k+1)-zo_cup(i,k) + dbyt(i,k)=dbyt(i,k-1)+dbyo(i,k)*dz + + enddo +! for now no overshooting (only very little) + kk=maxloc(dbyt(i,:),1) + ki=maxloc(zuo(i,:),1) +! if(ipr .eq.1)write(16,*)'cupgf2',kk,ki +! if(kk.lt.ki+3)then +! ierr(i)=423 +! endif +! + do k=ktop(i)-1,kbcon(i),-1 + if(dbyo(i,k).gt.0.)then + ktopkeep(i)=k+1 + exit + endif + enddo + ktop(i)=ktopkeep(i) + if(ierr(i).eq.0)ktop(i)=ktopkeep(i) + enddo +41 continue + do i=its,itf + if(ierr(i) /= 0) cycle + do k=ktop(i)+1,ktf + hc(i,k)=hes_cup(i,k) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + hco(i,k)=heso_cup(i,k) + dby(i,k)=0. + dbyo(i,k)=0. + zu(i,k)=0. + zuo(i,k)=0. + cd(i,k)=0. + entr_rate_2d(i,k)=0. + up_massentr(i,k)=0. + up_massdetr(i,k)=0. + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + enddo + enddo +! + do i=its,itf + if(ierr(i)/=0)cycle + if(ktop(i).lt.kbcon(i)+2)then + ierr(i)=5 + ierrc(i)='ktop too small deep' + ktop(i)=0 + endif + enddo +!! do 37 i=its,itf +! kzdown(i)=0 +! if(ierr(i).eq.0)then +! zktop=(zo_cup(i,ktop(i))-z1(i))*.6 +! if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4 +! zktop=min(zktop+z1(i),zcutdown+z1(i)) +! do k=kts,ktf +! if(zo_cup(i,k).gt.zktop)then +! kzdown(i)=k +! kzdown(i)=min(kzdown(i),kstabi(i)-1) ! +! go to 37 +! endif +! enddo +! endif +! 37 continue +!! +!!--- downdraft originating level - jmin +!! +! call cup_minimi(heso_cup,k22,kzdown,jmin,ierr, & +! itf,ktf, & +! its,ite, kts,kte) +! do 100 i=its,itf +! if(ierr(i).eq.0)then +!! +!!-----srf-08aug2017-----begin +!! if(imid .ne. 1 .and. melt_glac) jmin(i)=max(jmin(i),maxloc(melting_layer(i,:),1)) +!!-----srf-08aug2017-----end +! +!!--- check whether it would have buoyancy, if there where +!!--- no entrainment/detrainment +!! +! jmini = jmin(i) +! keep_going = .true. +! do while ( keep_going ) +! keep_going = .false. +! if ( jmini - 1 .lt. kdet(i) ) kdet(i) = jmini-1 +! if ( jmini .ge. ktop(i)-1 ) jmini = ktop(i) - 2 +! ki = jmini +! hcdo(i,ki)=heso_cup(i,ki) +! dz=zo_cup(i,ki+1)-zo_cup(i,ki) +! dh=0. +! do k=ki-1,1,-1 +! hcdo(i,k)=heso_cup(i,jmini) +! dz=zo_cup(i,k+1)-zo_cup(i,k) +! dh=dh+dz*(hcdo(i,k)-heso_cup(i,k)) +! if(dh.gt.0.)then +! jmini=jmini-1 +! if ( jmini .gt. 5 ) then +! keep_going = .true. +! else +! ierr(i) = 9 +! ierrc(i) = "could not find jmini9" +! exit +! endif +! endif +! enddo +! enddo +! jmin(i) = jmini +! if ( jmini .le. 5 ) then +! ierr(i)=4 +! ierrc(i) = "could not find jmini4" +! endif +! endif +!100 continue +!! +! - must have at least depth_min m between cloud convective base +! and cloud top. +! + do i=its,itf + if(ierr(i).eq.0)then + if ( jmin(i) - 1 .lt. kdet(i) ) kdet(i) = jmin(i)-1 + if(-zo_cup(i,kbcon(i))+zo_cup(i,ktop(i)).lt.depth_min)then + ierr(i)=6 + ierrc(i)="cloud depth very shallow" + endif + endif + enddo + +! +!--- normalized downdraft mass flux profile,also work on bottom detrainment +!--- in this routine +! + do k=kts,ktf + do i=its,itf + zdo(i,k)=0. + cdd(i,k)=0. + dd_massentro(i,k)=0. + dd_massdetro(i,k)=0. + dd_massentru(i,k)=0. + dd_massdetru(i,k)=0. + hcdo(i,k)=heso_cup(i,k) + ucd(i,k)=u_cup(i,k) + vcd(i,k)=v_cup(i,k) + dbydo(i,k)=0. + mentrd_rate_2d(i,k)=entr_rate(i) + enddo + enddo + do i=its,itf + if(ierr(i)/=0)cycle + beta=max(.025,.055-float(csum(i))*.0015) !.02 + if(imid.eq.0 .and. xland1(i) == 0)then + edtmax(i)=max(0.1,.4-float(csum(i))*.015) !.3) + endif + if(imid.eq.1)beta=.025 + bud(i)=0. + cdd(i,1:jmin(i))=.1*entr_rate(i) + cdd(i,jmin(i))=0. + dd_massdetro(i,:)=0. + dd_massentro(i,:)=0. + call get_zu_zd_pdf_fim(0,po_cup(i,:),rand_vmas(i),0.0_kind_phys,ipr,xland1(i),zuh2,"down",ierr(i),kdet(i),jmin(i)+1,zdo(i,:),kts,kte,ktf,beta,kpbl(i),csum(i),pmin_lev(i)) + if(zdo(i,jmin(i)) .lt.1.e-8)then + zdo(i,jmin(i))=0. + jmin(i)=jmin(i)-1 + cdd(i,jmin(i):ktf)=0. + zdo(i,jmin(i)+1:ktf)=0. + if(zdo(i,jmin(i)) .lt.1.e-8)then + ierr(i)=876 + cycle + endif + endif + + do ki=jmin(i) ,maxloc(zdo(i,:),1),-1 + !=> from jmin to maximum value zd -> change entrainment + dzo=zo_cup(i,ki+1)-zo_cup(i,ki) + dd_massdetro(i,ki)=cdd(i,ki)*dzo*zdo(i,ki+1) + dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1)+dd_massdetro(i,ki) + if(dd_massentro(i,ki).lt.0.)then + dd_massentro(i,ki)=0. + dd_massdetro(i,ki)=zdo(i,ki+1)-zdo(i,ki) + if(zdo(i,ki+1).gt.0.)cdd(i,ki)=dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) + endif + if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) + enddo + mentrd_rate_2d(i,1)=0. + do ki=maxloc(zdo(i,:),1)-1,1,-1 + !=> from maximum value zd to surface -> change detrainment + dzo=zo_cup(i,ki+1)-zo_cup(i,ki) + dd_massentro(i,ki)=mentrd_rate_2d(i,ki)*dzo*zdo(i,ki+1) + dd_massdetro(i,ki) = zdo(i,ki+1)+dd_massentro(i,ki)-zdo(i,ki) + if(dd_massdetro(i,ki).lt.0.)then + dd_massdetro(i,ki)=0. + dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1) + if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) + endif + if(zdo(i,ki+1).gt.0.)cdd(i,ki)= dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) + enddo +! cbeg=800. !po_cup(i,kbcon(i)) !850. +! cend=min(po_cup(i,ktop(i)),200.) +! cmid=.5*(cbeg+cend) !600. +! const_b=c1/((cmid*cmid-cbeg*cbeg)*(cbeg-cend)/(cend*cend-cbeg*cbeg)+cmid-cbeg) +! const_a=const_b*(cbeg-cend)/(cend*cend-cbeg*cbeg) +! const_c=-const_a*cbeg*cbeg-const_b*cbeg +! do k=kbcon(i)+1,ktop(i)-1 +! c1d(i,k)=const_a*po_cup(i,k)*po_cup(i,k)+const_b*po_cup(i,k)+const_c +! c1d(i,k)=max(0.,c1d(i,k)) +!! c1d(i,k)=c1 +! enddo +!! if(imid.eq.1)c1d(i,:)=0. +!! do k=1,jmin(i) +!! c1d(i,k)=0. +!! enddo +!! c1d(i,jmin(i)-2)=c1/40. +!! if(imid.eq.1)c1d(i,jmin(i)-2)=c1/20. +!! do k=jmin(i)-1,ktop(i) +!! dz=zo_cup(i,ktop(i))-zo_cup(i,jmin(i)) +!! c1d(i,k)=c1d(i,k-1)+c1*(zo_cup(i,k+1)-zo_cup(i,k))/dz +!! c1d(i,k)=max(0.,c1d(i,k)) +!! c1d(i,k)=min(.002,c1d(i,k)) +!! enddo +! +! +! downdraft moist static energy + moisture budget + do k=2,jmin(i)+1 + dd_massentru(i,k-1)=dd_massentro(i,k-1)+lambau(i)*dd_massdetro(i,k-1) + dd_massdetru(i,k-1)=dd_massdetro(i,k-1)+lambau(i)*dd_massdetro(i,k-1) + enddo + dbydo(i,jmin(i))=hcdo(i,jmin(i))-heso_cup(i,jmin(i)) + bud(i)=dbydo(i,jmin(i))*(zo_cup(i,jmin(i)+1)-zo_cup(i,jmin(i))) + ucd(i,jmin(i)+1)=.5*(uc(i,jmin(i)+1)+u_cup(i,jmin(i)+1)) + do ki=jmin(i) ,1,-1 + dzo=zo_cup(i,ki+1)-zo_cup(i,ki) + h_entr=.5*(heo(i,ki)+.5*(hco(i,ki)+hco(i,ki+1))) + ucd(i,ki)=(ucd(i,ki+1)*zdo(i,ki+1) & + -.5*dd_massdetru(i,ki)*ucd(i,ki+1)+ & + dd_massentru(i,ki)*us(i,ki) & + -pgcon*zdo(i,ki+1)*(us(i,ki+1)-us(i,ki))) / & + (zdo(i,ki+1)-.5*dd_massdetru(i,ki)+dd_massentru(i,ki)) + vcd(i,ki)=(vcd(i,ki+1)*zdo(i,ki+1) & + -.5*dd_massdetru(i,ki)*vcd(i,ki+1)+ & + dd_massentru(i,ki)*vs(i,ki) & + -pgcon*zdo(i,ki+1)*(vs(i,ki+1)-vs(i,ki))) / & + (zdo(i,ki+1)-.5*dd_massdetru(i,ki)+dd_massentru(i,ki)) + hcdo(i,ki)=(hcdo(i,ki+1)*zdo(i,ki+1) & + -.5*dd_massdetro(i,ki)*hcdo(i,ki+1)+ & + dd_massentro(i,ki)*h_entr) / & + (zdo(i,ki+1)-.5*dd_massdetro(i,ki)+dd_massentro(i,ki)) + dbydo(i,ki)=hcdo(i,ki)-heso_cup(i,ki) + bud(i)=bud(i)+dbydo(i,ki)*dzo + enddo + ! endif + + if(bud(i).gt.0)then + ierr(i)=7 + ierrc(i)='downdraft is not negatively buoyant ' + endif + enddo +! +!--- calculate moisture properties of downdraft +! + call cup_dd_moisture(ierrc,zdo,hcdo,heso_cup,qcdo,qeso_cup, & + pwdo,qo_cup,zo_cup,dd_massentro,dd_massdetro,jmin,ierr,gammao_cup, & + pwevo,bu,qrcdo,qo,heo,1, & + itf,ktf, & + its,ite, kts,kte) +! +!---meltglac------------------------------------------------- +!--- calculate moisture properties of updraft +! +! if(imid.eq.1)then +! call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & +! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & +! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & +! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & +! 1,itf,ktf, & +! its,ite, kts,kte) +! else +! call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & +! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & +! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & +! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & +! 1,itf,ktf, & +! its,ite, kts,kte) +! endif +!---meltglac------------------------------------------------- + do i=its,itf + if(ierr(i)/=0)cycle + do k=kts+1,ktop(i) + dp=100.*(po_cup(i,1)-po_cup(i,2)) + cupclw(i,k)=qrco(i,k) ! my mod + cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp + enddo + enddo +! +!--- calculate workfunctions for updrafts +! + call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) + call cup_up_aa0(aa1,zo,zuo,dbyo,gammao_cup,tn_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) + do i=its,itf + if(ierr(i)/=0)cycle + if(aa1(i).eq.0.)then + ierr(i)=17 + ierrc(i)="cloud work function zero" + endif + enddo +! +!--- diurnal cycle closure +! + !--- aa1 from boundary layer (bl) processes only + aa1_bl (:) = 0.0 + xf_dicycle (:) = 0.0 + tau_ecmwf (:) = 0. + !- way to calculate the fraction of cape consumed by shallow convection + iversion=1 ! ecmwf + !iversion=0 ! orig + ! + ! betchold et al 2008 time-scale of cape removal +! +! wmean is of no meaning over land.... +! still working on replacing it over water +! + do i=its,itf + if(ierr(i).eq.0)then + !- mean vertical velocity + wmean(i) = 3.0 ! m/s ! in the future change for wmean == integral( w dz) / cloud_depth + if(imid.eq.1)wmean(i) = 3.0 + !- time-scale cape removal from betchold et al. 2008 + tau_ecmwf(i)=( zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) ) / wmean(i) + tau_ecmwf(i)=max(tau_ecmwf(i),720.) + tau_ecmwf(i)= tau_ecmwf(i) * (1.0061 + 1.23e-2 * (dx(i)/1000.))! dx(i) must be in meters + endif + enddo + tau_bl(:) = 0. + ! + if(dicycle == 1) then + do i=its,itf + + if(ierr(i).eq.0)then + if(xland1(i) == 0 ) then + !- over water + umean= 2.0+sqrt(0.5*(us(i,1)**2+vs(i,1)**2+us(i,kbcon(i))**2+vs(i,kbcon(i))**2)) + tau_bl(i) = (zo_cup(i,kbcon(i))- z1(i)) /umean + else + !- over land + tau_bl(i) =( zo_cup(i,ktopdby(i))- zo_cup(i,kbcon(i)) ) / wmean(i) + tau_bl(i)=max(tau_bl(i),1500.) + endif + + endif + enddo + + if(iversion == 1) then + !-- version ecmwf + t_star=1. + + !-- calculate pcape from bl forcing only + call cup_up_aa1bl(aa1_bl,t,tn,q,qo,dtime, & + zo_cup,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & + kbcon,ktop,ierr, & + itf,ktf,its,ite, kts,kte) + + do i=its,itf + + if(ierr(i).eq.0)then + + !- only for convection rooting in the pbl + !if(zo_cup(i,kbcon(i))-z1(i) > zo(i,kpbl(i)+1)) then + ! aa1_bl(i) = 0.0 + !else + !- multiply aa1_bl the " time-scale" - tau_bl + ! aa1_bl(i) = max(0.,aa1_bl(i)/t_star* tau_bl(i)) + aa1_bl(i) = ( aa1_bl(i)/t_star)* tau_bl(i) + !endif + endif + enddo + + else + + !- version for real cloud-work function + + !-get the profiles modified only by bl tendencies + do i=its,itf + tn_bl(i,:)=0.;qo_bl(i,:)=0. + if ( ierr(i) == 0 )then + !below kbcon -> modify profiles + tn_bl(i,1:kbcon(i)) = tn(i,1:kbcon(i)) + qo_bl(i,1:kbcon(i)) = qo(i,1:kbcon(i)) + !above kbcon -> keep environment profiles + tn_bl(i,kbcon(i)+1:ktf) = t(i,kbcon(i)+1:ktf) + qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf) + endif + enddo + !--- calculate moist static energy, heights, qes, ... only by bl tendencies + call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, its,ite, kts,kte) + !--- environmental values on cloud levels only by bl tendencies + call cup_env_clev(tn_bl,qeso_bl,qo_bl,heo_bl,heso_bl,zo,po,qeso_cup_bl,qo_cup_bl, & + heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur, & + ierr,z1, & + itf,ktf,its,ite, kts,kte) + do i=its,itf + if(ierr(i).eq.0)then + hkbo_bl(i)=heo_cup_bl(i,k22(i)) + endif ! ierr + enddo + do k=kts,ktf + do i=its,itf + hco_bl (i,k)=0. + dbyo_bl(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + do k=1,kbcon(i)-1 + hco_bl(i,k)=hkbo_bl(i) + enddo + k=kbcon(i) + hco_bl (i,k)=hkbo_bl(i) + dbyo_bl(i,k)=hkbo_bl(i) - heso_cup_bl(i,k) + endif + enddo +! +! + do i=its,itf + if(ierr(i).eq.0)then + do k=kbcon(i)+1,ktop(i) + hco_bl(i,k)=(hco_bl(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco_bl(i,k-1)+ & + up_massentro(i,k-1)*heo_bl(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + dbyo_bl(i,k)=hco_bl(i,k)-heso_cup_bl(i,k) + enddo + do k=ktop(i)+1,ktf + hco_bl (i,k)=heso_cup_bl(i,k) + dbyo_bl(i,k)=0.0 + enddo + endif + enddo + + !--- calculate workfunctions for updrafts + call cup_up_aa0(aa1_bl,zo,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & + kbcon,ktop,ierr, & + itf,ktf,its,ite, kts,kte) + + do i=its,itf + + if(ierr(i).eq.0)then + !- get the increment on aa0 due the bl processes + aa1_bl(i) = aa1_bl(i) - aa0(i) + !- only for convection rooting in the pbl + !if(zo_cup(i,kbcon(i))-z1(i) > 500.0) then !- instead 500 -> zo_cup(kpbl(i)) + ! aa1_bl(i) = 0.0 + !else + ! !- multiply aa1_bl the "normalized time-scale" - tau_bl/ model_timestep + aa1_bl(i) = aa1_bl(i)* tau_bl(i)/ dtime + !endif + print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) + endif + enddo + endif + endif ! version of implementation + + + axx(:)=aa1(:) + +! +!--- determine downdraft strength in terms of windshear +! + call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & + pwo,ccn,pwevo,edtmax,edtmin,edtc,psum,psumh, & + rho,aeroevap,itf,ktf, & + its,ite, kts,kte) + do i=its,itf + if(ierr(i)/=0)cycle + edto(i)=edtc(i,1) + enddo + !--- get melting profile + call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & + ,pwo,edto,pwdo,melting & + ,itf,ktf,its,ite, kts,kte, cumulus ) + do k=kts,ktf + do i=its,itf + dellat_ens (i,k,1)=0. + dellaq_ens (i,k,1)=0. + dellaqc_ens(i,k,1)=0. + pwo_ens (i,k,1)=0. + enddo + enddo +! +!--- change per unit mass that a model cloud would modify the environment +! +!--- 1. in bottom layer +! + do k=kts,kte + do i=its,itf + dellu (i,k)=0. + dellv (i,k)=0. + dellah (i,k)=0. + dellat (i,k)=0. + dellaq (i,k)=0. + dellaqc(i,k)=0. + enddo + enddo +! +!---------------------------------------------- cloud level ktop +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1 +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level k+2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1 +! +!---------------------------------------------- cloud level k+1 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k +! +!---------------------------------------------- cloud level k +! +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level 3 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 2 +! +!---------------------------------------------- cloud level 2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 1 + + do i=its,itf + if(ierr(i)/=0)cycle + dp=100.*(po_cup(i,1)-po_cup(i,2)) + dellu(i,1)=pgcd*(edto(i)*zdo(i,2)*ucd(i,2) & + -edto(i)*zdo(i,2)*u_cup(i,2))*g/dp & + -zuo(i,2)*(uc (i,2)-u_cup(i,2)) *g/dp + dellv(i,1)=pgcd*(edto(i)*zdo(i,2)*vcd(i,2) & + -edto(i)*zdo(i,2)*v_cup(i,2))*g/dp & + -zuo(i,2)*(vc (i,2)-v_cup(i,2)) *g/dp + + do k=kts+1,ktop(i) + ! these three are only used at or near mass detrainment and/or entrainment levels + pgc=pgcon + entupk=0. + if(k == k22(i)-1) entupk=zuo(i,k+1) + detupk=0. + entdoj=0. + ! detrainment and entrainment for fowndrafts + detdo=edto(i)*dd_massdetro(i,k) + entdo=edto(i)*dd_massentro(i,k) + ! entrainment/detrainment for updraft + entup=up_massentro(i,k) + detup=up_massdetro(i,k) + ! subsidence by downdrafts only + subin=-zdo(i,k+1)*edto(i) + subdown=-zdo(i,k)*edto(i) + ! special levels + if(k.eq.ktop(i))then + detupk=zuo(i,ktop(i)) + subin=0. + subdown=0. + detdo=0. + entdo=0. + entup=0. + detup=0. + endif + totmas=subin-subdown+detup-entup-entdo+ & + detdo-entupk-entdoj+detupk+zuo(i,k+1)-zuo(i,k) + if(abs(totmas).gt.1.e-6)then + write(0,123)'totmas=',k22(i),kbcon(i),k,entup,detup,edto(i),zdo(i,k+1),dd_massdetro(i,k),dd_massentro(i,k) +123 format(a7,1x,3i3,2e12.4,1(1x,f5.2),3e12.4) + endif + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + pgc=pgcon + if(k.ge.ktop(i))pgc=0. + + dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) - & + zuo(i,k )*(uc (i,k )-u_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(ucd(i,k+1)-u_cup(i,k+1) ) - & + zdo(i,k )*(ucd(i,k )-u_cup(i,k ) ) )*g/dp*edto(i)*pgcd + dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) - & + zuo(i,k )*(vc (i,k )-v_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(vcd(i,k+1)-v_cup(i,k+1) ) - & + zdo(i,k )*(vcd(i,k )-v_cup(i,k ) ) )*g/dp*edto(i)*pgcd + + enddo ! k + + enddo + + + do i=its,itf + !trash = 0.0 + !trash2 = 0.0 + if(ierr(i).eq.0)then + + dp=100.*(po_cup(i,1)-po_cup(i,2)) + + dellah(i,1)=(edto(i)*zdo(i,2)*hcdo(i,2) & + -edto(i)*zdo(i,2)*heo_cup(i,2))*g/dp & + -zuo(i,2)*(hco(i,2)-heo_cup(i,2))*g/dp + + dellaq (i,1)=(edto(i)*zdo(i,2)*qcdo(i,2) & + -edto(i)*zdo(i,2)*qo_cup(i,2))*g/dp & + -zuo(i,2)*(qco(i,2)-qo_cup(i,2))*g/dp + + g_rain= 0.5*(pwo (i,1)+pwo (i,2))*g/dp + e_dn = -0.5*(pwdo(i,1)+pwdo(i,2))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 + dellaq(i,1) = dellaq(i,1)+ e_dn-g_rain + + !--- conservation check + !- water mass balance + !trash = trash + (dellaq(i,1)+dellaqc(i,1)+g_rain-e_dn)*dp/g + !- h budget + !trash2 = trash2+ (dellah(i,1))*dp/g + + + do k=kts+1,ktop(i) + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + ! these three are only used at or near mass detrainment and/or entrainment levels + + dellah(i,k) =-(zuo(i,k+1)*(hco (i,k+1)-heo_cup(i,k+1) ) - & + zuo(i,k )*(hco (i,k )-heo_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(hcdo(i,k+1)-heo_cup(i,k+1) ) - & + zdo(i,k )*(hcdo(i,k )-heo_cup(i,k ) ) )*g/dp*edto(i) + +!---meltglac------------------------------------------------- + + dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))*0.5*(qrco(i,k+1)+qrco(i,k)) & + - melting(i,k))*g/dp + +!---meltglac------------------------------------------------- + + !- check h conservation + ! trash2 = trash2+ (dellah(i,k))*dp/g + + + !-- take out cloud liquid water for detrainment + detup=up_massdetro(i,k) + dz=zo_cup(i,k)-zo_cup(i,k-1) +!! if(k.lt.ktop(i) .and. k.ge.jmin(i)) then +!! if(k.lt.ktop(i) .and. c1d(i,k).gt.0) then + if(k.lt.ktop(i)) then + dellaqc(i,k) = zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g + else + dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp + endif +!! if(imid.eq.1) dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! !--- + g_rain= 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp + e_dn = -0.5*(pwdo(i,k)+pwdo(i,k+1))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 + !-- condensation source term = detrained + flux divergence of + !-- cloud liquid water (qrco) + converted to rain + + c_up = dellaqc(i,k)+(zuo(i,k+1)* qrco(i,k+1) - & + zuo(i,k )* qrco(i,k ) )*g/dp + g_rain +! c_up = dellaqc(i,k)+ g_rain + !-- water vapor budget + !-- = flux divergence z*(q_c - q_env)_up_and_down & + !-- - condensation term + evaporation + dellaq(i,k) =-(zuo(i,k+1)*(qco (i,k+1)-qo_cup(i,k+1) ) - & + zuo(i,k )*(qco (i,k )-qo_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(qcdo(i,k+1)-qo_cup(i,k+1) ) - & + zdo(i,k )*(qcdo(i,k )-qo_cup(i,k ) ) )*g/dp*edto(i) & + - c_up + e_dn + !- check water conservation liq+condensed (including rainfall) + ! trash= trash+ (dellaq(i,k)+dellaqc(i,k)+ g_rain-e_dn)*dp/g + + enddo ! k + endif + + enddo +444 format(1x,i2,1x,7e12.4) !,1x,f7.2,2x,e13.5) +! +!--- using dellas, calculate changed environmental profiles +! + mbdt=.1 + do i=its,itf + xaa0_ens(i,1)=0. + enddo + + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + xhe(i,k)=dellah(i,k)*mbdt+heo(i,k) +! xq(i,k)=max(1.e-16,(dellaqc(i,k)+dellaq(i,k))*mbdt+qo(i,k)) + xq(i,k)=max(1.e-16,dellaq(i,k)*mbdt+qo(i,k)) + dellat(i,k)=(1./cp)*(dellah(i,k)-xlv*dellaq(i,k)) +! xt(i,k)= (dellat(i,k)-xlv/cp*dellaqc(i,k))*mbdt+tn(i,k) + xt(i,k)= dellat(i,k)*mbdt+tn(i,k) + xt(i,k)=max(190.,xt(i,k)) + enddo + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + xhe(i,ktf)=heo(i,ktf) + xq(i,ktf)=qo(i,ktf) + xt(i,ktf)=tn(i,ktf) + endif + enddo +! +!--- calculate moist static energy, heights, qes +! + call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) +! +!--- environmental values on cloud levels +! + call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, & + xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) +! +! +!**************************** static control +! +!--- moist static energy inside cloud +! + do k=kts,ktf + do i=its,itf + xhc(i,k)=0. + xdby(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,xhe_cup (i,1:kte),xhkb (i),k22(i),x_add) + do k=1,start_level(i)-1 + xhc(i,k)=xhe_cup(i,k) + enddo + k=start_level(i) + xhc(i,k)=xhkb(i) + endif !ierr + enddo +! +! + do i=its,itf + if(ierr(i).eq.0)then + do k=start_level(i) +1,ktop(i) + xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1) + & + up_massentro(i,k-1)*xhe(i,k-1)) / & + (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + + +!---meltglac------------------------------------------------- + ! + !- include glaciation effects on xhc + ! ------ ice content -------- + xhc (i,k)= xhc (i,k)+ xlf*(1.-p_liq_ice(i,k))*qrco(i,k) +!---meltglac------------------------------------------------- + + xdby(i,k)=xhc(i,k)-xhes_cup(i,k) + enddo + do k=ktop(i)+1,ktf + xhc (i,k)=xhes_cup(i,k) + xdby(i,k)=0. + enddo + endif + enddo + +! +!--- workfunctions for updraft +! + call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) + do i=its,itf + if(ierr(i).eq.0)then + xaa0_ens(i,1)=xaa0(i) + do k=kts,ktop(i) + do nens3=1,maxens3 + if(nens3.eq.7)then +!--- b=0 + pr_ens(i,nens3)=pr_ens(i,nens3) & + +pwo(i,k)+edto(i)*pwdo(i,k) +!--- b=beta + else if(nens3.eq.8)then + pr_ens(i,nens3)=pr_ens(i,nens3)+ & + pwo(i,k)+edto(i)*pwdo(i,k) +!--- b=beta/2 + else if(nens3.eq.9)then + pr_ens(i,nens3)=pr_ens(i,nens3) & + + pwo(i,k)+edto(i)*pwdo(i,k) + else + pr_ens(i,nens3)=pr_ens(i,nens3)+ & + pwo(i,k) +edto(i)*pwdo(i,k) + endif + enddo + enddo + if(pr_ens(i,7).lt.1.e-6)then + ierr(i)=18 + ierrc(i)="total normalized condensate too small" + do nens3=1,maxens3 + pr_ens(i,nens3)=0. + enddo + endif + do nens3=1,maxens3 + if(pr_ens(i,nens3).lt.1.e-5)then + pr_ens(i,nens3)=0. + endif + enddo + endif + enddo + 200 continue +! +!--- large scale forcing +! +! +!------- check wether aa0 should have been zero, assuming this +! ensemble is chosen +! +! + do i=its,itf + ierr2(i)=ierr(i) + ierr3(i)=ierr(i) + k22x(i)=k22(i) + enddo + call cup_maximi(heo_cup,2,kbmax,k22x,ierr, & + itf,ktf, & + its,ite, kts,kte) + iloop=2 + call cup_kbcon(ierrc,cap_max_increment,iloop,k22x,kbconx,heo_cup, & + heso_cup,hkbo,ierr2,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + 0,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid) + iloop=3 + call cup_kbcon(ierrc,cap_max_increment,iloop,k22x,kbconx,heo_cup, & + heso_cup,hkbo,ierr3,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + 0,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid) +! +!--- calculate cloud base mass flux +! + + do i = its,itf + mconv(i) = 0 + if(ierr(i)/=0)cycle + do k=1,ktop(i) + dq=(qo_cup(i,k+1)-qo_cup(i,k)) + mconv(i)=mconv(i)+omeg(i,k)*dq/g + enddo + enddo + call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt,dtime, & + ierr,ierr2,ierr3,xf_ens,axx,forcing, & + maxens3,mconv,rand_clos, & + po_cup,ktop,omeg,zdo,zdm,k22,zuo,pr_ens,edto,edtm,kbcon, & + ichoice, & + imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,tau_ecmwf,aa1_bl,xf_dicycle) +! + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + dellat_ens (i,k,1)=dellat(i,k) + dellaq_ens (i,k,1)=dellaq(i,k) + dellaqc_ens(i,k,1)=dellaqc(i,k) + pwo_ens (i,k,1)=pwo(i,k) +edto(i)*pwdo(i,k) + else + dellat_ens (i,k,1)=0. + dellaq_ens (i,k,1)=0. + dellaqc_ens(i,k,1)=0. + pwo_ens (i,k,1)=0. + endif + enddo + enddo + 250 continue +! +!--- feedback +! + if(imid.eq.1 .and. ichoice .le.2)then + do i=its,itf + !-boundary layer qe + xff_mid(i,1)=0. + xff_mid(i,2)=0. + if(ierr(i).eq.0)then + blqe=0. + trash=0. + if(k22(i).lt.kpbl(i)+1)then + do k=1,kpbl(i) + blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g + enddo + trash=max((hco(i,kbcon(i))-heo_cup(i,kbcon(i))),1.e1) + xff_mid(i,1)=max(0.,blqe/trash) + xff_mid(i,1)=min(0.1,xff_mid(i,1)) + endif + xff_mid(i,2)=min(0.1,.03*zws(i)) + endif + enddo + endif + call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, & + dellaqc_ens,outt, & + outq,outqc,zuo,pre,pwo_ens,xmb,ktop, & + edto,pwdo,'deep',ierr2,ierr3, & + po_cup,pr_ens,maxens3, & + sig,closure_n,xland1,xmbm_in,xmbs_in, & + ichoice,imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,xf_dicycle ) + k=1 + do i=its,itf + if(ierr(i).eq.0 .and.pre(i).gt.0.) then + pre(i)=max(pre(i),0.) + xmb_out(i)=xmb(i) + outu(i,1)=dellu(i,1)*xmb(i) + outv(i,1)=dellv(i,1)*xmb(i) + do k=kts+1,ktop(i) + outu(i,k)=.25*(dellu(i,k-1)+2.*dellu(i,k)+dellu(i,k+1))*xmb(i) + outv(i,k)=.25*(dellv(i,k-1)+2.*dellv(i,k)+dellv(i,k+1))*xmb(i) + enddo + elseif(ierr(i).ne.0 .or. pre(i).eq.0.)then + ktop(i)=0 + do k=kts,kte + outt(i,k)=0. + outq(i,k)=0. + outqc(i,k)=0. + outu(i,k)=0. + outv(i,k)=0. + enddo + endif + enddo +! rain evaporation as in sas +! + if(irainevap.eq.1)then + do i = its,itf + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + rn(i) = 0. + rntot(i) = 0. + rain=0. + if(ierr(i).eq.0)then + do k = ktop(i), 1, -1 + rain = pwo(i,k) + edto(i) * pwdo(i,k) + rntot(i) = rntot(i) + rain * xmb(i)* .001 * dtime + enddo + endif + enddo + do i = its,itf + qevap(i) = 0. + flg(i) = .true. + if(ierr(i).eq.0)then + evef = edt(i) * evfact + if(xland(i).gt.0.5 .and. xland(i).lt.1.5) evef=edt(i) * evfactl + do k = ktop(i), 1, -1 + rain = pwo(i,k) + edto(i) * pwdo(i,k) + rn(i) = rn(i) + rain * xmb(i) * .001 * dtime + !if(po(i,k).gt.700.)then + if(flg(i))then + q1=qo(i,k)+(outq(i,k))*dtime + t1=tn(i,k)+(outt(i,k))*dtime + qcond(i) = evef * (q1 - qeso(i,k)) & + & / (1. + el2orc * qeso(i,k) / t1**2) + dp = -100.*(p_cup(i,k+1)-p_cup(i,k)) + if(rn(i).gt.0. .and. qcond(i).lt.0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dtime*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i).gt.0..and.qcond(i).lt.0..and. & + & delq2(i).gt.rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i).gt.0..and.qevap(i).gt.0.) then + outq(i,k) = outq(i,k) + qevap(i)/dtime + outt(i,k) = outt(i,k) - elocp * qevap(i)/dtime + rn(i) = max(0.,rn(i) - .001 * qevap(i) * dp / g) + pre(i) = pre(i) - qevap(i) * dp /g/dtime + pre(i)=max(pre(i),0.) + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + !endif ! 700mb + endif + enddo +! pre(i)=1000.*rn(i)/dtime + endif + enddo + endif +! +! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) +! + do i=its,itf + if(ierr(i).eq.0) then + dts=0. + fpi=0. + do k=kts,ktop(i) + dp=(po_cup(i,k)-po_cup(i,k+1))*100. +!total ke dissiptaion estimate + dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g +! fpi needed for calcualtion of conversion to pot. energyintegrated + fpi = fpi +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp + enddo + if(fpi.gt.0.)then + do k=kts,ktop(i) + fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi + outt(i,k)=outt(i,k)+fp*dts*g/cp + enddo + endif + endif + enddo + + +! +!---------------------------done------------------------------ +! + + end subroutine cu_gf_deep_run + + + subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & + pw,ccn,pwev,edtmax,edtmin,edtc,psum2,psumh, & + rho,aeroevap,itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + aeroevap,itf,ktf, & + its,ite, kts,kte + ! + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + rho,us,vs,z,p,pw + real(kind=kind_phys), dimension (its:ite,1) & + ,intent (out ) :: & + edtc + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + edt + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + pwav,pwev,ccn,psum2,psumh,edtmax,edtmin + integer, dimension (its:ite) & + ,intent (in ) :: & + ktop,kbcon + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +! +! local variables in this routine +! + + integer i,k,kk + real(kind=kind_phys) einc,pef,pefb,prezk,zkbc + real(kind=kind_phys), dimension (its:ite) :: & + vshear,sdp,vws + real(kind=kind_phys) :: prop_c,pefc,aeroadd,alpha3,beta3 + prop_c=8. !10.386 + alpha3 = 1.9 + beta3 = -1.13 + pefc=0. + +! +!--- determine downdraft strength in terms of windshear +! +! */ calculate an average wind shear over the depth of the cloud +! + do i=its,itf + edt(i)=0. + vws(i)=0. + sdp(i)=0. + vshear(i)=0. + enddo + do i=its,itf + edtc(i,1)=0. + enddo + do kk = kts,ktf-1 + do 62 i=its,itf + if(ierr(i).ne.0)go to 62 + if (kk .le. min0(ktop(i),ktf) .and. kk .ge. kbcon(i)) then + vws(i) = vws(i)+ & + (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk))) & + + abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) * & + (p(i,kk) - p(i,kk+1)) + sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1) + endif + if (kk .eq. ktf-1)vshear(i) = 1.e3 * vws(i) / sdp(i) + 62 continue + end do + do i=its,itf + if(ierr(i).eq.0)then + pef=(1.591-.639*vshear(i)+.0953*(vshear(i)**2) & + -.00496*(vshear(i)**3)) + if(pef.gt.0.9)pef=0.9 + if(pef.lt.0.1)pef=0.1 +! +!--- cloud base precip efficiency +! + zkbc=z(i,kbcon(i))*3.281e-3 + prezk=.02 + if(zkbc.gt.3.)then + prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc & + *(- 1.2569798e-2+zkbc*(4.2772e-4-zkbc*5.44e-6)))) + endif + if(zkbc.gt.25)then + prezk=2.4 + endif + pefb=1./(1.+prezk) + if(pefb.gt.0.9)pefb=0.9 + if(pefb.lt.0.1)pefb=0.1 + edt(i)=1.-.5*(pefb+pef) + if(aeroevap.gt.1)then + aeroadd=(ccnclean**beta3)*((psumh(i))**(alpha3-1)) !*1.e6 +! prop_c=.9/aeroadd + prop_c=.5*(pefb+pef)/aeroadd + aeroadd=(ccn(i)**beta3)*((psum2(i))**(alpha3-1)) !*1.e6 + aeroadd=prop_c*aeroadd + pefc=aeroadd + if(pefc.gt.0.9)pefc=0.9 + if(pefc.lt.0.1)pefc=0.1 + edt(i)=1.-pefc + if(aeroevap.eq.2)edt(i)=1.-.25*(pefb+pef+2.*pefc) + endif + + +!--- edt here is 1-precipeff! + einc=.2*edt(i) + edtc(i,1)=edt(i)-einc + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + edtc(i,1)=-edtc(i,1)*pwav(i)/pwev(i) + if(edtc(i,1).gt.edtmax(i))edtc(i,1)=edtmax(i) + if(edtc(i,1).lt.edtmin(i))edtc(i,1)=edtmin(i) + endif + enddo + + end subroutine cup_dd_edt + + + subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & + pwd,q_cup,z_cup,dd_massentr,dd_massdetr,jmin,ierr, & + gamma_cup,pwev,bu,qrcd, & + q,he,iloop, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! cdd= detrainment function + ! q = environmental q on model levels + ! q_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! hes_cup = saturation h on model cloud levels + ! hcd = h in model cloud + ! bu = buoancy term + ! zd = normalized downdraft mass flux + ! gamma_cup = gamma on model cloud levels + ! mentr_rate = entrainment rate + ! qcd = cloud q (including liquid water) after entrainment + ! qrch = saturation q in cloud + ! pwd = evaporate at that level + ! pwev = total normalized integrated evaoprate (i2) + ! entr= entrainment rate + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + zd,hes_cup,hcd,qes_cup,q_cup,z_cup, & + dd_massentr,dd_massdetr,gamma_cup,q,he + integer & + ,intent (in ) :: & + iloop + integer, dimension (its:ite) & + ,intent (in ) :: & + jmin + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr + real(kind=kind_phys), dimension (its:ite,kts:kte)& + ,intent (out ) :: & + qcd,qrcd,pwd + real(kind=kind_phys), dimension (its:ite)& + ,intent (out ) :: & + pwev,bu + character*50 :: ierrc(its:ite) +! +! local variables in this routine +! + + integer :: & + i,k,ki + real(kind=kind_phys) :: & + denom,dh,dz,dqeva + + do i=its,itf + bu(i)=0. + pwev(i)=0. + enddo + do k=kts,ktf + do i=its,itf + qcd(i,k)=0. + qrcd(i,k)=0. + pwd(i,k)=0. + enddo + enddo +! +! +! + do 100 i=its,itf + if(ierr(i).eq.0)then + k=jmin(i) + dz=z_cup(i,k+1)-z_cup(i,k) + qcd(i,k)=q_cup(i,k) + dh=hcd(i,k)-hes_cup(i,k) + if(dh.lt.0)then + qrcd(i,k)=(qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & + /(1.+gamma_cup(i,k)))*dh) + else + qrcd(i,k)=qes_cup(i,k) + endif + pwd(i,jmin(i))=zd(i,jmin(i))*min(0.,qcd(i,k)-qrcd(i,k)) + qcd(i,k)=qrcd(i,k) + pwev(i)=pwev(i)+pwd(i,jmin(i)) ! *dz +! + bu(i)=dz*dh + do ki=jmin(i)-1,1,-1 + dz=z_cup(i,ki+1)-z_cup(i,ki) +! qcd(i,ki)=(qcd(i,ki+1)*(1.-.5*cdd(i,ki+1)*dz) & +! +entr*dz*q(i,ki) & +! )/(1.+entr*dz-.5*cdd(i,ki+1)*dz) +! dz=qcd(i,ki) +!print*,"i=",i," k=",ki," qcd(i,ki+1)=",qcd(i,ki+1) +!print*,"zd=",zd(i,ki+1)," dd_ma=",dd_massdetr(i,ki)," q=",q(i,ki) +!joe-added check for non-zero denominator: + denom=zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki) + if(denom.lt.1.e-16)then + ierr(i)=51 + exit + endif + qcd(i,ki)=(qcd(i,ki+1)*zd(i,ki+1) & + -.5*dd_massdetr(i,ki)*qcd(i,ki+1)+ & + dd_massentr(i,ki)*q(i,ki)) / & + (zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki)) +! +!--- to be negatively buoyant, hcd should be smaller than hes! +!--- ideally, dh should be negative till dd hits ground, but that is not always +!--- the case +! + dh=hcd(i,ki)-hes_cup(i,ki) + bu(i)=bu(i)+dz*dh + qrcd(i,ki)=qes_cup(i,ki)+(1./xlv)*(gamma_cup(i,ki) & + /(1.+gamma_cup(i,ki)))*dh + dqeva=qcd(i,ki)-qrcd(i,ki) + if(dqeva.gt.0.)then + dqeva=0. + qrcd(i,ki)=qcd(i,ki) + endif + pwd(i,ki)=zd(i,ki)*dqeva + qcd(i,ki)=qrcd(i,ki) + pwev(i)=pwev(i)+pwd(i,ki) ! *dz +! if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then +! print *,'in cup_dd_moi ', hcd(i,ki),hes_cup(i,ki),dh,dqeva +! endif + enddo +! +!--- end loop over i + if( (pwev(i).eq.0.) .and. (iloop.eq.1))then +! print *,'problem with buoy in cup_dd_moisture',i + ierr(i)=7 + ierrc(i)="problem with buoy in cup_dd_moisture" + endif + if(bu(i).ge.0.and.iloop.eq.1)then +! print *,'problem with buoy in cup_dd_moisture',i + ierr(i)=7 + ierrc(i)="problem2 with buoy in cup_dd_moisture" + endif + endif +100 continue + + end subroutine cup_dd_moisture + + subroutine cup_env(z,qes,he,hes,t,q,p,z1, & + psur,ierr,tcrit,itest, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! + ! ierr error value, maybe modified in this routine + ! q = environmental mixing ratio + ! qes = environmental saturation mixing ratio + ! t = environmental temp + ! tv = environmental virtual temp + ! p = environmental pressure + ! z = environmental heights + ! he = environmental moist static energy + ! hes = environmental saturation moist static energy + ! psur = surface pressure + ! z1 = terrain elevation + ! + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + p,t,q + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out ) :: & + he,hes,qes + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + z + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + psur,z1 + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr + integer & + ,intent (in ) :: & + itest +! +! local variables in this routine +! + + integer :: & + i,k +! real(kind=kind_phys), dimension (1:2) :: ae,be,ht + real(kind=kind_phys), dimension (its:ite,kts:kte) :: tv + real(kind=kind_phys) :: tcrit,e,tvbar +! real(kind=kind_phys), external :: satvap +! real(kind=kind_phys) :: satvap + + +! ht(1)=xlv/cp +! ht(2)=2.834e6/cp +! be(1)=.622*ht(1)/.286 +! ae(1)=be(1)/273.+alog(610.71) +! be(2)=.622*ht(2)/.286 +! ae(2)=be(2)/273.+alog(610.71) + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then +!csgb - iph is for phase, dependent on tcrit (water or ice) +! iph=1 +! if(t(i,k).le.tcrit)iph=2 +! print *, 'ae(iph),be(iph) = ',ae(iph),be(iph),ae(iph)-be(iph),t(i,k),i,k +! e=exp(ae(iph)-be(iph)/t(i,k)) +! print *, 'p, e = ', p(i,k), e +! qes(i,k)=.622*e/(100.*p(i,k)-e) + e=satvap(t(i,k)) + qes(i,k)=0.622*e/max(1.e-8,(p(i,k)-e)) + if(qes(i,k).le.1.e-16)qes(i,k)=1.e-16 + if(qes(i,k).lt.q(i,k))qes(i,k)=q(i,k) +! if(q(i,k).gt.qes(i,k))q(i,k)=qes(i,k) + tv(i,k)=t(i,k)+.608*q(i,k)*t(i,k) + endif + enddo + enddo +! +!--- z's are calculated with changed h's and q's and t's +!--- if itest=2 +! + if(itest.eq.1 .or. itest.eq.0)then + do i=its,itf + if(ierr(i).eq.0)then + z(i,1)=max(0.,z1(i))-(log(p(i,1))- & + log(psur(i)))*287.*tv(i,1)/9.81 + endif + enddo + +! --- calculate heights + do k=kts+1,ktf + do i=its,itf + if(ierr(i).eq.0)then + tvbar=.5*tv(i,k)+.5*tv(i,k-1) + z(i,k)=z(i,k-1)-(log(p(i,k))- & + log(p(i,k-1)))*287.*tvbar/9.81 + endif + enddo + enddo + else if(itest.eq.2)then + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81 + z(i,k)=max(1.e-3,z(i,k)) + endif + enddo + enddo + else if(itest.eq.-1)then + endif +! +!--- calculate moist static energy - he +! saturated moist static energy - hes +! + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + if(itest.le.0)he(i,k)=9.81*z(i,k)+1004.*t(i,k)+2.5e06*q(i,k) + hes(i,k)=9.81*z(i,k)+1004.*t(i,k)+2.5e06*qes(i,k) + if(he(i,k).ge.hes(i,k))he(i,k)=hes(i,k) + endif + enddo + enddo + + end subroutine cup_env + + + subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & + he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! + ! ierr error value, maybe modified in this routine + ! q = environmental mixing ratio + ! q_cup = environmental mixing ratio on cloud levels + ! qes = environmental saturation mixing ratio + ! qes_cup = environmental saturation mixing ratio on cloud levels + ! t = environmental temp + ! t_cup = environmental temp on cloud levels + ! p = environmental pressure + ! p_cup = environmental pressure on cloud levels + ! z = environmental heights + ! z_cup = environmental heights on cloud levels + ! he = environmental moist static energy + ! he_cup = environmental moist static energy on cloud levels + ! hes = environmental saturation moist static energy + ! hes_cup = environmental saturation moist static energy on cloud levels + ! gamma_cup = gamma on cloud levels + ! psur = surface pressure + ! z1 = terrain elevation + ! + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + qes,q,he,hes,z,p,t + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out ) :: & + qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + psur,z1 + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +! +! local variables in this routine +! + + integer :: & + i,k + + + do k=kts,ktf + do i=its,itf + qes_cup(i,k)=0. + q_cup(i,k)=0. + hes_cup(i,k)=0. + he_cup(i,k)=0. + z_cup(i,k)=0. + p_cup(i,k)=0. + t_cup(i,k)=0. + gamma_cup(i,k)=0. + enddo + enddo + do k=kts+1,ktf + do i=its,itf + if(ierr(i).eq.0)then + qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k)) + q_cup(i,k)=.5*(q(i,k-1)+q(i,k)) + hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k)) + he_cup(i,k)=.5*(he(i,k-1)+he(i,k)) + if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k) + z_cup(i,k)=.5*(z(i,k-1)+z(i,k)) + p_cup(i,k)=.5*(p(i,k-1)+p(i,k)) + t_cup(i,k)=.5*(t(i,k-1)+t(i,k)) + gamma_cup(i,k)=(xlv/cp)*(xlv/(r_v*t_cup(i,k) & + *t_cup(i,k)))*qes_cup(i,k) + endif + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + qes_cup(i,1)=qes(i,1) + q_cup(i,1)=q(i,1) +! hes_cup(i,1)=hes(i,1) +! he_cup(i,1)=he(i,1) + hes_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*qes(i,1) + he_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*q(i,1) + z_cup(i,1)=.5*(z(i,1)+z1(i)) + p_cup(i,1)=.5*(p(i,1)+psur(i)) + z_cup(i,1)=z1(i) + p_cup(i,1)=psur(i) + t_cup(i,1)=t(i,1) + gamma_cup(i,1)=xlv/cp*(xlv/(r_v*t_cup(i,1) & + *t_cup(i,1)))*qes_cup(i,1) + endif + enddo + + end subroutine cup_env_clev + + subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,& + xf_ens,axx,forcing,maxens3,mconv,rand_clos, & + p_cup,ktop,omeg,zd,zdm,k22,zu,pr_ens,edt,edtm,kbcon, & + ichoice, & + imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,tau_ecmwf,aa1_bl,xf_dicycle ) + + implicit none + + integer & + ,intent (in ) :: & + imid,ipr,itf,ktf, & + its,ite, kts,kte + integer, intent (in ) :: & + maxens3 + ! + ! ierr error value, maybe modified in this routine + ! pr_ens = precipitation ensemble + ! xf_ens = mass flux ensembles + ! massfln = downdraft mass flux ensembles used in next timestep + ! omeg = omega from large scale model + ! mconv = moisture convergence from large scale model + ! zd = downdraft normalized mass flux + ! zu = updraft normalized mass flux + ! aa0 = cloud work function without forcing effects + ! aa1 = cloud work function with forcing effects + ! xaa0 = cloud work function with cloud effects (ensemble dependent) + ! edt = epsilon + ! dir = "storm motion" + ! mbdt = arbitrary numerical parameter + ! dtime = dt over which forcing is applied + ! iact_gr_old = flag to tell where convection was active + ! kbcon = lfc of parcel from k22 + ! k22 = updraft originating level + ! ichoice = flag if only want one closure (usually set to zero!) + ! + real(kind=kind_phys), dimension (its:ite,1:maxens3) & + ,intent (inout) :: & + pr_ens + real(kind=kind_phys), dimension (its:ite,1:maxens3) & + ,intent (inout ) :: & + xf_ens + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + zd,zu,p_cup,zdm + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + omeg + real(kind=kind_phys), dimension (its:ite,1) & + ,intent (in ) :: & + xaa0 + real(kind=kind_phys), dimension (its:ite,4) & + ,intent (in ) :: & + rand_clos + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + aa1,edt,edtm + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + mconv,axx + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout) :: & + aa0,closure_n + real(kind=kind_phys) & + ,intent (in ) :: & + mbdt + real(kind=kind_phys) & + ,intent (in ) :: & + dtime + integer, dimension (its:ite) & + ,intent (inout ) :: & + k22,kbcon,ktop + integer, dimension (its:ite) & + ,intent (in ) :: & + xland + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr,ierr2,ierr3 + integer & + ,intent (in ) :: & + ichoice + integer, intent(in) :: dicycle + real(kind=kind_phys), intent(in) , dimension (its:ite) :: aa1_bl,tau_ecmwf + real(kind=kind_phys), intent(inout), dimension (its:ite) :: xf_dicycle + real(kind=kind_phys), intent(inout), dimension (its:ite,10) :: forcing + !- local var + real(kind=kind_phys) :: xff_dicycle +! +! local variables in this routine +! + + real(kind=kind_phys), dimension (1:maxens3) :: & + xff_ens3 + real(kind=kind_phys), dimension (1) :: & + xk + integer :: & + kk,i,k,n,ne +! integer, parameter :: mkxcrt=15 +! real(kind=kind_phys), dimension(1:mkxcrt) :: & +! pcrit,acrit,acritt + integer, dimension (its:ite) :: kloc + real(kind=kind_phys) :: & + a1,a_ave,xff0,xomg!,aclim1,aclim2,aclim3,aclim4 + + real(kind=kind_phys), dimension (its:ite) :: ens_adj + + + +! + ens_adj(:)=1. + xff_dicycle = 0. + +!--- large scale forcing +! + do 100 i=its,itf + kloc(i)=1 + if(ierr(i).eq.0)then +! kloc(i)=maxloc(zu(i,:),1) + kloc(i)=kbcon(i) + ens_adj(i)=1. +!ss --- comment out adjustment over ocean +!ss if(ierr2(i).gt.0.and.ierr3(i).eq.0)ens_adj(i)=0.666 ! 2./3. +!ss if(ierr2(i).gt.0.and.ierr3(i).gt.0)ens_adj(i)=0.333 +! + a_ave=0. + a_ave=axx(i) + a_ave=max(0.,a_ave) + a_ave=min(a_ave,aa1(i)) + a_ave=max(0.,a_ave) + xff_ens3(:)=0. + xff0= (aa1(i)-aa0(i))/dtime + xff_ens3(1)=max(0.,(aa1(i)-aa0(i))/dtime) + xff_ens3(2)=max(0.,(aa1(i)-aa0(i))/dtime) + xff_ens3(3)=max(0.,(aa1(i)-aa0(i))/dtime) + xff_ens3(16)=max(0.,(aa1(i)-aa0(i))/dtime) + forcing(i,1)=xff_ens3(2) +! +!--- omeg is in bar/s, mconv done with omeg in pa/s +! more like brown (1979), or frank-cohen (199?) +! +! average aaround kbcon +! + xomg=0. + kk=0 + xff_ens3(4)=0. + xff_ens3(5)=0. + xff_ens3(6)=0. + do k=kbcon(i)-1,kbcon(i)+1 + if(zu(i,k).gt.0.)then + xomg=xomg-omeg(i,k)/9.81/max(0.3,(1.-(edt(i)*zd(i,k)-edtm(i)*zdm(i,k))/zu(i,k))) + kk=kk+1 + endif + enddo + if(kk.gt.0)xff_ens3(4)=xomg/float(kk) + +! +! max below kbcon +! xff_ens3(6)=-omeg(i,k22(i))/9.81 +! do k=k22(i),kbcon(i) +! xomg=-omeg(i,k)/9.81 +! if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg +! enddo +! +! if(zu(i,kbcon(i)) > 0)xff_ens3(6)=betajb*xff_ens3(6)/zu(i,kbcon(i)) + xff_ens3(4)=betajb*xff_ens3(4) + xff_ens3(5)=xff_ens3(4) + xff_ens3(6)=xff_ens3(4) + if(xff_ens3(4).lt.0.)xff_ens3(4)=0. + if(xff_ens3(5).lt.0.)xff_ens3(5)=0. + if(xff_ens3(6).lt.0.)xff_ens3(6)=0. + xff_ens3(14)=xff_ens3(4) + forcing(i,2)=xff_ens3(4) +! +!--- more like krishnamurti et al.; pick max and average values +! + xff_ens3(7)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + xff_ens3(8)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + xff_ens3(9)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + xff_ens3(15)=mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + forcing(i,3)=xff_ens3(8) +! +!--- more like fritsch chappel or kain fritsch (plus triggers) +! + xff_ens3(10)=aa1(i)/tau_ecmwf(i) + xff_ens3(11)=aa1(i)/tau_ecmwf(i) + xff_ens3(12)=aa1(i)/tau_ecmwf(i) + xff_ens3(13)=(aa1(i))/tau_ecmwf(i) !(60.*15.) !tau_ecmwf(i) +! forcing(i,4)=xff_ens3(10) + +!!- more like bechtold et al. (jas 2014) +!! if(dicycle == 1) xff_dicycle = max(0.,aa1_bl(i)/tau_ecmwf(i)) !(60.*30.) !tau_ecmwf(i) +!gtest + if(ichoice.eq.0)then + if(xff0.lt.0.)then + xff_ens3(1)=0. + xff_ens3(2)=0. + xff_ens3(3)=0. + xff_ens3(10)=0. + xff_ens3(11)=0. + xff_ens3(12)=0. + xff_ens3(13)= 0. + xff_ens3(16)= 0. +! closure_n(i)=12. +! hli 05/01/2018 closure_n(i)=12. +! xff_dicycle = 0. + endif !xff0 + endif ! ichoice + + xk(1)=(xaa0(i,1)-aa1(i))/mbdt + forcing(i,4)=aa0(i) + forcing(i,5)=aa1(i) + forcing(i,6)=xaa0(i,1) + forcing(i,7)=xk(1) + if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) & + xk(1)=-.01*mbdt + if(xk(1).gt.0.and.xk(1).lt.1.e-2) & + xk(1)=1.e-2 + ! enddo +! +!--- add up all ensembles +! +! +! over water, enfor!e small cap for some of the closures +! + if(xland(i).lt.0.1)then + if(ierr2(i).gt.0.or.ierr3(i).gt.0)then + xff_ens3(1) =ens_adj(i)*xff_ens3(1) + xff_ens3(2) =ens_adj(i)*xff_ens3(2) + xff_ens3(3) =ens_adj(i)*xff_ens3(3) + xff_ens3(4) =ens_adj(i)*xff_ens3(4) + xff_ens3(5) =ens_adj(i)*xff_ens3(5) + xff_ens3(6) =ens_adj(i)*xff_ens3(6) + xff_ens3(7) =ens_adj(i)*xff_ens3(7) + xff_ens3(8) =ens_adj(i)*xff_ens3(8) + xff_ens3(9) =ens_adj(i)*xff_ens3(9) + xff_ens3(10) =ens_adj(i)*xff_ens3(10) + xff_ens3(11) =ens_adj(i)*xff_ens3(11) + xff_ens3(12) =ens_adj(i)*xff_ens3(12) + xff_ens3(13) =ens_adj(i)*xff_ens3(13) + xff_ens3(14) =ens_adj(i)*xff_ens3(14) + xff_ens3(15) =ens_adj(i)*xff_ens3(15) + xff_ens3(16) =ens_adj(i)*xff_ens3(16) +!! !srf +!! xff_dicycle = ens_adj(i)*xff_dicycle +!! !srf end +! xff_ens3(7) =0. +! xff_ens3(8) =0. +! xff_ens3(9) =0. + endif ! ierr2 + endif ! xland +! +! end water treatment +! +! + +! +!--- special treatment for stability closures +! + if(xk(1).lt.0.)then + if(xff_ens3(1).gt.0)xf_ens(i,1)=max(0.,-xff_ens3(1)/xk(1)) + if(xff_ens3(2).gt.0)xf_ens(i,2)=max(0.,-xff_ens3(2)/xk(1)) + if(xff_ens3(3).gt.0)xf_ens(i,3)=max(0.,-xff_ens3(3)/xk(1)) + if(xff_ens3(16).gt.0)xf_ens(i,16)=max(0.,-xff_ens3(16)/xk(1)) + xf_ens(i,1)= xf_ens(i,1)+xf_ens(i,1)*rand_clos(i,1) + xf_ens(i,2)= xf_ens(i,2)+xf_ens(i,2)*rand_clos(i,1) + xf_ens(i,3)= xf_ens(i,3)+xf_ens(i,3)*rand_clos(i,1) + xf_ens(i,16)=xf_ens(i,16)+xf_ens(i,16)*rand_clos(i,1) + else + xff_ens3(1)= 0 + xff_ens3(2)= 0 + xff_ens3(3)= 0 + xff_ens3(16)=0 + endif +! +!--- if iresult.eq.1, following independent of xff0 +! + xf_ens(i,4)=max(0.,xff_ens3(4)) + xf_ens(i,5)=max(0.,xff_ens3(5)) + xf_ens(i,6)=max(0.,xff_ens3(6)) + xf_ens(i,14)=max(0.,xff_ens3(14)) + a1=max(1.e-5,pr_ens(i,7)) + xf_ens(i,7)=max(0.,xff_ens3(7)/a1) + a1=max(1.e-5,pr_ens(i,8)) + xf_ens(i,8)=max(0.,xff_ens3(8)/a1) +! forcing(i,7)=xf_ens(i,8) + a1=max(1.e-5,pr_ens(i,9)) + xf_ens(i,9)=max(0.,xff_ens3(9)/a1) + a1=max(1.e-3,pr_ens(i,15)) + xf_ens(i,15)=max(0.,xff_ens3(15)/a1) + xf_ens(i,4)=xf_ens(i,4)+xf_ens(i,4)*rand_clos(i,2) + xf_ens(i,5)=xf_ens(i,5)+xf_ens(i,5)*rand_clos(i,2) + xf_ens(i,6)=xf_ens(i,6)+xf_ens(i,6)*rand_clos(i,2) + xf_ens(i,14)=xf_ens(i,14)+xf_ens(i,14)*rand_clos(i,2) + xf_ens(i,7)=xf_ens(i,7)+xf_ens(i,7)*rand_clos(i,3) + xf_ens(i,8)=xf_ens(i,8)+xf_ens(i,8)*rand_clos(i,3) + xf_ens(i,9)=xf_ens(i,9)+xf_ens(i,9)*rand_clos(i,3) + xf_ens(i,15)=xf_ens(i,15)+xf_ens(i,15)*rand_clos(i,3) + if(xk(1).lt.0.)then + xf_ens(i,10)=max(0.,-xff_ens3(10)/xk(1)) + xf_ens(i,11)=max(0.,-xff_ens3(11)/xk(1)) + xf_ens(i,12)=max(0.,-xff_ens3(12)/xk(1)) + xf_ens(i,13)=max(0.,-xff_ens3(13)/xk(1)) + xf_ens(i,10)=xf_ens(i,10)+xf_ens(i,10)*rand_clos(i,4) + xf_ens(i,11)=xf_ens(i,11)+xf_ens(i,11)*rand_clos(i,4) + xf_ens(i,12)=xf_ens(i,12)+xf_ens(i,12)*rand_clos(i,4) + xf_ens(i,13)=xf_ens(i,13)+xf_ens(i,13)*rand_clos(i,4) + forcing(i,8)=xf_ens(i,11) + else + xf_ens(i,10)=0. + xf_ens(i,11)=0. + xf_ens(i,12)=0. + xf_ens(i,13)=0. + forcing(i,8)=0. + endif +!srf-begin +!! if(xk(1).lt.0.)then +!! xf_dicycle(i) = max(0.,-xff_dicycle /xk(1)) +!! forcing(i,9)=xf_dicycle(i) +!! else +!! xf_dicycle(i) = 0. +!! endif +!srf-end +!- +!- diurnal cycle mass flux +!- + if(dicycle == 1 )then + do i=its,itf + xf_dicycle(i) = 0. + if(ierr(i) /= 0)cycle + xk(1)=(xaa0(i,1)-aa1(i))/mbdt + if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) xk(1)=-.01*mbdt + if(xk(1).gt.0.and.xk(1).lt.1.e-2) xk(1)=1.e-2 + + xff_dicycle = (aa1(i)-aa1_bl(i))/tau_ecmwf(i) + if(xk(1).lt.0) xf_dicycle(i)= max(0.,-xff_dicycle/xk(1)) + xf_dicycle(i)= xf_ens(i,10)-xf_dicycle(i) + enddo + else + xf_dicycle(:) = 0. + endif +!--------- + if(ichoice.ge.1)then +! closure_n(i)=0. + xf_ens(i,1)=xf_ens(i,ichoice) + xf_ens(i,2)=xf_ens(i,ichoice) + xf_ens(i,3)=xf_ens(i,ichoice) + xf_ens(i,4)=xf_ens(i,ichoice) + xf_ens(i,5)=xf_ens(i,ichoice) + xf_ens(i,6)=xf_ens(i,ichoice) + xf_ens(i,7)=xf_ens(i,ichoice) + xf_ens(i,8)=xf_ens(i,ichoice) + xf_ens(i,9)=xf_ens(i,ichoice) + xf_ens(i,10)=xf_ens(i,ichoice) + xf_ens(i,11)=xf_ens(i,ichoice) + xf_ens(i,12)=xf_ens(i,ichoice) + xf_ens(i,13)=xf_ens(i,ichoice) + xf_ens(i,14)=xf_ens(i,ichoice) + xf_ens(i,15)=xf_ens(i,ichoice) + xf_ens(i,16)=xf_ens(i,ichoice) + endif + elseif(ierr(i).ne.20.and.ierr(i).ne.0)then + do n=1,maxens3 + xf_ens(i,n)=0. +!! +!! xf_dicycle(i) = 0. +!! + enddo + endif ! ierror + 100 continue + + end subroutine cup_forcing_ens_3d + + subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & + hkb,ierr,kbmax,p_cup,cap_max, & + ztexec,zqexec, & + jprnt,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid ) + + implicit none +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + jprnt,itf,ktf,imid, & + its,ite, kts,kte + ! + ! + ! + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + he_cup,hes_cup,p_cup + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + entr_rate,ztexec,zqexec,cap_inc,cap_max + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + hkb !,cap_max + integer, dimension (its:ite) & + ,intent (in ) :: & + kbmax + integer, dimension (its:ite) & + ,intent (inout) :: & + kbcon,k22,ierr + integer & + ,intent (in ) :: & + iloop_in + character*50 :: ierrc(its:ite) + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: z_cup,heo + integer, dimension (its:ite) :: iloop,start_level +! +! local variables in this routine +! + + integer :: & + i,k + real(kind=kind_phys) :: & + x_add,pbcdif,plus,hetest,dz + real(kind=kind_phys), dimension (its:ite,kts:kte) ::hcot +! +!--- determine the level of convective cloud base - kbcon +! + iloop(:)=iloop_in + do 27 i=its,itf + kbcon(i)=1 +! +! reset iloop for mid level convection + if(cap_max(i).gt.200 .and. imid.eq.1)iloop(i)=5 +! + if(ierr(i).ne.0)go to 27 + start_level(i)=k22(i) + kbcon(i)=k22(i)+1 + if(iloop(i).eq.5)kbcon(i)=k22(i) +! if(iloop_in.eq.5)start_level(i)=kbcon(i) + !== including entrainment for hetest + hcot(i,1:start_level(i)) = hkb(i) + do k=start_level(i)+1,kbmax(i)+3 + dz=z_cup(i,k)-z_cup(i,k-1) + hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1) & + + entr_rate(i)*dz*heo(i,k-1) )/ & + (1.+0.5*entr_rate(i)*dz) + enddo + !== + + go to 32 + 31 continue + kbcon(i)=kbcon(i)+1 + if(kbcon(i).gt.kbmax(i)+2)then + if(iloop(i).ne.4)then + ierr(i)=3 + ierrc(i)="could not find reasonable kbcon in cup_kbcon" + endif + go to 27 + endif + 32 continue + hetest=hcot(i,kbcon(i)) !hkb(i) ! he_cup(i,k22(i)) + if(hetest.lt.hes_cup(i,kbcon(i)))then + go to 31 + endif + +! cloud base pressure and max moist static energy pressure +! i.e., the depth (in mb) of the layer of negative buoyancy + if(kbcon(i)-k22(i).eq.1)go to 27 + if(iloop(i).eq.5 .and. (kbcon(i)-k22(i)).le.2)go to 27 + pbcdif=-p_cup(i,kbcon(i))+p_cup(i,k22(i)) + plus=max(25.,cap_max(i)-float(iloop(i)-1)*cap_inc(i)) + if(iloop(i).eq.4)plus=cap_max(i) +! +! for shallow convection, if cap_max is greater than 25, it is the pressure at pbltop + if(iloop(i).eq.5)plus=150. + if(iloop(i).eq.5.and.cap_max(i).gt.200)pbcdif=-p_cup(i,kbcon(i))+cap_max(i) + if(pbcdif.le.plus)then + go to 27 + elseif(pbcdif.gt.plus)then + k22(i)=k22(i)+1 + kbcon(i)=k22(i)+1 +!== since k22 has be changed, hkb has to be re-calculated + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + + start_level(i)=k22(i) +! if(iloop_in.eq.5)start_level(i)=kbcon(i) + hcot(i,1:start_level(i)) = hkb(i) + do k=start_level(i)+1,kbmax(i)+3 + dz=z_cup(i,k)-z_cup(i,k-1) + + hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1) & + + entr_rate(i)*dz*heo(i,k-1) )/ & + (1.+0.5*entr_rate(i)*dz) + enddo + !== + + if(iloop(i).eq.5)kbcon(i)=k22(i) + if(kbcon(i).gt.kbmax(i)+2)then + if(iloop(i).ne.4)then + ierr(i)=3 + ierrc(i)="could not find reasonable kbcon in cup_kbcon" + endif + go to 27 + endif + go to 32 + endif + 27 continue + + end subroutine cup_kbcon + + + subroutine cup_maximi(array,ks,ke,maxx,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! array input array + ! x output array with return values + ! kt output array of levels + ! ks,kend check-range + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + array + integer, dimension (its:ite) & + ,intent (in ) :: & + ierr,ke + integer & + ,intent (in ) :: & + ks + integer, dimension (its:ite) & + ,intent (out ) :: & + maxx + real(kind=kind_phys), dimension (its:ite) :: & + x + real(kind=kind_phys) :: & + xar + integer :: & + i,k + + do 200 i=its,itf + maxx(i)=ks + if(ierr(i).eq.0)then + x(i)=array(i,ks) +! + do 100 k=ks,ke(i) + xar=array(i,k) + if(xar.ge.x(i)) then + x(i)=xar + maxx(i)=k + endif + 100 continue + endif + 200 continue + + end subroutine cup_maximi + + + subroutine cup_minimi(array,ks,kend,kt,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! array input array + ! x output array with return values + ! kt output array of levels + ! ks,kend check-range + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + array + integer, dimension (its:ite) & + ,intent (in ) :: & + ierr,ks,kend + integer, dimension (its:ite) & + ,intent (out ) :: & + kt + real(kind=kind_phys), dimension (its:ite) :: & + x + integer :: & + i,k,kstop + + do 200 i=its,itf + kt(i)=ks(i) + if(ierr(i).eq.0)then + x(i)=array(i,ks(i)) + kstop=max(ks(i)+1,kend(i)) +! + do 100 k=ks(i)+1,kstop + if(array(i,k).lt.x(i)) then + x(i)=array(i,k) + kt(i)=k + endif + 100 continue + endif + 200 continue + + end subroutine cup_minimi + + + subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! aa0 cloud work function + ! gamma_cup = gamma on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! dby = buoancy term + ! zu= normalized updraft mass flux + ! z = heights of model levels + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + z,zu,gamma_cup,t_cup,dby + integer, dimension (its:ite) & + ,intent (in ) :: & + kbcon,ktop +! +! input and output +! + + + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + aa0 +! +! local variables in this routine +! + + integer :: & + i,k + real(kind=kind_phys) :: & + dz,da +! + do i=its,itf + aa0(i)=0. + enddo + do 100 k=kts+1,ktf + do 100 i=its,itf + if(ierr(i).ne.0)go to 100 + if(k.lt.kbcon(i))go to 100 + if(k.gt.ktop(i))go to 100 + dz=z(i,k)-z(i,k-1) + da=zu(i,k)*dz*(9.81/(1004.*( & + (t_cup(i,k)))))*dby(i,k-1)/ & + (1.+gamma_cup(i,k)) +! if(k.eq.ktop(i).and.da.le.0.)go to 100 + aa0(i)=aa0(i)+max(0.,da) + if(aa0(i).lt.0.)aa0(i)=0. +100 continue + + end subroutine cup_up_aa0 + +!==================================================================== + subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & + outqc,pret,its,ite,kts,kte,itf,ktf,ktop) + + integer, intent(in ) :: j,its,ite,kts,kte,itf,ktf + integer, dimension (its:ite ), intent(in ) :: ktop + + real(kind=kind_phys), dimension (its:ite,kts:kte ) , & + intent(inout ) :: & + outq,outt,outqc,outu,outv + real(kind=kind_phys), dimension (its:ite,kts:kte ) , & + intent(inout ) :: & + q + real(kind=kind_phys), dimension (its:ite ) , & + intent(inout ) :: & + pret + character *(*), intent (in) :: & + name + real(kind=kind_phys) & + ,intent (in ) :: & + dt + real(kind=kind_phys) :: names,scalef,thresh,qmem,qmemf,qmem2,qtest,qmem1 + integer :: icheck +! +! first do check on vertical heating rate +! + thresh=300.01 +! thresh=200.01 !ss +! thresh=250.01 + names=1. + if(name == 'shallow' .or. name == 'mid')then + thresh=148.01 + names=1. + endif + scalef=86400. + do i=its,itf + if(ktop(i) <= 2)cycle + icheck=0 + qmemf=1. + qmem=0. + do k=kts,ktop(i) + qmem=(outt(i,k))*86400. + if(qmem.gt.thresh)then + qmem2=thresh/qmem + qmemf=min(qmemf,qmem2) + icheck=1 +! +! +! print *,'1',' adjusted massflux by factor ',i,j,k,qmem,qmem2,qmemf,dt + endif + if(qmem.lt.-.5*thresh*names)then + qmem2=-.5*names*thresh/qmem + qmemf=min(qmemf,qmem2) + icheck=2 +! +! + endif + enddo + do k=kts,ktop(i) + outq(i,k)=outq(i,k)*qmemf + outt(i,k)=outt(i,k)*qmemf + outu(i,k)=outu(i,k)*qmemf + outv(i,k)=outv(i,k)*qmemf + outqc(i,k)=outqc(i,k)*qmemf + enddo + pret(i)=pret(i)*qmemf + enddo +! return +! +! check whether routine produces negative q's. this can happen, since +! tendencies are calculated based on forced q's. this should have no +! influence on conservation properties, it scales linear through all +! tendencies +! +! return +! write(14,*)'return' + thresh=1.e-32 + do i=its,itf + if(ktop(i) <= 2)cycle + qmemf=1. + do k=kts,ktop(i) + qmem=outq(i,k) + if(abs(qmem).gt.0. .and. q(i,k).gt.1.e-6)then + qtest=q(i,k)+(outq(i,k))*dt + if(qtest.lt.thresh)then +! +! qmem2 would be the maximum allowable tendency +! + qmem1=abs(outq(i,k)) + qmem2=abs((thresh-q(i,k))/dt) + qmemf=min(qmemf,qmem2/qmem1) + qmemf=max(0.,qmemf) + endif + endif + enddo + do k=kts,ktop(i) + outq(i,k)=outq(i,k)*qmemf + outt(i,k)=outt(i,k)*qmemf + outu(i,k)=outu(i,k)*qmemf + outv(i,k)=outv(i,k)*qmemf + outqc(i,k)=outqc(i,k)*qmemf + enddo + pret(i)=pret(i)*qmemf + enddo + + end subroutine neg_check + + + subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & + outtem,outq,outqc, & + zu,pre,pw,xmb,ktop, & + edt,pwd,name,ierr2,ierr3,p_cup,pr_ens, & + maxens3, & + sig,closure_n,xland1,xmbm_in,xmbs_in, & + ichoice,imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,xf_dicycle ) + + implicit none +! +! on input +! + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + ichoice,imid,ipr,itf,ktf, & + its,ite, kts,kte + integer, intent (in ) :: & + maxens3 + ! xf_ens = ensemble mass fluxes + ! pr_ens = precipitation ensembles + ! dellat = change of temperature per unit mass flux of cloud ensemble + ! dellaq = change of q per unit mass flux of cloud ensemble + ! dellaqc = change of qc per unit mass flux of cloud ensemble + ! outtem = output temp tendency (per s) + ! outq = output q tendency (per s) + ! outqc = output qc tendency (per s) + ! pre = output precip + ! xmb = total base mass flux + ! xfac1 = correction factor + ! pw = pw -epsilon*pd (ensemble dependent) + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,1:maxens3) & + ,intent (inout) :: & + xf_ens,pr_ens + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + outtem,outq,outqc + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + zu,pwd,p_cup + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + sig,xmbm_in,xmbs_in,edt + real(kind=kind_phys), dimension (its:ite,2) & + ,intent (in ) :: & + xff_mid + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + pre,xmb + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + closure_n + real(kind=kind_phys), dimension (its:ite,kts:kte,1) & + ,intent (in ) :: & + dellat,dellaqc,dellaq,pw + integer, dimension (its:ite) & + ,intent (in ) :: & + ktop,xland1 + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr,ierr2,ierr3 + integer, intent(in) :: dicycle + real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle +! +! local variables in this routine +! + + integer :: & + i,k,n + real(kind=kind_phys) :: & + clos_wei,dtt,dp,dtq,dtqc,dtpw,dtpwd + real(kind=kind_phys), dimension (its:ite) :: & + pre2,xmb_ave,pwtot +! + character *(*), intent (in) :: & + name + +! + do k=kts,kte + do i=its,ite + outtem (i,k)=0. + outq (i,k)=0. + outqc (i,k)=0. + enddo + enddo + do i=its,itf + pre(i)=0. + xmb(i)=0. + enddo + do i=its,itf + if(ierr(i).eq.0)then + do n=1,maxens3 + if(pr_ens(i,n).le.0.)then + xf_ens(i,n)=0. + endif + enddo + endif + enddo +! +!--- calculate ensemble average mass fluxes +! + +! +!-- now do feedback +! +!!!!! deep convection !!!!!!!!!! + if(imid.eq.0)then + do i=its,itf + if(ierr(i).eq.0)then + k=0 + xmb_ave(i)=0. + do n=1,maxens3 + k=k+1 + xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) + + enddo + !print *,'xf_ens',xf_ens + xmb_ave(i)=xmb_ave(i)/float(k) + !print *,'k,xmb_ave',k,xmb_ave + !srf begin + if(dicycle == 2 )then + xmb_ave(i)=xmb_ave(i)-max(0.,xmbs_in(i)) + xmb_ave(i)=max(0.,xmb_ave(i)) + else if (dicycle == 1) then +! xmb_ave(i)=min(xmb_ave(i),xmb_ave(i) - xf_dicycle(i)) + xmb_ave(i)=xmb_ave(i) - xf_dicycle(i) + xmb_ave(i)=max(0.,xmb_ave(i)) + endif + !print *,"2 xmb_ave,xf_dicycle",xmb_ave,xf_dicycle +! --- now use proper count of how many closures were actually +! used in cup_forcing_ens (including screening of some +! closures over water) to properly normalize xmb + clos_wei=16./max(1.,closure_n(i)) + xmb_ave(i)=min(xmb_ave(i),100.) + xmb(i)=clos_wei*sig(i)*xmb_ave(i) + + if(xmb(i) < 1.e-16)then + ierr(i)=19 + endif +! xfac1(i)=xmb(i) +! xfac2(i)=xmb(i) + + endif + enddo +!!!!! not so deep convection !!!!!!!!!! + else ! imid == 1 + do i=its,itf + xmb_ave(i)=0. + if(ierr(i).eq.0)then +! ! first get xmb_ves, depend on ichoicee +! + if(ichoice.eq.1 .or. ichoice.eq.2)then + xmb_ave(i)=sig(i)*xff_mid(i,ichoice) + else if(ichoice.gt.2)then + k=0 + do n=1,maxens3 + k=k+1 + xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) + enddo + xmb_ave(i)=xmb_ave(i)/float(k) + else if(ichoice == 0)then + xmb_ave(i)=.5*sig(i)*(xff_mid(i,1)+xff_mid(i,2)) + endif ! ichoice gt.2 +! which dicycle method + if(dicycle == 2 )then + xmb(i)=max(0.,xmb_ave(i)-xmbs_in(i)) + else if (dicycle == 1) then +! xmb(i)=min(xmb_ave(i),xmb_ave(i) - xf_dicycle(i)) + xmb(i)=xmb_ave(i) - xf_dicycle(i) + xmb(i)=max(0.,xmb_ave(i)) + else if (dicycle == 0) then + xmb(i)=max(0.,xmb_ave(i)) + endif ! dicycle=1,2 + endif ! ierr >0 + enddo ! i + endif ! imid=1 + + do i=its,itf + if(ierr(i).eq.0)then + dtpw=0. + do k=kts,ktop(i) + dtpw=dtpw+pw(i,k,1) + outtem(i,k)= xmb(i)* dellat (i,k,1) + outq (i,k)= xmb(i)* dellaq (i,k,1) + outqc (i,k)= xmb(i)* dellaqc(i,k,1) + enddo + PRE(I)=PRE(I)+XMB(I)*dtpw + endif + enddo + return + + do i=its,itf + pwtot(i)=0. + pre2(i)=0. + if(ierr(i).eq.0)then + do k=kts,ktop(i) + pwtot(i)=pwtot(i)+pw(i,k,1) + enddo + do k=kts,ktop(i) + dp=100.*(p_cup(i,k)-p_cup(i,k+1))/g + dtt =dellat (i,k,1) + dtq =dellaq (i,k,1) +! necessary to drive downdraft + dtpwd=-pwd(i,k)*edt(i) +! take from dellaqc first + dtqc=dellaqc (i,k,1)*dp - dtpwd +! if this is negative, use dellaqc first, rest needs to come from rain + if(dtqc < 0.)then + dtpwd=dtpwd-dellaqc(i,k,1)*dp + dtqc=0. +! if this is positive, can come from clw detrainment + else + dtqc=dtqc/dp + dtpwd=0. + endif + outtem(i,k)= xmb(i)* dtt + outq (i,k)= xmb(i)* dtq + outqc (i,k)= xmb(i)* dtqc + xf_ens(i,:)=sig(i)*xf_ens(i,:) +! what is evaporated + pre(i)=pre(i)-xmb(i)*dtpwd + pre2(i)=pre2(i)+xmb(i)*(pw(i,k,1)+edt(i)*pwd(i,k)) +! write(15,124)k,dellaqc(i,k,1),dtqc,-pwd(i,k)*edt(i),dtpwd + enddo + pre(i)=-pre(i)+xmb(i)*pwtot(i) + endif +124 format(1x,i3,4e13.4) +125 format(1x,2e13.4) + enddo + + + end subroutine cup_output_ens_3d +!------------------------------------------------------- + subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & + p_cup,kbcon,ktop,dby,clw_all,xland1, & + q,gamma_cup,zu,qes_cup,k22,qe_cup, & + zqexec,ccn,rho,c1d,t, & + up_massentr,up_massdetr,psum,psumh, & + itest,itf,ktf, & + its,ite, kts,kte ) + + implicit none + real(kind=kind_phys), parameter :: bdispm = 0.366 !berry--size dispersion (martime) + real(kind=kind_phys), parameter :: bdispc = 0.146 !berry--size dispersion (continental) +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itest,itf,ktf, & + its,ite, kts,kte + ! cd= detrainment function + ! q = environmental q on model levels + ! qe_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! dby = buoancy term + ! cd= detrainment function + ! zu = normalized updraft mass flux + ! gamma_cup = gamma on model cloud levels + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + p_cup,rho,q,zu,gamma_cup,qe_cup, & + up_massentr,up_massdetr,dby,qes_cup,z_cup + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + zqexec + ! entr= entrainment rate + integer, dimension (its:ite) & + ,intent (in ) :: & + kbcon,ktop,k22,xland1 +! +! input and output +! + + ! ierr error value, maybe modified in this routine + + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr + character *(*), intent (in) :: & + name + ! qc = cloud q (including liquid water) after entrainment + ! qrch = saturation q in cloud + ! qrc = liquid water content in cloud after rainout + ! pw = condensate that will fall out at that level + ! pwav = totan normalized integrated condensate (i1) + ! c0 = conversion rate (cloud to rain) + + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out ) :: & + qc,qrc,pw,clw_all + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + qch,qrcb,pwh,clw_allh,c1d,t + real(kind=kind_phys), dimension (its:ite) :: & + pwavh + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + pwav,psum,psumh + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + ccn +! +! local variables in this routine +! + + integer :: & + iprop,iall,i,k + integer :: start_level(its:ite) + real(kind=kind_phys) :: & + prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & + c0,dz,berryc0,q1,berryc + real(kind=kind_phys) :: & + denom, c0t + real(kind=kind_phys), dimension (kts:kte) :: & + prop_b +! + prop_b(kts:kte)=0 + iall=0 + c0=.002 + clwdet=100. + bdsp=bdispm +! +!--- no precip for small clouds +! +! if(name.eq.'shallow')then +! c0=0.002 +! endif + do i=its,itf + pwav(i)=0. + pwavh(i)=0. + psum(i)=0. + psumh(i)=0. + enddo + do k=kts,ktf + do i=its,itf + pw(i,k)=0. + pwh(i,k)=0. + qc(i,k)=0. + if(ierr(i).eq.0)qc(i,k)=qe_cup(i,k) + if(ierr(i).eq.0)qch(i,k)=qe_cup(i,k) + clw_all(i,k)=0. + clw_allh(i,k)=0. + qrc(i,k)=0. + qrcb(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + start_level=k22(i) + call get_cloud_bc(kte,qe_cup (i,1:kte),qaver,k22(i)) + qaver = qaver + k=start_level(i) + qc (i,k)= qaver + qch (i,k)= qaver + do k=1,start_level(i)-1 + qc (i,k)= qe_cup(i,k) + qch (i,k)= qe_cup(i,k) + enddo +! +! initialize below originating air +! + endif + enddo + + do 100 i=its,itf + c0=.004 + if(ierr(i).eq.0)then + +! below lfc, but maybe above lcl +! +! if(name == "deep" )then + do k=k22(i)+1,kbcon(i) + if(t(i,k) > 273.16) then + c0t = c0 + else + c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) + endif + qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & + up_massentr(i,k-1)*q(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) +! qrch=qes_cup(i,k) + qrch=qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & + /(1.+gamma_cup(i,k)))*dby(i,k) + if(k.lt.kbcon(i))qrch=qc(i,k) + if(qc(i,k).gt.qrch)then + dz=z_cup(i,k)-z_cup(i,k-1) + qrc(i,k)=(qc(i,k)-qrch)/(1.+c0t*dz) + pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) + qc(i,k)=qrch+qrc(i,k) + clw_all(i,k)=qrc(i,k) + endif + enddo + ! endif +! +!now do the rest +! + do k=kbcon(i)+1,ktop(i) + c0=.004 + if(t(i,k).lt.270.)c0=.002 + if(t(i,k) > 273.16) then + c0t = c0 + else + c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) + endif + denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) + if(denom.lt.1.e-16)then + ierr(i)=51 + exit + endif + + + rhoc=.5*(rho(i,k)+rho(i,k-1)) + dz=z_cup(i,k)-z_cup(i,k-1) + dp=p_cup(i,k)-p_cup(i,k-1) +! +!--- saturation in cloud, this is what is allowed to be in it +! + qrch=qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & + /(1.+gamma_cup(i,k)))*dby(i,k) +! +!------ 1. steady state plume equation, for what could +!------ be in cloud without condensation +! +! + qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & + up_massentr(i,k-1)*q(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + qch(i,k)= (qch(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*qch(i,k-1)+ & + up_massentr(i,k-1)*q(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + + if(qc(i,k).le.qrch)then + qc(i,k)=qrch + endif + if(qch(i,k).le.qrch)then + qch(i,k)=qrch + endif +! +!------- total condensed water before rainout +! + clw_all(i,k)=max(0.,qc(i,k)-qrch) + qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) + clw_allh(i,k)=max(0.,qch(i,k)-qrch) + qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) + if(autoconv.eq.2) then + + +! +! normalized berry +! +! first calculate for average conditions, used in cup_dd_edt! +! this will also determine proportionality constant prop_b, which, if applied, +! would give the same results as c0 under these conditions +! + q1=1.e3*rhoc*qrcb(i,k) ! g/m^3 ! g[h2o]/cm^3 + berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccnclean/ & + ( q1 * bdsp) ) ) !/( + qrcb_h=((qch(i,k)-qrch)*zu(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ & + (zu(i,k)+.5*up_massdetr(i,k-1)+c0t*dz*zu(i,k)) + prop_b(k)=c0t*qrcb_h*zu(i,k)/(1.e-3*berryc0) + pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) ! 2. + berryc=qrcb(i,k) + qrcb(i,k)=((qch(i,k)-qrch)*zu(i,k)-pwh(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ & + (zu(i,k)+.5*up_massdetr(i,k-1)) + if(qrcb(i,k).lt.0.)then + berryc0=(qrcb(i,k-1)*(.5*up_massdetr(i,k-1))-(qch(i,k)-qrch)*zu(i,k))/zu(i,k)*1.e-3*dz*prop_b(k) + pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) + qrcb(i,k)=0. + endif + qch(i,k)=qrcb(i,k)+qrch + pwavh(i)=pwavh(i)+pwh(i,k) + psumh(i)=psumh(i)+clw_allh(i,k)*zu(i,k) *dz + ! +! then the real berry +! + q1=1.e3*rhoc*qrc(i,k) ! g/m^3 ! g[h2o]/cm^3 + berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccn(i)/ & + ( q1 * bdsp) ) ) !/( + berryc0=1.e-3*berryc0*dz*prop_b(k) ! 2. + berryc=qrc(i,k) + qrc(i,k)=((qc(i,k)-qrch)*zu(i,k)-zu(i,k)*berryc0-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/ & + (zu(i,k)+.5*up_massdetr(i,k-1)) + if(qrc(i,k).lt.0.)then + berryc0=((qc(i,k)-qrch)*zu(i,k)-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/zu(i,k) + qrc(i,k)=0. + endif + pw(i,k)=berryc0*zu(i,k) + qc(i,k)=qrc(i,k)+qrch +! +! if not running with berry at all, do the following +! + else !c0=.002 + if(iall.eq.1)then + qrc(i,k)=0. + pw(i,k)=(qc(i,k)-qrch)*zu(i,k) + if(pw(i,k).lt.0.)pw(i,k)=0. + else +! create clw detrainment profile that depends on mass detrainment and +! in-cloud clw/ice +! + c1d(i,k)=clwdet*up_massdetr(i,k-1)*qrc(i,k-1) + qrc(i,k)=(qc(i,k)-qrch)/(1.+(c1d(i,k)+c0t)*dz) + pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) +!-----srf-08aug2017-----begin +! pw(i,k)=(c1d(i,k)+c0)*dz*max(0.,qrc(i,k) -qrc_crit)! units kg[rain]/kg[air] +!-----srf-08aug2017-----end + if(qrc(i,k).lt.0)then + qrc(i,k)=0. + pw(i,k)=0. + endif + endif + qc(i,k)=qrc(i,k)+qrch + endif !autoconv + pwav(i)=pwav(i)+pw(i,k) + psum(i)=psum(i)+clw_all(i,k)*zu(i,k) *dz + enddo ! k=kbcon,ktop +! do not include liquid/ice in qc + do k=k22(i)+1,ktop(i) + qc(i,k)=qc(i,k)-qrc(i,k) + enddo + endif ! ierr +! +!--- integrated normalized ondensate +! + 100 continue + prop_ave=0. + iprop=0 + do k=kts,kte + prop_ave=prop_ave+prop_b(k) + if(prop_b(k).gt.0)iprop=iprop+1 + enddo + iprop=max(iprop,1) + + end subroutine cup_up_moisture + +!-------------------------------------------------------------------- + + real function satvap(temp2) + implicit none + real(kind=kind_phys) :: temp2, temp, toot, toto, eilog, tsot, & + & ewlog, ewlog2, ewlog3, ewlog4 + temp = temp2-273.155 + if (temp.lt.-20.) then !!!! ice saturation + toot = 273.16 / temp2 + toto = 1 / toot + eilog = -9.09718 * (toot - 1) - 3.56654 * (log(toot) / & + & log(10.)) + .876793 * (1 - toto) + (log(6.1071) / log(10.)) + satvap = 10 ** eilog + else + tsot = 373.16 / temp2 + ewlog = -7.90298 * (tsot - 1) + 5.02808 * & + & (log(tsot) / log(10.)) + ewlog2 = ewlog - 1.3816e-07 * & + & (10 ** (11.344 * (1 - (1 / tsot))) - 1) + ewlog3 = ewlog2 + .0081328 * & + & (10 ** (-3.49149 * (tsot - 1)) - 1) + ewlog4 = ewlog3 + (log(1013.246) / log(10.)) + satvap = 10 ** ewlog4 + end if + end function +!-------------------------------------------------------------------- + subroutine get_cloud_bc(mzp,array,x_aver,k22,add) + implicit none + integer, intent(in) :: mzp,k22 + real(kind=kind_phys) , intent(in) :: array(mzp) + real(kind=kind_phys) , optional , intent(in) :: add + real(kind=kind_phys) , intent(out) :: x_aver + integer :: i,local_order_aver,order_aver + + !-- dimension of the average + !-- a) to pick the value at k22 level, instead of a average between + !-- k22-order_aver, ..., k22-1, k22 set order_aver=1) + !-- b) to average between 1 and k22 => set order_aver = k22 + order_aver = 3 !=> average between k22, k22-1 and k22-2 + + local_order_aver=min(k22,order_aver) + + x_aver=0. + do i = 1,local_order_aver + x_aver = x_aver + array(k22-i+1) + enddo + x_aver = x_aver/float(local_order_aver) + if(present(add)) x_aver = x_aver + add + + end subroutine get_cloud_bc + !======================================================================================== + + + subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, & + xland,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev) + implicit none + character *(*), intent (in) :: name + integer, intent(in) :: ipr,its,ite,itf,kts,kte,ktf + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup + real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo,rand_vmas + integer, dimension (its:ite),intent (in) :: kstabi,k22,kpbl,csum,xland,pmin_lev + integer, dimension (its:ite),intent (inout) :: kbcon,ierr,ktop,ktopdby + !-local vars + real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot + real(kind=kind_phys) :: entr_init,beta_u,dz,dbythresh,dzh2,zustart,zubeg,massent,massdetr + real(kind=kind_phys) :: dby(kts:kte),dbm(kts:kte),zux(kts:kte) + real(kind=kind_phys) zuh2(40),zh2(40) + integer :: kklev,i,kk,kbegin,k,kfinalzu + integer, dimension (its:ite) :: start_level + ! + zustart=.1 + dbythresh= 0.8 !.0.95 ! 0.85, 0.6 + if(name == 'shallow' .or. name == 'mid') dbythresh=1. + dby(:)=0. + + do i=its,itf + if(ierr(i) > 0 )cycle + zux(:)=0. + beta_u=max(.1,.2-float(csum(i))*.01) + zuo(i,:)=0. + dby(:)=0. + dbm(:)=0. + kbcon(i)=max(kbcon(i),2) + start_level(i)=k22(i) + zuo(i,start_level(i))=zustart + zux(start_level(i))=zustart + entr_init=entr_rate_2d(i,kts) + do k=start_level(i)+1,kbcon(i) + dz=z_cup(i,k)-z_cup(i,k-1) + massent=dz*entr_rate_2d(i,k-1)*zuo(i,k-1) +! massdetr=dz*1.e-9*zuo(i,k-1) + massdetr=dz*.1*entr_init*zuo(i,k-1) + zuo(i,k)=zuo(i,k-1)+massent-massdetr + zux(k)=zuo(i,k) + enddo + zubeg=zustart !zuo(i,kbcon(i)) + if(name .eq. 'deep')then + ktop(i)=0 + hcot(i,start_level(i))=hkbo(i) + dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1) + do k=start_level(i)+1,ktf-2 + dz=z_cup(i,k)-z_cup(i,k-1) + + hcot(i,k)=( (1.-0.5*entr_rate_2d(i,k-1)*dz)*hcot(i,k-1) & + + entr_rate_2d(i,k-1)*dz*heo(i,k-1))/ & + (1.+0.5*entr_rate_2d(i,k-1)*dz) + if(k >= kbcon(i)) dby(k)=dby(k-1)+(hcot(i,k)-heso_cup(i,k))*dz + if(k >= kbcon(i)) dbm(k)=hcot(i,k)-heso_cup(i,k) + enddo + ktopdby(i)=maxloc(dby(:),1) + kklev=maxloc(dbm(:),1) + do k=maxloc(dby(:),1)+1,ktf-2 + if(dby(k).lt.dbythresh*maxval(dby))then + kfinalzu=k - 1 + ktop(i)=kfinalzu + go to 412 + endif + enddo + kfinalzu=ktf-2 + ktop(i)=kfinalzu +412 continue + kklev=min(kklev+3,ktop(i)-2) +! +! at least overshoot by one level +! +! kfinalzu=min(max(kfinalzu,ktopdby(i)+1),ktopdby(i)+2) +! ktop(i)=kfinalzu + if(kfinalzu.le.kbcon(i)+2)then + ierr(i)=41 + ktop(i)= 0 + else +! call get_zu_zd_pdf_fim(ipr,xland(i),zuh2,"up",ierr(i),start_level(i), & +! call get_zu_zd_pdf_fim(rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),kbcon(i), & +! kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i)) + call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),k22(i), & + kfinalzu+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + endif + endif ! end deep + if ( name == 'mid' ) then + if(ktop(i) <= kbcon(i)+2)then + ierr(i)=41 + ktop(i)= 0 + else + kfinalzu=ktop(i) + ktopdby(i)=ktop(i)+1 + call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"mid",ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + endif + endif ! mid + if ( name == 'shallow' ) then + if(ktop(i) <= kbcon(i)+2)then + ierr(i)=41 + ktop(i)= 0 + else + kfinalzu=ktop(i) + ktopdby(i)=ktop(i)+1 + call get_zu_zd_pdf_fim(kbcon(i),p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"sh2",ierr(i),k22(i), & + ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + + endif + endif ! shal + enddo + + end subroutine rates_up_pdf +!------------------------------------------------------------------------- + + subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,kb,kt,zu,kts,kte,ktf,max_mass,kpbli,csum,pmin_lev) + + implicit none +! real(kind=kind_phys), parameter :: beta_deep=1.3,g_beta_deep=0.8974707 +! real(kind=kind_phys), parameter :: beta_deep=1.2,g_beta_deep=0.8974707 +! real(kind=kind_phys), parameter :: beta_sh=2.5,g_beta_sh=1.329340 + real(kind=kind_phys), parameter :: beta_sh=2.2,g_beta_sh=0.8974707 + real(kind=kind_phys), parameter :: beta_mid=1.3,g_beta_mid=0.8974707 +! real(kind=kind_phys), parameter :: beta_mid=1.8,g_beta_mid=0.8974707 + real(kind=kind_phys), parameter :: beta_dd=4.0,g_beta_dd=6. + integer, intent(in) ::ipr,xland,kb,kklev,kt,kts,kte,ktf,kpbli,csum,pmin_lev + real(kind=kind_phys), intent(in) ::max_mass,zubeg + real(kind=kind_phys), intent(inout) :: zu(kts:kte) + real(kind=kind_phys), intent(in) :: p(kts:kte) + real(kind=kind_phys) :: trash,beta_deep,zuh(kts:kte),zuh2(1:40) + integer, intent(inout) :: ierr + character*(*), intent(in) ::draft + + !- local var + integer :: k1,kk,k,kb_adj,kpbli_adj,kmax + real(kind=kind_phys) :: maxlim,krmax,kratio,tunning,fzu,rand_vmas,lev_start + real(kind=kind_phys) :: a,b,x1,y1,g_a,g_b,alpha2,g_alpha2 +! +! very simple lookup tables +! + real(kind=kind_phys), dimension(30) :: alpha,g_alpha + data (alpha(k),k=4,27)/3.699999, & + 3.024999,2.559999,2.249999,2.028571,1.862500, & + 1.733333,1.630000,1.545454,1.475000,1.415385, & + 1.364286,1.320000,1.281250,1.247059,1.216667, & + 1.189474,1.165000,1.142857,1.122727,1.104348, & + 1.087500,1.075000,1.075000/ + data (g_alpha(k),k=4,27)/4.170645, & + 2.046925 , 1.387837, 1.133003, 1.012418,0.9494680, & + 0.9153771,0.8972442,0.8885444,0.8856795,0.8865333, & + 0.8897996,0.8946404,0.9005030,0.9070138,0.9139161, & + 0.9210315,0.9282347,0.9354376,0.9425780,0.9496124, & + 0.9565111,0.9619183,0.9619183/ + alpha(1:3)=alpha(4) + g_alpha(1:3)=g_alpha(4) + alpha(28:30)=alpha(27) + g_alpha(28:30)=g_alpha(27) + + !- kb cannot be at 1st level + + !-- fill zu with zeros + zu(:)=0.0 + zuh(:)=0.0 + kb_adj=max(kb,2) + if(draft == "up") then + lev_start=min(.9,.1+csum*.013) + kb_adj=max(kb,2) + tunning=max(p(kklev+1),.5*(p(kpbli)+p(kt))) + tunning=p(kklev) +! tunning=p(kklev+1) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +! tunning=.5*(p(kb_adj)+p(kt)) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start + trash=-p(kt)+p(kb_adj) + beta_deep=1.3 +(1.-trash/1200.) + tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_deep -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then +! write(0,*)'k1 = ',k1 + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b +! write(0,*)'x1,y1,a,b ',x1,y1,a,b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b +! write(0,*)'g_a,g_b,g_alpha2 ',g_a,g_b,g_alpha2 + else + g_alpha2=g_alpha(k1) + endif + +! fzu = gamma(alpha2 + beta_deep)/(g_alpha2*g_beta_deep) + fzu = gamma(alpha2 + beta_deep)/(gamma(alpha2)*gamma(beta_deep)) + zu(kb_adj)=zubeg + do k=kb_adj+1,min(kte,kt-1) + kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) + zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_deep-1.0) + enddo + + if(zu(kpbli).gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) + do k=maxloc(zu(:),1),1,-1 + if(zu(k).lt.1.e-6)then + kb_adj=k+1 + exit + endif + enddo + kb_adj=max(2,kb_adj) + do k=kts,kb_adj-1 + zu(k)=0. + enddo + maxlim=1.2 + a=maxval(zu)-zu(kb_adj) + do k=kb_adj,kt + trash=zu(k) + if(a.gt.maxlim)then + zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) +! if(p(kt).gt.400.)write(32,122)k,p(k),zu(k),trash + endif + enddo +122 format(1x,i4,1x,f8.1,1x,f6.2,1x,f6.2) + + elseif(draft == "sh2") then + k=kklev + if(kpbli.gt.5)k=kpbli +!new nov18 + tunning=p(kklev) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +!end new + tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_sh -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b + else + g_alpha2=g_alpha(k1) + endif + + fzu = gamma(alpha2 + beta_sh)/(g_alpha2*g_beta_sh) + zu(kb_adj) = zubeg + do k=kb_adj+1,min(kte,kt-1) + kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) + zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_sh-1.0) + enddo + +! beta = 2.5 !2.5 ! max(2.5,2./tunning) +! if(maxval(zu(kts:min(ktf,kt+1))).gt.0.) & +! zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1))) + if(zu(kpbli).gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) + do k=maxloc(zu(:),1),1,-1 + if(zu(k).lt.1.e-6)then + kb_adj=k+1 + exit + endif + enddo + maxlim=1. + a=maxval(zu)-zu(kb_adj) + do k=kts,kt + if(a.gt.maxlim)zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) +! write(32,122)k,p(k),zu(k) + enddo + + elseif(draft == "mid") then + kb_adj=max(kb,2) + tunning=.5*(p(kt)+p(kpbli)) !p(kt)+(p(kb_adj)-p(kt))*.9 !*.33 +!new nov18 +! tunning=p(kpbli) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +!end new + tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_mid -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b + else + g_alpha2=g_alpha(k1) + endif + +! fzu = gamma(alpha2 + beta_deep)/(g_alpha2*g_beta_deep) + fzu = gamma(alpha2 + beta_mid)/(gamma(alpha2)*gamma(beta_mid)) +! fzu = gamma(alpha2 + beta_mid)/(g_alpha2*g_beta_mid) + zu(kb_adj) = zubeg + do k=kb_adj+1,min(kte,kt-1) + kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) + zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_mid-1.0) + enddo + + if(zu(kpbli).gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) + do k=maxloc(zu(:),1),1,-1 + if(zu(k).lt.1.e-6)then + kb_adj=k+1 + exit + endif + enddo + kb_adj=max(2,kb_adj) + do k=kts,kb_adj-1 + zu(k)=0. + enddo + maxlim=1.5 + a=maxval(zu)-zu(kb_adj) + do k=kts,kt + if(a.gt.maxlim)zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) +! write(33,122)k,p(k),zu(k) + enddo + + elseif(draft == "down" .or. draft == "downm") then + + tunning=p(kb) + tunning =min(0.95, (tunning-p(1))/(p(kt)-p(1))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_dd -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b + else + g_alpha2=g_alpha(k1) + endif + + fzu = gamma(alpha2 + beta_dd)/(g_alpha2*g_beta_dd) +! fzu = gamma(alpha2 + beta_dd)/(gamma(alpha2)*gamma(beta_dd)) + zu(:)=0. + do k=2,min(kte,kt-1) + kratio= (p(k)-p(1))/(p(kt)-p(1)) !float(k)/float(kt+1) + zu(k) = fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_dd-1.0) + enddo + + fzu=maxval(zu(kts:min(ktf,kt-1))) + if(fzu.gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/fzu + zu(1)=0. + do k=1,kb-2 !kb,2,-1 + zu(kb-k)=zu(kb-k+1)-zu(kb)*(p(kb-k)-p(kb-k+1))/(p(1)-p(kb)) + enddo + zu(1)=0. + endif + end subroutine get_zu_zd_pdf_fim + +!------------------------------------------------------------------------- + subroutine cup_up_aa1bl(aa0,t,tn,q,qo,dtime, & + z_cup,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! aa0 cloud work function + ! gamma_cup = gamma on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! dby = buoancy term + ! zu= normalized updraft mass flux + ! z = heights of model levels + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + z_cup,zu,gamma_cup,t_cup,dby,t,tn,q,qo + integer, dimension (its:ite) & + ,intent (in ) :: & + kbcon,ktop + real(kind=kind_phys), intent(in) :: dtime +! +! input and output +! + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + aa0 +! +! local variables in this routine +! + integer :: & + i,k + real(kind=kind_phys) :: & + dz,da +! + do i=its,itf + aa0(i)=0. + enddo + do 100 i=its,itf + do 100 k=kts,kbcon(i) + if(ierr(i).ne.0 )go to 100 +! if(k.gt.kbcon(i))go to 100 + + dz = (z_cup (i,k+1)-z_cup (i,k))*g + da = dz*(tn(i,k)*(1.+0.608*qo(i,k))-t(i,k)*(1.+0.608*q(i,k)))/dtime + + aa0(i)=aa0(i)+da +100 continue + + end subroutine cup_up_aa1bl +!---------------------------------------------------------------------- + subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_layers,& + kstart,kend,dtempdz,itf,ktf,its,ite, kts,kte) + + implicit none + integer ,intent (in ) :: itf,ktf,its,ite,kts,kte + integer, dimension (its:ite) ,intent (in ) :: ierr,kstart,kend + integer, dimension (its:ite) :: kend_p3 + + real(kind=kind_phys), dimension (its:ite,kts:kte), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup + real(kind=kind_phys), dimension (its:ite,kts:kte), intent (out) :: dtempdz + integer, dimension (its:ite,kts:kte), intent (out) :: k_inv_layers + !-local vars + real(kind=kind_phys) :: dp,l_mid,l_shal,first_deriv(kts:kte),sec_deriv(kts:kte) + integer:: ken,kadd,kj,i,k,ilev,kk,ix,k800,k550,mid,shal + ! + !-initialize k_inv_layers as undef + l_mid=300. + l_shal=100. + k_inv_layers(:,:) = 1 + do i = its,itf + if(ierr(i) == 0)then + sec_deriv(:)=0. + kend_p3(i)=kend(i)+3 + do k = kts+1,kend_p3(i)+4 + !- get the 1st der + first_deriv(k)= (t_cup(i,k+1)-t_cup(i,k-1))/(z_cup(i,k+1)-z_cup(i,k-1)) + dtempdz(i,k)=first_deriv(k) + enddo + do k = kts+2,kend_p3(i)+3 + ! get the 2nd der + sec_deriv(k)= (first_deriv(k+1)-first_deriv(k-1))/(z_cup(i,k+1)-z_cup(i,k-1)) + sec_deriv(k)= abs(sec_deriv(k)) + enddo + + ilev=max(kts+3,kstart(i)+1) + ix=1 + k=ilev + do while (ilev < kend_p3(i)) !(z_cup(i,ilev)<15000.) + do kk=k,kend_p3(i)+2 !k,ktf-2 + + if(sec_deriv(kk) < sec_deriv(kk+1) .and. & + sec_deriv(kk) < sec_deriv(kk-1) ) then + k_inv_layers(i,ix)=kk + ix=min(5,ix+1) + ilev=kk+1 + exit + endif + ilev=kk+1 + enddo + k=ilev + enddo + !- 2nd criteria + kadd=0 + ken=maxloc(k_inv_layers(i,:),1) + do k=1,ken + kk=k_inv_layers(i,k+kadd) + if(kk.eq.1)exit + + if( dtempdz(i,kk) < dtempdz(i,kk-1) .and. & + dtempdz(i,kk) < dtempdz(i,kk+1) ) then ! the layer is not a local maximum + kadd=kadd+1 + do kj = k,ken + if(k_inv_layers(i,kj+kadd).gt.1)k_inv_layers(i,kj) = k_inv_layers(i,kj+kadd) + if(k_inv_layers(i,kj+kadd).eq.1)k_inv_layers(i,kj) = 1 + enddo + endif + enddo + endif + enddo +100 format(1x,16i3) + !- find the locations of inversions around 800 and 550 hpa + do i = its,itf + if(ierr(i) /= 0) cycle + + !- now find the closest layers of 800 and 550 hpa. + sec_deriv(:)=1.e9 + do k=1,maxloc(k_inv_layers(i,:),1) !kts,kte !kstart(i),kend(i) !kts,kte + dp=p_cup(i,k_inv_layers(i,k))-p_cup(i,kstart(i)) + sec_deriv(k)=abs(dp)-l_shal + enddo + k800=minloc(abs(sec_deriv),1) + sec_deriv(:)=1.e9 + + do k=1,maxloc(k_inv_layers(i,:),1) !kts,kte !kstart(i),kend(i) !kts,kte + dp=p_cup(i,k_inv_layers(i,k))-p_cup(i,kstart(i)) + sec_deriv(k)=abs(dp)-l_mid + enddo + k550=minloc(abs(sec_deriv),1) + !-save k800 and k550 in k_inv_layers array + shal=1 + mid=2 + k_inv_layers(i,shal)=k_inv_layers(i,k800) ! this is for shallow convection + k_inv_layers(i,mid )=k_inv_layers(i,k550) ! this is for mid/congestus convection + k_inv_layers(i,mid+1:kte)=-1 + enddo + + + end subroutine get_inversion_layers +!----------------------------------------------------------------------------------- + function deriv3(xx, xi, yi, ni, m) + !============================================================================*/ + ! evaluate first- or second-order derivatives + ! using three-point lagrange interpolation + ! written by: alex godunov (october 2009) + ! input ... + ! xx - the abscissa at which the interpolation is to be evaluated + ! xi() - the arrays of data abscissas + ! yi() - the arrays of data ordinates + ! ni - size of the arrays xi() and yi() + ! m - order of a derivative (1 or 2) + ! output ... + ! deriv3 - interpolated value + !============================================================================*/ + + implicit none + integer, parameter :: n=3 + integer ni, m,i, j, k, ix + real(kind=kind_phys):: deriv3, xx + real(kind=kind_phys):: xi(ni), yi(ni), x(n), f(n) + + ! exit if too high-order derivative was needed, + if (m > 2) then + deriv3 = 0.0 + return + end if + + ! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0 + if (xx < xi(1) .or. xx > xi(ni)) then + deriv3 = 0.0 + stop "problems with finding the 2nd derivative" + end if + + ! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i) + i = 1 + j = ni + do while (j > i+1) + k = (i+j)/2 + if (xx < xi(k)) then + j = k + else + i = k + end if + end do + + ! shift i that will correspond to n-th order of interpolation + ! the search point will be in the middle in x_i, x_i+1, x_i+2 ... + i = i + 1 - n/2 + + ! check boundaries: if i is ouside of the range [1, ... n] -> shift i + if (i < 1) i=1 + if (i + n > ni) i=ni-n+1 + + ! old output to test i + ! write(*,100) xx, i + ! 100 format (f10.5, i5) + + ! just wanted to use index i + ix = i + ! initialization of f(n) and x(n) + do i=1,n + f(i) = yi(ix+i-1) + x(i) = xi(ix+i-1) + end do + + ! calculate the first-order derivative using lagrange interpolation + if (m == 1) then + deriv3 = (2.0*xx - (x(2)+x(3)))*f(1)/((x(1)-x(2))*(x(1)-x(3))) + deriv3 = deriv3 + (2.0*xx - (x(1)+x(3)))*f(2)/((x(2)-x(1))*(x(2)-x(3))) + deriv3 = deriv3 + (2.0*xx - (x(1)+x(2)))*f(3)/((x(3)-x(1))*(x(3)-x(2))) + ! calculate the second-order derivative using lagrange interpolation + else + deriv3 = 2.0*f(1)/((x(1)-x(2))*(x(1)-x(3))) + deriv3 = deriv3 + 2.0*f(2)/((x(2)-x(1))*(x(2)-x(3))) + deriv3 = deriv3 + 2.0*f(3)/((x(3)-x(1))*(x(3)-x(2))) + end if + end function deriv3 +!============================================================================================= + subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,draft,kbcon,k22,up_massentru,up_massdetru,lambau) + + implicit none + character *(*), intent (in) :: draft + integer, intent(in):: itf,ktf, its,ite, kts,kte + integer, intent(in) , dimension(its:ite) :: ierr,ktop,kbcon,k22 + !real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau + real(kind=kind_phys), intent(inout), optional , dimension(its:ite):: lambau + real(kind=kind_phys), intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo + real(kind=kind_phys), intent(inout), dimension(its:ite,kts:kte) :: cd,entr_rate_2d + real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte) :: up_massentro, up_massdetro & + ,up_massentr, up_massdetr + real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte), optional :: & + up_massentru,up_massdetru + !-- local vars + integer :: i,k, incr1,incr2,turn + real(kind=kind_phys) :: dz,trash,trash2 + + do k=kts,kte + do i=its,ite + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + up_massentr (i,k)=0. + up_massdetr (i,k)=0. + enddo + enddo + if(present(up_massentru) .and. present(up_massdetru))then + do k=kts,kte + do i=its,ite + up_massentru(i,k)=0. + up_massdetru(i,k)=0. + enddo + enddo + endif + do i=its,itf + if(ierr(i).eq.0)then + + do k=max(2,k22(i)+1),maxloc(zuo(i,:),1) + !=> below maximum value zu -> change entrainment + dz=zo_cup(i,k)-zo_cup(i,k-1) + + up_massdetro(i,k-1)=cd(i,k-1)*dz*zuo(i,k-1) + up_massentro(i,k-1)=zuo(i,k)-zuo(i,k-1)+up_massdetro(i,k-1) + if(up_massentro(i,k-1).lt.0.)then + up_massentro(i,k-1)=0. + up_massdetro(i,k-1)=zuo(i,k-1)-zuo(i,k) + if(zuo(i,k-1).gt.0.)cd(i,k-1)=up_massdetro(i,k-1)/(dz*zuo(i,k-1)) + endif + if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1)) + enddo + do k=maxloc(zuo(i,:),1)+1,ktop(i) + !=> above maximum value zu -> change detrainment + dz=zo_cup(i,k)-zo_cup(i,k-1) + up_massentro(i,k-1)=entr_rate_2d(i,k-1)*dz*zuo(i,k-1) + up_massdetro(i,k-1)=zuo(i,k-1)+up_massentro(i,k-1)-zuo(i,k) + if(up_massdetro(i,k-1).lt.0.)then + up_massdetro(i,k-1)=0. + up_massentro(i,k-1)=zuo(i,k)-zuo(i,k-1) + if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1)) + endif + + if(zuo(i,k-1).gt.0.)cd(i,k-1)=up_massdetro(i,k-1)/(dz*zuo(i,k-1)) + enddo + up_massdetro(i,ktop(i))=zuo(i,ktop(i)) + up_massentro(i,ktop(i))=0. + do k=ktop(i)+1,ktf + cd(i,k)=0. + entr_rate_2d(i,k)=0. + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + enddo + do k=2,ktf-1 + up_massentr (i,k-1)=up_massentro(i,k-1) + up_massdetr (i,k-1)=up_massdetro(i,k-1) + enddo + if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'deep')then + !turn=maxloc(zuo(i,:),1) + !do k=2,turn + ! up_massentru(i,k-1)=up_massentro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + ! up_massdetru(i,k-1)=up_massdetro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + !enddo + !do k=turn+1,ktf-1 + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'shallow')then + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'mid')then + lambau(i)=0. + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + endif + + trash=0. + trash2=0. + do k=k22(i)+1,ktop(i) + trash2=trash2+entr_rate_2d(i,k) + enddo + do k=k22(i)+1,kbcon(i) + trash=trash+entr_rate_2d(i,k) + enddo + + endif + enddo + end subroutine get_lateral_massflux +!---meltglac------------------------------------------------- +!------------------------------------------------------------------------------------ + subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer & + ,itf,ktf,its,ite, kts,kte, cumulus ) + implicit none + character *(*), intent (in) :: cumulus + integer ,intent (in ) :: itf,ktf, its,ite, kts,kte + real(kind=kind_phys), intent (in ), dimension(its:ite,kts:kte) :: tn,po_cup + real(kind=kind_phys), intent (inout), dimension(its:ite,kts:kte) :: p_liq_ice,melting_layer + integer , intent (in ), dimension(its:ite) :: ierr + integer :: i,k + real(kind=kind_phys) :: dp + real(kind=kind_phys), dimension(its:ite) :: norm + real(kind=kind_phys), parameter :: t1=276.16 + + ! hli initialize at the very beginning + p_liq_ice (:,:) = 1. + melting_layer(:,:) = 0. + !-- get function of t for partition of total condensate into liq and ice phases. + if(melt_glac .and. cumulus == 'deep') then + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + + if (tn(i,k) <= t_ice) then + + p_liq_ice(i,k) = 0. + elseif( tn(i,k) > t_ice .and. tn(i,k) < t_0) then + + p_liq_ice(i,k) = ((tn(i,k)-t_ice)/(t_0-t_ice))**2 + else + p_liq_ice(i,k) = 1. + endif + + !melting_layer(i,k) = p_liq_ice(i,k) * (1.-p_liq_ice(i,k)) + enddo + endif + enddo + !go to 655 + !-- define the melting layer (the layer will be between t_0+1 < temp < t_1 + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + if (tn(i,k) <= t_0+1) then + melting_layer(i,k) = 0. + + elseif( tn(i,k) > t_0+1 .and. tn(i,k) < t1) then + melting_layer(i,k) = ((tn(i,k)-t_0+1)/(t1-t_0+1))**2 + + else + melting_layer(i,k) = 1. + endif + melting_layer(i,k) = melting_layer(i,k)*(1-melting_layer(i,k)) + enddo + endif + enddo + 655 continue + !-normalize vertical integral of melting_layer to 1 + norm(:)=0. + !do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf-1 + dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) + norm(i) = norm(i) + melting_layer(i,k)*dp/g + enddo + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + !print*,"i1=",i,maxval(melting_layer(i,:)),minval(melting_layer(i,:)),norm(i) + melting_layer(i,:)=melting_layer(i,:)/(norm(i)+1.e-6)*(100*(po_cup(i,kts)-po_cup(i,ktf))/g) + endif + !print*,"i2=",i,maxval(melting_layer(i,:)),minval(melting_layer(i,:)),norm(i) + enddo + !--check +! norm(:)=0. +! do k=kts,ktf-1 +! do i=its,itf +! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) +! norm(i) = norm(i) + melting_layer(i,k)*dp/g/(100*(po_cup(i,kts)-po_cup(i,ktf))/g) +! !print*,"n=",i,k,norm(i) +! enddo +! enddo + + else + p_liq_ice (:,:) = 1. + melting_layer(:,:) = 0. + endif + end subroutine get_partition_liq_ice + +!------------------------------------------------------------------------------------ + subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & + ,pwo,edto,pwdo,melting & + ,itf,ktf,its,ite, kts,kte, cumulus ) + implicit none + character *(*), intent (in) :: cumulus + integer ,intent (in ) :: itf,ktf, its,ite, kts,kte + integer ,intent (in ), dimension(its:ite) :: ierr + real(kind=kind_phys) ,intent (in ), dimension(its:ite) :: edto + real(kind=kind_phys) ,intent (in ), dimension(its:ite,kts:kte) :: tn_cup,po_cup,qrco,pwo & + ,pwdo,p_liq_ice,melting_layer + real(kind=kind_phys) ,intent (inout), dimension(its:ite,kts:kte) :: melting + integer :: i,k + real(kind=kind_phys) :: dp + real(kind=kind_phys), dimension(its:ite) :: norm,total_pwo_solid_phase + real(kind=kind_phys), dimension(its:ite,kts:kte) :: pwo_solid_phase,pwo_eff + + if(melt_glac .and. cumulus == 'deep') then + + !-- set melting mixing ratio to zero for columns that do not have deep convection + do i=its,itf + if(ierr(i) > 0) melting(i,:) = 0. + enddo + + !-- now, get it for columns where deep convection is activated + total_pwo_solid_phase(:)=0. + + !do k=kts,ktf + do k=kts,ktf-1 + do i=its,itf + if(ierr(i) /= 0) cycle + dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) + + !-- effective precip (after evaporation by downdraft) + pwo_eff(i,k) = 0.5*(pwo(i,k)+pwo(i,k+1) + edto(i)*(pwdo(i,k)+pwdo(i,k+1))) + + !-- precipitation at solid phase(ice/snow) + pwo_solid_phase(i,k) = (1.-p_liq_ice(i,k))*pwo_eff(i,k) + + !-- integrated precip at solid phase(ice/snow) + total_pwo_solid_phase(i) = total_pwo_solid_phase(i)+pwo_solid_phase(i,k)*dp/g + enddo + enddo + + do k=kts,ktf + do i=its,itf + if(ierr(i) /= 0) cycle + !-- melting profile (kg/kg) + melting(i,k) = melting_layer(i,k)*(total_pwo_solid_phase(i)/(100*(po_cup(i,kts)-po_cup(i,ktf))/g)) + !print*,"mel=",k,melting(i,k),pwo_solid_phase(i,k),po_cup(i,k) + enddo + enddo + +!-- check conservation of total solid phase precip +! norm(:)=0. +! do k=kts,ktf-1 +! do i=its,itf +! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) +! norm(i) = norm(i) + melting(i,k)*dp/g +! enddo +! enddo +! +! do i=its,itf +! print*,"cons=",i,norm(i),total_pwo_solid_phase(i) +! enddo +!-- + + else + !-- no melting allowed in this run + melting (:,:) = 0. + endif + end subroutine get_melting_profile +!---meltglac------------------------------------------------- +!-----srf-08aug2017-----begin + subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, & + kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,klcl,hcot) + implicit none + integer, intent(in) :: its,ite,itf,kts,kte,ktf + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup + real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo + integer, dimension (its:ite),intent (in) :: kstabi,k22,kbcon,kpbl,klcl + integer, dimension (its:ite),intent (inout) :: ierr,ktop + real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot + character *(*), intent (in) :: name + real(kind=kind_phys) :: dz,dh, dbythresh + real(kind=kind_phys) :: dby(kts:kte) + integer :: i,k,ipr,kdefi,kstart,kbegzu,kfinalzu + integer, dimension (its:ite) :: start_level + integer,parameter :: find_ktop_option = 1 !0=original, 1=new + + dbythresh=0.8 !0.95 ! the range of this parameter is 0-1, higher => lower + ! overshoting (cheque aa0 calculation) + ! rainfall is too sensible this parameter + ! for now, keep =1. + if(name == 'shallow'.or. name == 'mid')then + dbythresh=1.0 + endif + ! print*,"================================cumulus=",name; call flush(6) + do i=its,itf + kfinalzu=ktf-2 + ktop(i)=kfinalzu + if(ierr(i).eq.0)then + dby (kts:kte)=0.0 + + start_level(i)=kbcon(i) + !-- hcot below kbcon + hcot(i,kts:start_level(i))=hkbo(i) + + dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1) + dby(start_level(i))=(hcot(i,start_level(i))-heso_cup(i,start_level(i)))*dz + + !print*,'hco1=',start_level(i),kbcon(i),hcot(i,start_level(i))/heso_cup(i,start_level(i)) + + do k=start_level(i)+1,ktf-2 + dz=z_cup(i,k)-z_cup(i,k-1) + + hcot(i,k)=( (1.-0.5*entr_rate_2d(i,k-1)*dz)*hcot(i,k-1) & + +entr_rate_2d(i,k-1)*dz *heo (i,k-1) )/ & + (1.+0.5*entr_rate_2d(i,k-1)*dz) + dby(k)=dby(k-1)+(hcot(i,k)-heso_cup(i,k))*dz + !print*,'hco2=',k,hcot(i,k)/heso_cup(i,k),dby(k),entr_rate_2d(i,k-1) + + enddo + if(find_ktop_option==0) then + do k=maxloc(dby(:),1),ktf-2 + !~ print*,'hco30=',k,dby(k),dbythresh*maxval(dby) + + if(dby(k).lt.dbythresh*maxval(dby))then + kfinalzu = k - 1 + ktop(i) = kfinalzu + !print*,'hco4=',k,kfinalzu,ktop(i),kbcon(i)+1;call flush(6) + go to 412 + endif + enddo + 412 continue + else + do k=start_level(i)+1,ktf-2 + !~ print*,'hco31=',k,dby(k),dbythresh*maxval(dby) + + if(hcot(i,k) < heso_cup(i,k) )then + kfinalzu = k - 1 + ktop(i) = kfinalzu + !print*,'hco40=',k,kfinalzu,ktop(i),kbcon(i)+1;call flush(6) + exit + endif + enddo + endif + if(kfinalzu.le.kbcon(i)+1) ierr(i)=41 + !~ print*,'hco5=',k,kfinalzu,ktop(i),kbcon(i)+1,ierr(i);call flush(6) + ! + endif + enddo + end subroutine get_cloud_top +!------------------------------------------------------------------------------------ + + +end module cu_gf_deep diff --git a/cu_gf_driver.F90 b/cu_gf_driver.F90 new file mode 100644 index 000000000..88575c53a --- /dev/null +++ b/cu_gf_driver.F90 @@ -0,0 +1,836 @@ +! +module cu_gf_driver + + ! DH* TODO: replace constants with arguments to cu_gf_driver_run + use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv + use machine , only: kind_phys + use cu_gf_deep, only: cu_gf_deep_run,neg_check,autoconv,aeroevap + use cu_gf_sh , only: cu_gf_sh_run + + implicit none + + private + + public :: cu_gf_driver_init, cu_gf_driver_run, cu_gf_driver_finalize + +contains + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_cu_gf_driver_init Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------------|--------------------|------------------------------------------|-------|------|-----------|-----------|--------|----------| +!! | mpirank | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | +!! | mpiroot | mpi_root | master MPI-rank | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_gf_driver_init(mpirank, mpiroot, errmsg, errflg) + + implicit none + + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! DH* temporary + if (mpirank==mpiroot) then + write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' + write(0,*) ' --- WARNING --- the CCPP Grell Freitas convection scheme is currently under development, use at your own risk --- WARNING ---' + write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' + end if + ! *DH temporary + + end subroutine cu_gf_driver_init + + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_cu_gf_driver_finalize Argument Table +!! + subroutine cu_gf_driver_finalize() + end subroutine cu_gf_driver_finalize +! +! t2di is temp after advection, but before physics +! t = current temp (t2di + physics up to now) +!=================== +! +!! +!! \section arg_table_cu_gf_driver_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------|-----------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | tottracer | number_of_total_tracers | number of total tracers | count | 0 | integer | | in | F | +!! | ntrac | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | +!! | garea | cell_area | grid cell area | m2 | 1 | real | kind_phys | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | cactiv | conv_activity_counter | convective activity memory | none | 1 | integer | | inout | F | +!! | forcet | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | in | F | +!! | forceqv_spechum| moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | layer geopotential | m2 s-2 | 2 | real | kind_phys | in | F | +!! | raincv | lwe_thickness_of_deep_convective_precipitation_amount | deep convective rainfall amount on physics timestep | m | 1 | real | kind_phys | out | F | +!! | qv_spechum | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | t | air_temperature_updated_by_physics | updated temperature | K | 2 | real | kind_phys | inout | F | +!! | cld1d | cloud_work_function | cloud work function | m2 s-2 | 1 | real | kind_phys | out | F | +!! | us | x_wind_updated_by_physics | updated x-direction wind | m s-1 | 2 | real | kind_phys | inout | F | +!! | vs | y_wind_updated_by_physics | updated y-direction wind | m s-1 | 2 | real | kind_phys | inout | F | +!! | t2di | air_temperature | mid-layer temperature | K | 2 | real | kind_phys | in | F | +!! | w | omega | layer mean vertical velocity | Pa s-1 | 2 | real | kind_phys | in | F | +!! | qv2di_spechum | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!! | p2di | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | psuri | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!! | hbot | vertical_index_at_cloud_base | index for cloud base | index | 1 | integer | | out | F | +!! | htop | vertical_index_at_cloud_top | index for cloud top | index | 1 | integer | | out | F | +!! | kcnv | flag_deep_convection | deep convection: 0=no, 1=yes | flag | 1 | integer | | out | F | +!! | xland | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | hfx2 | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | qfx2 | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | clw | convective_transportable_tracers | cloud water and other convective trans. tracers | kg kg-1 | 3 | real | kind_phys | inout | F | +!! | pbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | in | F | +!! | ud_mf | instantaneous_atmosphere_updraft_convective_mass_flux | (updraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | dd_mf | instantaneous_atmosphere_downdraft_convective_mass_flux | (downdraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | dt_mf | instantaneous_atmosphere_detrainment_convective_mass_flux | (detrainment mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | cnvw_moist | convective_cloud_water_mixing_ratio | moist convective cloud water mixing ratio | kg kg-1 | 2 | real | kind_phys | out | F | +!! | cnvc | convective_cloud_cover | convective cloud cover | frac | 2 | real | kind_phys | out | F | +!! | imfshalcnv | flag_for_mass_flux_shallow_convection_scheme | flag for mass-flux shallow convection scheme | flag | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & + forcet,forceqv_spechum,phil,raincv,qv_spechum,t,cld1d, & + us,vs,t2di,w,qv2di_spechum,p2di,psuri, & + hbot,htop,kcnv,xland,hfx2,qfx2,clw, & + pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv,errmsg,errflg) +!------------------------------------------------------------- + implicit none + integer, parameter :: maxiens=1 + integer, parameter :: maxens=1 + integer, parameter :: maxens2=1 + integer, parameter :: maxens3=16 + integer, parameter :: ensdim=16 + integer, parameter :: imid_gf=1 ! testgf2 turn on middle gf conv. + integer, parameter :: ideep=1 + integer, parameter :: ichoice=0 ! 0 2 5 13 8 + !integer, parameter :: ichoicem=5 ! 0 2 5 13 + integer, parameter :: ichoicem=13 ! 0 2 5 13 + integer, parameter :: ichoice_s=3 ! 0 1 2 3 + real(kind=kind_phys), parameter :: aodccn=0.1 + real(kind=kind_phys) :: dts,fpi,fp + integer, parameter :: dicycle=0 ! diurnal cycle flag + integer, parameter :: dicycle_m=0 !- diurnal cycle flag + integer :: ishallow_g3 ! depend on imfshalcnv +!------------------------------------------------------------- + integer :: its,ite, jts,jte, kts,kte + integer, intent(in ) :: im,ix,km,ntrac,tottracer + + real(kind=kind_phys), dimension( ix , km ), intent(in ) :: forcet,forceqv_spechum,w,phil + real(kind=kind_phys), dimension( ix , km ), intent(inout ) :: t,us,vs + real(kind=kind_phys), dimension( ix ) :: rand_mom,rand_vmas + real(kind=kind_phys), dimension( ix,4 ) :: rand_clos + real(kind=kind_phys), dimension( ix , km, 11 ) :: gdc,gdc2 + real(kind=kind_phys), dimension( ix , km ), intent(out ) :: cnvw_moist,cnvc + real(kind=kind_phys), dimension( ix , km,tottracer+2 ), intent(inout ) :: clw + + integer, dimension (im), intent(inout) :: hbot,htop,kcnv + integer, dimension (im), intent(in) :: xland + real(kind=kind_phys), dimension (im), intent(in) :: pbl + integer, dimension (ix) :: tropics +! ruc variable + real(kind=kind_phys), dimension (im) :: hfx2,qfx2,psuri + real(kind=kind_phys), dimension (im,km) :: ud_mf,dd_mf,dt_mf + real(kind=kind_phys), dimension (im), intent(inout) :: raincv,cld1d + real(kind=kind_phys), dimension (ix,km) :: t2di,p2di + ! Specific humidity from FV3 + real(kind=kind_phys), dimension (ix,km), intent(in) :: qv2di_spechum + real(kind=kind_phys), dimension (ix,km), intent(inout) :: qv_spechum + ! Local water vapor mixing ratios and cloud water mixing ratios + real(kind=kind_phys), dimension (ix,km) :: qv2di, qv, forceqv, cnvw + ! + real(kind=kind_phys), dimension( im ),intent(in) :: garea + real(kind=kind_phys), intent(in ) :: dt + integer, intent(in ) :: imfshalcnv + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer, dimension(im),intent(inout) :: cactiv + integer, dimension(im) :: k22_shallow,kbcon_shallow,ktop_shallow + real(kind=kind_phys), dimension(im) :: ht + real(kind=kind_phys), dimension(im) :: dx + + real(kind=kind_phys), dimension (im,km) :: outt,outq,outqc,phh,subm,cupclw,cupclws + real(kind=kind_phys), dimension (im,km) :: dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm + real(kind=kind_phys), dimension (im,km) :: outts,outqs,outqcs,outu,outv,outus,outvs + real(kind=kind_phys), dimension (im,km) :: outtm,outqm,outqcm,submm,cupclwm + real(kind=kind_phys), dimension (im,km) :: cnvwt,cnvwts,cnvwtm + real(kind=kind_phys), dimension (im,km) :: hco,hcdo,zdo,zdd,hcom,hcdom,zdom + real(kind=kind_phys), dimension (km) :: zh + real(kind=kind_phys), dimension (im) :: tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi + real(kind=kind_phys), dimension (im) :: pret,prets,pretm,hexec + real(kind=kind_phys), dimension (im,10) :: forcing,forcing2 + + integer, dimension (im) :: kbcon, ktop,ierr,ierrs,ierrm,kpbli + integer, dimension (im) :: k22s,kbcons,ktops,k22,jmin,jminm + integer, dimension (im) :: kbconm,ktopm,k22m + + integer :: iens,ibeg,iend,jbeg,jend,n + integer :: ibegh,iendh,jbegh,jendh + integer :: ibegc,iendc,jbegc,jendc,kstop + real(kind=kind_phys) :: rho_dryar,temp + real(kind=kind_phys) :: pten,pqen,paph,zrho,pahfs,pqhfl,zkhvfl,pgeoh + + integer, parameter :: ipn = 0 + +! +! basic environmental input includes moisture convergence (mconv) +! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off +! convection for this call only and at that particular gridpoint +! + real(kind=kind_phys), dimension (im,km) :: qcheck,zo,t2d,q2d,po,p2d,rhoi + real(kind=kind_phys), dimension (im,km) :: tn,qo,tshall,qshall,dz8w,omeg + real(kind=kind_phys), dimension (im) :: ccn,z1,psur,cuten,cutens,cutenm + real(kind=kind_phys), dimension (im) :: umean,vmean,pmean + real(kind=kind_phys), dimension (im) :: xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv + + integer :: i,j,k,icldck,ipr,jpr,jpr_deep,ipr_deep + integer :: itf,jtf,ktf,iss,jss,nbegin,nend + integer :: high_resolution + real(kind=kind_phys) :: clwtot,clwtot1,excess,tcrit,tscl_kf,dp,dq,sub_spread,subcenter + real(kind=kind_phys) :: dsubclw,dsubclws,dsubclwm,ztm,ztq,hfm,qfm,rkbcon,rktop !-lxz + real(kind=kind_phys), dimension (im) :: flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep + character*50 :: ierrc(im),ierrcm(im) + character*50 :: ierrcs(im) +! ruc variable +! hfx2 -- sensible heat flux (k m/s), positive upward from sfc +! qfx2 -- latent heat flux (kg/kg m/s), positive upward from sfc +! gf needs them in w/m2. define hfx and qfx after simple unit conversion + real(kind=kind_phys), dimension (im) :: hfx,qfx + real(kind=kind_phys) tem,tem1,tf,tcr,tcrf + + parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) + !parameter (tf=263.16, tcr=273.16, tcrf=1.0/(tcr-tf)) + !parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) + !parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) ! as fim + ! initialize ccpp error handling variables + errmsg = '' + errflg = 0 +! +! Scale specific humidity to dry mixing ratio +! + ! state in before physics + qv2di = qv2di_spechum/(1.0_kind_phys-qv2di_spechum) + ! forcing by dynamics, based on state in + forceqv = forceqv_spechum/(1.0_kind_phys-qv2di_spechum) + ! current state (updated by preceeding physics) + qv = qv_spechum/(1.0_kind_phys-qv_spechum) +! +! +! these should be coming in from outside +! + rand_mom(:) = 0. + rand_vmas(:) = 0. + rand_clos(:,:) = 0. + its=1 + ite=im + jts=1 + jte=1 + kts=1 + kte=km + ktf=kte-1 +! + tropics(:)=0 +! +!> tuning constants for radiation coupling +! + tun_rad_shall(:)=.02 + tun_rad_mid(:)=.15 + tun_rad_deep(:)=.13 + edt(:)=0. + edtm(:)=0. + edtd(:)=0. + zdd(:,:)=0. + flux_tun(:)=5. + ccn(its:ite)=150. + ! + if (imfshalcnv == 3) then + ishallow_g3 = 1 + else + ishallow_g3 = 0 + end if + high_resolution=0 + subcenter=0. + iens=1 +! +! these can be set for debugging +! + ipr=0 + jpr=0 + ipr_deep=0 + jpr_deep= 0 !53322 ! 528196 !0 ! 1136 !0 !421755 !3536 +! +! + ibeg=its + iend=ite + tcrit=258. + + itf=ite + ktf=kte-1 + jtf=jte + ztm=0. + ztq=0. + hfm=0. + qfm=0. + ud_mf =0. + dd_mf =0. + dt_mf =0. + tau_ecmwf(:)=0. +! + j=1 + ht(:)=phil(:,1)/g + do i=its,ite + cld1d(i)=0. + zo(i,:)=phil(i,:)/g + dz8w(i,1)=zo(i,2)-zo(i,1) + zh(1)=0. + kpbli(i)=2 + do k=kts+1,ktf + dz8w(i,k)=zo(i,k+1)-zo(i,k) + enddo + do k=kts+1,ktf + zh(k)=zh(k-1)+dz8w(i,k-1) + if(zh(k).gt.pbl(i))then + kpbli(i)=max(2,k) + exit + endif + enddo + enddo + + do i= its,itf + forcing(i,:)=0. + forcing2(i,:)=0. + ccn(i)=100. + hbot(i) =kte + htop(i) =kts + raincv(i)=0. + xlandi(i)=real(xland(i)) +! if(abs(xlandi(i)-1.).le.1.e-3) tun_rad_shall(i)=.15 +! if(abs(xlandi(i)-1.).le.1.e-3) flux_tun(i)=1.5 + enddo + do i= its,itf + mconv(i)=0. + enddo + do k=kts,kte + do i= its,itf + omeg(i,k)=0. + zu(i,k)=0. + zum(i,k)=0. + zus(i,k)=0. + zd(i,k)=0. + zdm(i,k)=0. + enddo + enddo + + psur(:)=0.01*psuri(:) + do i=its,itf + ter11(i)=max(0.,ht(i)) + enddo + do k=kts,kte + do i=its,ite + cnvw(i,k)=0. + cnvc(i,k)=0. + gdc(i,k,1)=0. + gdc(i,k,2)=0. + gdc(i,k,3)=0. + gdc(i,k,4)=0. + gdc(i,k,7)=0. + gdc(i,k,8)=0. + gdc(i,k,9)=0. + gdc(i,k,10)=0. + gdc2(i,k,1)=0. + enddo + enddo + ierr(:)=0 + ierrm(:)=0 + ierrs(:)=0 + cuten(:)=0. + cutenm(:)=0. + cutens(:)=0. + ierrc(:)=" " + + kbcon(:)=0 + kbcons(:)=0 + kbconm(:)=0 + + ktop(:)=0 + ktops(:)=0 + ktopm(:)=0 + + xmb(:)=0. + xmb_dumm(:)=0. + xmbm(:)=0. + xmbs(:)=0. + xmbs2(:)=0. + + k22s(:)=0 + k22m(:)=0 + k22(:)=0 + + jmin(:)=0 + jminm(:)=0 + + pret(:)=0. + prets(:)=0. + pretm(:)=0. + + umean(:)=0. + vmean(:)=0. + pmean(:)=0. + + cupclw(:,:)=0. + cupclwm(:,:)=0. + cupclws(:,:)=0. + + cnvwt(:,:)=0. + cnvwts(:,:)=0. + + hco(:,:)=0. + hcom(:,:)=0. + hcdo(:,:)=0. + hcdom(:,:)=0. + + outt(:,:)=0. + outts(:,:)=0. + outtm(:,:)=0. + + outu(:,:)=0. + outus(:,:)=0. + outum(:,:)=0. + + outv(:,:)=0. + outvs(:,:)=0. + outvm(:,:)=0. + + outq(:,:)=0. + outqs(:,:)=0. + outqm(:,:)=0. + + outqc(:,:)=0. + outqcs(:,:)=0. + outqcm(:,:)=0. + + subm(:,:)=0. + dhdt(:,:)=0. + + do k=kts,ktf + do i=its,itf + p2d(i,k)=0.01*p2di(i,k) + po(i,k)=p2d(i,k) !*.01 + rhoi(i,k) = 100.*p2d(i,k)/(287.04*(t2di(i,k)*(1.+0.608*qv2di(i,k)))) + qcheck(i,k)=qv(i,k) + tn(i,k)=t(i,k)!+forcet(i,k)*dt + qo(i,k)=max(1.e-16,qv(i,k))!+forceqv(i,k)*dt + t2d(i,k)=t2di(i,k)-forcet(i,k)*dt + q2d(i,k)=max(1.e-16,qv2di(i,k)-forceqv(i,k)*dt) + if(qo(i,k).lt.1.e-16)qo(i,k)=1.e-16 + tshall(i,k)=t2d(i,k) + qshall(i,k)=q2d(i,k) + enddo + enddo +123 format(1x,i2,1x,2(1x,f8.0),1x,2(1x,f8.3),3(1x,e13.5)) + do i=its,itf + do k=kts,kpbli(i) + tshall(i,k)=t(i,k) + qshall(i,k)=max(1.e-16,qv(i,k)) + enddo + enddo +! +! converting hfx2 and qfx2 to w/m2 +! hfx=cp*rho*hfx2 +! qfx=xlv*qfx2 + do i=its,itf + hfx(i)=hfx2(i)*cp*rhoi(i,1) + qfx(i)=qfx2(i)*xlv*rhoi(i,1) + dx(i) = sqrt(garea(i)) + enddo +! + do i=its,itf + do k=kts,kpbli(i) + tn(i,k)=t(i,k) + qo(i,k)=max(1.e-16,qv(i,k)) + enddo + enddo + nbegin=0 + nend=0 + do i=its,itf + do k=kts,kpbli(i) + dhdt(i,k)=cp*(forcet(i,k)+(t(i,k)-t2di(i,k))/dt) + & + xlv*(forceqv(i,k)+(qv(i,k)-qv2di(i,k))/dt) +! tshall(i,k)=t(i,k) +! qshall(i,k)=qv(i,k) + enddo + enddo + + do k= kts+1,ktf-1 + do i = its,itf + if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then + dp=-.5*(p2d(i,k+1)-p2d(i,k-1)) + umean(i)=umean(i)+us(i,k)*dp + vmean(i)=vmean(i)+vs(i,k)*dp + pmean(i)=pmean(i)+dp + endif + enddo + enddo + do k=kts,ktf-1 + do i = its,itf + omeg(i,k)= w(i,k) !-g*rhoi(i,k)*w(i,k) +! dq=(q2d(i,k+1)-q2d(i,k)) +! mconv(i)=mconv(i)+omeg(i,k)*dq/g + enddo + enddo + do i = its,itf + if(mconv(i).lt.0.)mconv(i)=0. + enddo +! +!---- call cumulus parameterization +! + if(ishallow_g3.eq.1)then +! + do i=its,ite + ierrs(i)=0 + ierrm(i)=0 + enddo +! +!> if ishallow_g3=1, call shallow: cup_gf_sh() +! + call cu_gf_sh_run (us,vs, & +! input variables, must be supplied + zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli, & + rhoi,hfx,qfx,xlandi,ichoice_s,tcrit,dt, & +! input variables. ierr should be initialized to zero or larger than zero for +! turning off shallow convection for grid points + zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & +! output tendencies + outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & +! dimesnional variables + itf,ktf,its,ite, kts,kte,ipr,tropics) + + + do i=its,itf + if(xmbs(i).gt.0.)cutens(i)=1. + enddo + call neg_check('shallow',ipn,dt,qcheck,outqs,outts,outus,outvs, & + outqcs,prets,its,ite,kts,kte,itf,ktf,ktops) + endif + + ipr=0 + jpr_deep=0 !340765 +!> if imid_gf=1, call cup_gf() + if(imid_gf == 1)then + call cu_gf_deep_run( & + itf,ktf,its,ite, kts,kte & + ,dicycle_m & + ,ichoicem & + ,ipr & + ,ccn & + ,dt & + ,imid_gf & + ,kpbli & + ,dhdt & + ,xlandi & + + ,zo & + ,forcing2 & + ,t2d & + ,q2d & + ,ter11 & + ,tshall & + ,qshall & + ,p2d & + ,psur & + ,us & + ,vs & + ,rhoi & + ,hfx & + ,qfx & + ,dx & ! dx(im) + ,mconv & + ,omeg & + + ,cactiv & + ,cnvwtm & + ,zum & + ,zdm & ! hli + ,zdd & + ,edtm & + ,edtd & ! hli + ,xmbm & + ,xmb_dumm & + ,xmbs & + ,pretm & + ,outum & + ,outvm & + ,outtm & + ,outqm & + ,outqcm & + ,kbconm & + ,ktopm & + ,cupclwm & + ,ierrm & + ,ierrcm & +! the following should be set to zero if not available + ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist + ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist + ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist + ,0 & ! flag to what you want perturbed + ! 1 = momentum transport + ! 2 = normalized vertical mass flux profile + ! 3 = closures + ! more is possible, talk to developer or + ! implement yourself. pattern is expected to be + ! betwee -1 and +1 +#if ( wrf_dfi_radar == 1 ) + ,do_capsuppress,cap_suppress_j & +#endif + ,k22m & + ,jminm,tropics) + + do i=its,itf + do k=kts,ktf + qcheck(i,k)=qv(i,k) +outqs(i,k)*dt + enddo + enddo + call neg_check('mid',ipn,dt,qcheck,outqm,outtm,outum,outvm, & + outqcm,pretm,its,ite,kts,kte,itf,ktf,ktopm) + endif +!> if ideep=1, call cup_gf() + if(ideep.eq.1)then + call cu_gf_deep_run( & + itf,ktf,its,ite, kts,kte & + + ,dicycle & + ,ichoice & + ,ipr & + ,ccn & + ,dt & + ,0 & + + ,kpbli & + ,dhdt & + ,xlandi & + + ,zo & + ,forcing & + ,t2d & + ,q2d & + ,ter11 & + ,tn & + ,qo & + ,p2d & + ,psur & + ,us & + ,vs & + ,rhoi & + ,hfx & + ,qfx & + ,dx & !dx(im) + ,mconv & + ,omeg & + + ,cactiv & + ,cnvwt & + ,zu & + ,zd & + ,zdm & ! hli + ,edt & + ,edtm & ! hli + ,xmb & + ,xmbm & + ,xmbs & + ,pret & + ,outu & + ,outv & + ,outt & + ,outq & + ,outqc & + ,kbcon & + ,ktop & + ,cupclw & + ,ierr & + ,ierrc & +! the following should be set to zero if not available + ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist + ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist + ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist + ,0 & ! flag to what you want perturbed + ! 1 = momentum transport + ! 2 = normalized vertical mass flux profile + ! 3 = closures + ! more is possible, talk to developer or + ! implement yourself. pattern is expected to be + ! betwee -1 and +1 +#if ( wrf_dfi_radar == 1 ) + ,do_capsuppress,cap_suppress_j & +#endif + ,k22 & + ,jmin,tropics) + + jpr=0 + ipr=0 + do i=its,itf + do k=kts,ktf + qcheck(i,k)=qv(i,k) +(outqs(i,k)+outqm(i,k))*dt + enddo + enddo + call neg_check('deep',ipn,dt,qcheck,outq,outt,outu,outv, & + outqc,pret,its,ite,kts,kte,itf,ktf,ktop) +! + endif +! do i=its,itf +! kcnv(i)=0 +! if(pret(i).gt.0.)then +! cuten(i)=1. +! kcnv(i)= 1 !jmin(i) +! else +! kbcon(i)=0 +! ktop(i)=0 +! cuten(i)=0. +! endif ! pret > 0 +! if(pretm(i).gt.0.)then +! kcnv(i)= 1 !jmin(i) +! cutenm(i)=1. +! else +! kbconm(i)=0 +! ktopm(i)=0 +! cutenm(i)=0. +! endif ! pret > 0 +! enddo + do i=its,itf + kcnv(i)=0 + if(pretm(i).gt.0.)then + kcnv(i)= 1 !jmin(i) + cutenm(i)=1. + else + kbconm(i)=0 + ktopm(i)=0 + cutenm(i)=0. + endif ! pret > 0 + + if(pret(i).gt.0.)then + cuten(i)=1. + cutenm(i)=0. + pretm(i)=0. + kcnv(i)= 1 !jmin(i) + ktopm(i)=0 + kbconm(i)=0 + else + kbcon(i)=0 + ktop(i)=0 + cuten(i)=0. + endif ! pret > 0 + enddo +! + do i=its,itf + kstop=kts + if(ktopm(i).gt.kts .or. ktop(i).gt.kts)kstop=max(ktopm(i),ktop(i)) + if(ktops(i).gt.kts)kstop=max(kstop,ktops(i)) + + if(kstop.gt.2)then + htop(i)=kstop + if(kbcon(i).gt.2 .or. kbconm(i).gt.2)then + hbot(i)=max(kbconm(i),kbcon(i)) !jmin(i) + endif +!kbcon(i) + do k=kts,kstop + cnvc(i,k) = 0.04 * log(1. + 675. * zu(i,k) * xmb(i)) + & + 0.04 * log(1. + 675. * zum(i,k) * xmbm(i)) + & + 0.04 * log(1. + 675. * zus(i,k) * xmbs(i)) + cnvc(i,k) = min(cnvc(i,k), 0.6) + cnvc(i,k) = max(cnvc(i,k), 0.0) + cnvw(i,k)=cnvwt(i,k)*xmb(i)*dt+cnvwts(i,k)*xmbs(i)*dt+cnvwtm(i,k)*xmbm(i)*dt + ud_mf(i,k)=cuten(i)*zu(i,k)*xmb(i)*dt + dd_mf(i,k)=cuten(i)*zd(i,k)*edt(i)*xmb(i)*dt + t(i,k)=t(i,k)+dt*(cutens(i)*outts(i,k)+cutenm(i)*outtm(i,k)+outt(i,k)*cuten(i)) + qv(i,k)=max(1.e-16,qv(i,k)+dt*(cutens(i)*outqs(i,k)+cutenm(i)*outqm(i,k)+outq(i,k)*cuten(i))) + gdc(i,k,7)=sqrt(us(i,k)**2 +vs(i,k)**2) + us(i,k)=us(i,k)+outu(i,k)*cuten(i)*dt +outum(i,k)*cutenm(i)*dt +outus(i,k)*cutens(i)*dt + vs(i,k)=vs(i,k)+outv(i,k)*cuten(i)*dt +outvm(i,k)*cutenm(i)*dt +outvs(i,k)*cutens(i)*dt + + gdc(i,k,1)= max(0.,tun_rad_shall(i)*cupclws(i,k)*cutens(i)) ! my mod + gdc2(i,k,1)=max(0.,tun_rad_deep(i)*(cupclwm(i,k)*cutenm(i)+cupclw(i,k)*cuten(i))) + gdc(i,k,2)=(outt(i,k))*86400. + gdc(i,k,3)=(outtm(i,k))*86400. + gdc(i,k,4)=(outts(i,k))*86400. + gdc(i,k,7)=-(gdc(i,k,7)-sqrt(us(i,k)**2 +vs(i,k)**2))/dt + !gdc(i,k,8)=(outq(i,k))*86400.*xlv/cp + gdc(i,k,8)=(outqm(i,k)+outqs(i,k)+outq(i,k))*86400.*xlv/cp + gdc(i,k,9)=gdc(i,k,2)+gdc(i,k,3)+gdc(i,k,4) +! +!> calculate subsidence effect on clw +! + dsubclw=0. + dsubclwm=0. + dsubclws=0. + dp=100.*(p2d(i,k)-p2d(i,k+1)) + if (clw(i,k,2) .gt. -999.0 .and. clw(i,k+1,2) .gt. -999.0 )then + clwtot = clw(i,k,1) + clw(i,k,2) + clwtot1= clw(i,k+1,1) + clw(i,k+1,2) + dsubclw=((-edt(i)*zd(i,k+1)+zu(i,k+1))*clwtot1 & + -(-edt(i)*zd(i,k) +zu(i,k)) *clwtot )*g/dp + dsubclwm=((-edtm(i)*zdm(i,k+1)+zum(i,k+1))*clwtot1 & + -(-edtm(i)*zdm(i,k) +zum(i,k)) *clwtot )*g/dp + dsubclws=(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp + dsubclw=dsubclw+(zu(i,k+1)*clwtot1-zu(i,k)*clwtot)*g/dp + dsubclwm=dsubclwm+(zum(i,k+1)*clwtot1-zum(i,k)*clwtot)*g/dp + dsubclws=dsubclws+(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp + endif + tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & + +outqcm(i,k)*cutenm(i) & +! +dsubclw*xmb(i)+dsubclws*xmbs(i)+dsubclwm*xmbm(i) & + ) + tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) + if (clw(i,k,2) .gt. -999.0) then + clw(i,k,1) = max(0.,clw(i,k,1) + tem * tem1) ! ice + clw(i,k,2) = max(0.,clw(i,k,2) + tem *(1.0-tem1)) ! water + else + clw(i,k,1) = max(0.,clw(i,k,1) + tem) + endif + enddo ! kstop loop + + gdc(i,1,10)=forcing(i,1) + gdc(i,2,10)=forcing(i,2) + gdc(i,3,10)=forcing(i,3) + gdc(i,4,10)=forcing(i,4) + gdc(i,5,10)=forcing(i,5) + gdc(i,6,10)=forcing(i,6) + gdc(i,7,10)=forcing(i,7) + gdc(i,8,10)=forcing(i,8) + gdc(i,10,10)=xmb(i) + gdc(i,11,10)=xmbm(i) + gdc(i,12,10)=xmbs(i) + gdc(i,13,10)=hfx(i) + gdc(i,15,10)=qfx(i) + gdc(i,16,10)=pret(i)*3600. + if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) + endif ! kstop if + enddo + + do i=its,itf + if(pret(i).gt.0.)then + cactiv(i)=1 + raincv(i)=.001*(cutenm(i)*pretm(i)+cutens(i)*prets(i)+cuten(i)*pret(i))*dt + else + cactiv(i)=0 + if(pretm(i).gt.0)raincv(i)=.001*cutenm(i)*pretm(i)*dt + endif ! pret > 0 + enddo + 100 continue +! +! Scale dry mixing ratios for water wapor and cloud water to specific humidy / moist mixing ratios +! + qv_spechum = qv/(1.0_kind_phys+qv) + cnvw_moist = cnvw/(1.0_kind_phys+qv) +! + end subroutine cu_gf_driver_run +end module cu_gf_driver diff --git a/cu_gf_sh.F90 b/cu_gf_sh.F90 new file mode 100644 index 000000000..173de662e --- /dev/null +++ b/cu_gf_sh.F90 @@ -0,0 +1,937 @@ +! module cup_gf_sh will call shallow convection as described in grell and +! freitas (2016). input variables are: +! zo height at model levels +! t,tn temperature without and with forcing at model levels +! q,qo mixing ratio without and with forcing at model levels +! po pressure at model levels (mb) +! psur surface pressure (mb) +! z1 surface height +! dhdt forcing for boundary layer equilibrium +! hfx,qfx in w/m2 (positive, if upward from sfc) +! kpbl level of boundaty layer height +! xland land mask (1. for land) +! ichoice which closure to choose +! 1: old g +! 2: zws +! 3: dhdt +! 0: average +! tcrit parameter for water/ice conversion (258) +! +!!!!!!!!!!!! variables that are diagnostic +! +! zuo normalized mass flux profile +! xmb_out base mass flux +! kbcon convective cloud base +! ktop cloud top +! k22 level of updraft originating air +! ierr error flag +! ierrc error description +! +!!!!!!!!!!!! variables that are on output +! outt temperature tendency (k/s) +! outq mixing ratio tendency (kg/kg/s) +! outqc cloud water/ice tendency (kg/kg/s) +! pre precip rate (mm/s) +! cupclw incloud mixing ratio of cloudwater/ice (for radiation) +! this needs heavy tuning factors, since cloud fraction is +! not included (kg/kg) +! cnvwt required for gfs physics +! +! itf,ktf,its,ite, kts,kte are dimensions +! ztexec,zqexec excess temperature and moisture for updraft +module cu_gf_sh + use machine , only : kind_phys + !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 + real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 + real(kind=kind_phys), parameter:: g =9.81 + real(kind=kind_phys), parameter:: cp =1004. + real(kind=kind_phys), parameter:: xlv=2.5e6 + real(kind=kind_phys), parameter:: r_v=461. + real(kind=kind_phys), parameter:: c0_shal=.001 + real(kind=kind_phys), parameter:: fluxtune=1.5 + +contains + + subroutine cu_gf_sh_run ( & +! input variables, must be supplied + us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & + hfx,qfx,xland,ichoice,tcrit,dtime, & +! input variables. ierr should be initialized to zero or larger than zero for +! turning off shallow convection for grid points + zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & +! output tendencies + outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & +! dimesnional variables + itf,ktf,its,ite, kts,kte,ipr,tropics) +! +! this module needs some subroutines from gf_deep +! + use cu_gf_deep,only:cup_env,cup_env_clev,get_cloud_bc,cup_minimi, & + get_inversion_layers,rates_up_pdf,get_cloud_bc, & + cup_up_aa0,cup_kbcon,get_lateral_massflux + implicit none + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte,ipr + logical :: make_calc_for_xk = .true. + integer, intent (in ) :: & + ichoice + ! + ! + ! + ! outtem = output temp tendency (per s) + ! outq = output q tendency (per s) + ! outqc = output qc tendency (per s) + ! pre = output precip + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + xmb_out + integer, dimension (its:ite) & + ,intent (inout ) :: & + ierr + integer, dimension (its:ite) & + ,intent (out ) :: & + kbcon,ktop,k22 + integer, dimension (its:ite) & + ,intent (in ) :: & + kpbl,tropics + ! + ! basic environmental input includes a flag (ierr) to turn off + ! convection for this call only and at that particular gridpoint + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + t,po,tn,dhdt,rho,us,vs + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + q,qo + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + xland,z1,psur,hfx,qfx + + real(kind=kind_phys) & + ,intent (in ) :: & + dtime,tcrit + ! + !***************** the following are your basic environmental + ! variables. they carry a "_cup" if they are + ! on model cloud levels (staggered). they carry + ! an "o"-ending (z becomes zo), if they are the forced + ! variables. + ! + ! z = heights of model levels + ! q = environmental mixing ratio + ! qes = environmental saturation mixing ratio + ! t = environmental temp + ! p = environmental pressure + ! he = environmental moist static energy + ! hes = environmental saturation moist static energy + ! z_cup = heights of model cloud levels + ! q_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! p_cup = environmental pressure + ! he_cup = moist static energy on model cloud levels + ! hes_cup = saturation moist static energy on model cloud levels + ! gamma_cup = gamma on model cloud levels + ! dby = buoancy term + ! entr = entrainment rate + ! bu = buoancy term + ! gamma_cup = gamma on model cloud levels + ! qrch = saturation q in cloud + ! pwev = total normalized integrated evaoprate (i2) + ! z1 = terrain elevation + ! psur = surface pressure + ! zu = updraft normalized mass flux + ! kbcon = lfc of parcel from k22 + ! k22 = updraft originating level + ! ichoice = flag if only want one closure (usually set to zero!) + ! dby = buoancy term + ! ktop = cloud top (output) + ! xmb = total base mass flux + ! hc = cloud moist static energy + ! hkb = moist static energy at originating level + + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + entr_rate_2d,he,hes,qes,z, & + heo,heso,qeso,zo, & + xhe,xhes,xqes,xz,xt,xq, & + qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & + qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup, & + tn_cup, & + xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & + xt_cup,dby,hc,zu, & + dbyo,qco,pwo,hco,qrco, & + dbyt,xdby,xhc,xzu, & + + ! cd = detrainment function for updraft + ! dellat = change of temperature per unit mass flux of cloud ensemble + ! dellaq = change of q per unit mass flux of cloud ensemble + ! dellaqc = change of qc per unit mass flux of cloud ensemble + + cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup + + ! aa0 cloud work function for downdraft + ! aa0 = cloud work function without forcing effects + ! aa1 = cloud work function with forcing effects + ! xaa0 = cloud work function with cloud effects (ensemble dependent) + + real(kind=kind_phys), dimension (its:ite) :: & + zws,ztexec,zqexec,pre,aa1,aa0,xaa0,hkb, & + flux_tun,hkbo,xhkb, & + rand_vmas,xmbmax,xmb, & + cap_max,entr_rate, & + cap_max_increment,lambau + integer, dimension (its:ite) :: & + kstabi,xland1,kbmax,ktopx + + integer :: & + kstart,i,k,ki + real(kind=kind_phys) :: & + dz,mbdt,zkbmax, & + cap_maxs,trash,trash2,frh + + real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas + + real(kind=kind_phys) xff_shal(3),blqe,xkshal + character*50 :: ierrc(its:ite) + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru + real(kind=kind_phys) :: c_up,x_add,qaver,dts,fp,fpi + real(kind=kind_phys), dimension (its:ite,kts:kte) :: c1d,dtempdz + integer, dimension (its:ite,kts:kte) :: k_inv_layers + integer, dimension (its:ite) :: start_level, pmin_lev + start_level(:)=0 + rand_vmas(:)=0. + flux_tun=fluxtune + lambau(:)=2. + c1d(:,:)=0. + do i=its,itf + xland1(i)=int(xland(i)+.001) ! 1. + ktopx(i)=0 + if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then + xland1(i)=0 +! ierr(i)=100 + endif + pre(i)=0. + xmb_out(i)=0. + cap_max_increment(i)=25. + ierrc(i)=" " + entr_rate(i) = 1.e-3 !9.e-5 ! 1.75e-3 ! 1.2e-3 ! .2/50. + enddo +! +!--- initial entrainment rate (these may be changed later on in the +!--- program +! + +! +!--- initial detrainmentrates +! + do k=kts,ktf + do i=its,itf + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + up_massentru(i,k)=0. + up_massdetru(i,k)=0. + z(i,k)=zo(i,k) + xz(i,k)=zo(i,k) + qrco(i,k)=0. + pwo(i,k)=0. + cd(i,k)=.1*entr_rate(i) + dellaqc(i,k)=0. + cupclw(i,k)=0. + enddo + enddo +! +!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft +! +!--- minimum depth (m), clouds must have +! +! +!--- maximum depth (mb) of capping +!--- inversion (larger cap = no convection) +! + cap_maxs=175. + do i=its,itf + kbmax(i)=1 + aa0(i)=0. + aa1(i)=0. + enddo + do i=its,itf + cap_max(i)=cap_maxs + ztexec(i) = 0. + zqexec(i) = 0. + zws(i) = 0. + enddo + do i=its,itf + !- buoyancy flux (h+le) + buo_flux= (hfx(i)/cp+0.608*t(i,1)*qfx(i)/xlv)/rho(i,1) + pgeoh = zo(i,2)*g + !-convective-scale velocity w* + zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,2)*g/t(i,1)) + if(zws(i) > tiny(pgeoh)) then + !-convective-scale velocity w* + zws(i) = 1.2*zws(i)**.3333 + !- temperature excess + ztexec(i) = max(flux_tun(i)*hfx(i)/(rho(i,1)*zws(i)*cp),0.0) + !- moisture excess + zqexec(i) = max(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.) + endif + !- zws for shallow convection closure (grant 2001) + !- height of the pbl + zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i))) + zws(i) = 1.2*zws(i)**.3333 + zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct + + enddo + +! +!--- max height(m) above ground where updraft air can originate +! + zkbmax=3000. +! +!--- calculate moist static energy, heights, qes +! + call cup_env(z,qes,he,hes,t,q,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + +! +!--- environmental values on cloud levels +! + call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, & + hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, & + heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) + do i=its,itf + if(ierr(i).eq.0)then + u_cup(i,kts)=us(i,kts) + v_cup(i,kts)=vs(i,kts) + do k=kts+1,ktf + u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) + v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) + enddo + endif + enddo + + do i=its,itf + if(ierr(i).eq.0)then +! + do k=kts,ktf + if(zo_cup(i,k).gt.zkbmax+z1(i))then + kbmax(i)=k + go to 25 + endif + enddo + 25 continue +! + kbmax(i)=min(kbmax(i),ktf/2) + endif + enddo + +! +! +! +!------- determine level with highest moist static energy content - k22 +! + do 36 i=its,itf + if(kpbl(i).gt.3)cap_max(i)=po_cup(i,kpbl(i)) + if(ierr(i) == 0)then + k22(i)=maxloc(heo_cup(i,2:kbmax(i)),1) + k22(i)=max(2,k22(i)) + if(k22(i).gt.kbmax(i))then + ierr(i)=2 + ierrc(i)="could not find k22" + ktop(i)=0 + k22(i)=0 + kbcon(i)=0 + endif + endif + 36 continue +! +!--- determine the level of convective cloud base - kbcon +! + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + call get_cloud_bc(kte,heo_cup(i,1:kte),hkbo(i),k22(i),x_add) + endif ! ierr + enddo + +!joe-georg and saulo's new idea: + do i=its,itf + do k=kts,ktf + dbyo(i,k)= 0. !hkbo(i)-heso_cup(i,k) + enddo + enddo + + + call cup_kbcon(ierrc,cap_max_increment,5,k22,kbcon,heo_cup,heso_cup, & + hkbo,ierr,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + 0,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,0) +!--- get inversion layers for cloud tops + call cup_minimi(heso_cup,kbcon,kbmax,kstabi,ierr, & + itf,ktf, & + its,ite, kts,kte) +! + call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers,& + kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) +! +! + do i=its,itf + entr_rate_2d(i,:)=entr_rate(i) + if(ierr(i) == 0)then + start_level(i)=k22(i) + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + if(kbcon(i).gt.ktf-4)then + ierr(i)=231 + endif + do k=kts,ktf + frh = 2.*min(qo_cup(i,k)/qeso_cup(i,k),1.) + entr_rate_2d(i,k)=entr_rate(i) !*(2.3-frh) + cd(i,k)=.1*entr_rate_2d(i,k) + enddo +! +! first estimate for shallow convection +! + ktop(i)=1 + kstart=kpbl(i) + if(kpbl(i).lt.5)kstart=kbcon(i) +! if(k_inv_layers(i,1).gt.0)then +!! ktop(i)=min(k_inv_layers(i,1),k_inv_layers(i,2)) + if(k_inv_layers(i,1).gt.0 .and. & + (po_cup(i,kstart)-po_cup(i,k_inv_layers(i,1))).lt.200.)then + ktop(i)=k_inv_layers(i,1) + else + do k=kbcon(i)+1,ktf + if((po_cup(i,kstart)-po_cup(i,k)).gt.200.)then + ktop(i)=k + exit + endif + enddo + endif + endif + enddo +! get normalized mass flux profile + call rates_up_pdf(rand_vmas,ipr,'shallow',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & + xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopx,kbcon,pmin_lev) + do i=its,itf + if(ierr(i).eq.0)then +! do k=maxloc(zuo(i,:),1),1,-1 ! ktop(i)-1,1,-1 +! if(zuo(i,k).lt.1.e-6)then +! k22(i)=k+1 +! start_level(i)=k22(i) +! exit +! endif +! enddo + if(k22(i).gt.1)then + do k=1,k22(i)-1 + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif + do k=maxloc(zuo(i,:),1),ktop(i) + if(zuo(i,k).lt.1.e-6)then + ktop(i)=k-1 + exit + endif + enddo + do k=k22(i),ktop(i) + xzu(i,k)= zuo(i,k) + zu(i,k)= zuo(i,k) + enddo + do k=ktop(i)+1,ktf + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + k22(i)=max(2,k22(i)) + endif + enddo +! +! calculate mass entrainment and detrainment +! + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,'shallow',kbcon,k22,up_massentru,up_massdetru,lambau) + + do k=kts,ktf + do i=its,itf + hc(i,k)=0. + qco(i,k)=0. + qrco(i,k)=0. + dby(i,k)=0. + hco(i,k)=0. + dbyo(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i) /= 0) cycle + do k=1,start_level(i) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + enddo + do k=1,start_level(i)-1 + hc(i,k)=he_cup(i,k) + hco(i,k)=heo_cup(i,k) + enddo + k=start_level(i) + hc(i,k)=hkb(i) + hco(i,k)=hkbo(i) + enddo +! +! + do 42 i=its,itf + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle + do k=start_level(i)+1,ktop(i) + hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & + up_massentr(i,k-1)*he(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*uc(i,k-1)+ & + up_massentr(i,k-1)*us(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*vc(i,k-1)+ & + up_massentr(i,k-1)*vs(i,k-1))/ & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + dby(i,k)=max(0.,hc(i,k)-hes_cup(i,k)) + hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & + up_massentro(i,k-1)*heo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + dbyo(i,k)=hco(i,k)-heso_cup(i,k) + dz=zo_cup(i,k+1)-zo_cup(i,k) + if(k.ge.kbcon(i))dbyt(i,k)=dbyt(i,k-1)+dbyo(i,k)*dz + enddo + ki=maxloc(dbyt(i,:),1) + if(ktop(i).gt.ki+1)then + ktop(i)=ki+1 + zuo(i,ktop(i)+1:ktf)=0. + zu(i,ktop(i)+1:ktf)=0. + cd(i,ktop(i)+1:ktf)=0. + up_massdetro(i,ktop(i))=zuo(i,ktop(i)) +! up_massentro(i,ktop(i))=0. + up_massentro(i,ktop(i):ktf)=0. + up_massdetro(i,ktop(i)+1:ktf)=0. + entr_rate_2d(i,ktop(i)+1:ktf)=0. + +! ierr(i)=423 + endif + + if(ktop(i).lt.kbcon(i)+1)then + ierr(i)=5 + ierrc(i)='ktop is less than kbcon+1' + go to 42 + endif + if(ktop(i).gt.ktf-2)then + ierr(i)=5 + ierrc(i)="ktop is larger than ktf-2" + go to 42 + endif +! + call get_cloud_bc(kte,qo_cup (i,1:kte),qaver,k22(i)) + qaver = qaver + zqexec(i) + do k=1,start_level(i)-1 + qco (i,k)= qo_cup(i,k) + enddo + k=start_level(i) + qco (i,k)= qaver +! + do k=start_level(i)+1,ktop(i) + trash=qeso_cup(i,k)+(1./xlv)*(gammao_cup(i,k) & + /(1.+gammao_cup(i,k)))*dbyo(i,k) + !- total water liq+vapour + trash2 = qco(i,k-1) ! +qrco(i,k-1) + qco (i,k)= (trash2* ( zuo(i,k-1)-0.5*up_massdetr(i,k-1)) + & + up_massentr(i,k-1)*qo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + + if(qco(i,k)>=trash ) then + dz=z_cup(i,k)-z_cup(i,k-1) + ! cloud liquid water +! qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) +! qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1_shal)*dz) + qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) + c1d(i,k-1)=10.*up_massdetr(i,k-1)*.5*(qrco(i,k-1)+qrco(i,k)) + qrco(i,k)= qrco(i,k)-c1d(i,k-1)*dz*qrco(i,k) + if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 + qrco(i,k)=0. + c1d(i,k-1)=1./dz + endif + pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) + ! cloud water vapor + qco (i,k)= trash+qrco(i,k) + + else + qrco(i,k)= 0.0 + endif + cupclw(i,k)=qrco(i,k) + enddo + trash=0. + trash2=0. + do k=k22(i)+1,ktop(i) + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp + trash2=trash2+entr_rate_2d(i,k) + qco(i,k)=qco(i,k)-qrco(i,k) + enddo + do k=k22(i)+1,max(kbcon(i),k22(i)+1) + trash=trash+entr_rate_2d(i,k) + enddo + do k=ktop(i)+1,ktf-1 + hc (i,k)=hes_cup (i,k) + hco (i,k)=heso_cup(i,k) + qco (i,k)=qeso_cup(i,k) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + qrco(i,k)=0. + dby (i,k)=0. + dbyo(i,k)=0. + zu (i,k)=0. + xzu (i,k)=0. + zuo (i,k)=0. + enddo + 42 continue +! +!--- calculate workfunctions for updrafts +! + if(make_calc_for_xk) then + call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, its,ite, kts,kte) + call cup_up_aa0(aa1,zo,zuo,dbyo,gammao_cup,tn_cup, & + kbcon,ktop,ierr, & + itf,ktf, its,ite, kts,kte) + do i=its,itf + if(ierr(i) == 0)then + if(aa1(i) <= 0.)then + ierr(i)=17 + ierrc(i)="cloud work function zero" + endif + endif + enddo + endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! +!--- change per unit mass that a model cloud would modify the environment +! +!--- 1. in bottom layer +! + do k=kts,kte + do i=its,itf + dellah(i,k)=0. + dellaq(i,k)=0. + dellaqc(i,k)=0. + dellu (i,k)=0. + dellv (i,k)=0. + enddo + enddo +! +!---------------------------------------------- cloud level ktop +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1 +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level k+2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1 +! +!---------------------------------------------- cloud level k+1 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k +! +!---------------------------------------------- cloud level k +! +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level 3 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 2 +! +!---------------------------------------------- cloud level 2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 1 + trash2=0. + do i=its,itf + if(ierr(i).eq.0)then + dp=100.*(po_cup(i,1)-po_cup(i,2)) + dellu(i,1)= -zuo(i,2)*(uc (i,2)-u_cup(i,2)) *g/dp + dellv(i,1)= -zuo(i,2)*(vc (i,2)-v_cup(i,2)) *g/dp + dellah(i,1)=-zuo(i,2)*(hco(i,2)-heo_cup(i,2))*g/dp + + dellaq (i,1)=-zuo(i,2)*(qco(i,2)-qo_cup(i,2))*g/dp + + do k=k22(i),ktop(i) + ! entrainment/detrainment for updraft + entup=up_massentro(i,k) + detup=up_massdetro(i,k) + totmas=detup-entup+zuo(i,k+1)-zuo(i,k) + if(abs(totmas).gt.1.e-6)then + write(0,*)'*********************',i,k,totmas + write(0,*)k22(i),kbcon(i),ktop(i) + endif + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + dellah(i,k) =-(zuo(i,k+1)*(hco(i,k+1)-heo_cup(i,k+1) )- & + zuo(i,k )*(hco(i,k )-heo_cup(i,k ) ))*g/dp + + !-- take out cloud liquid water for detrainment + dz=zo_cup(i,k+1)-zo_cup(i,k) + if(k.lt.ktop(i) .and. c1d(i,k) > 0)then + dellaqc(i,k)= zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g ! detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp + else + dellaqc(i,k)=detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! dellaqc(i,k)= detup*qrco(i,k) *g/dp + endif + + !-- condensation source term = detrained + flux divergence of + !-- cloud liquid water (qrco) + c_up = dellaqc(i,k)+(zuo(i,k+1)* qrco(i,k+1) - & + zuo(i,k )* qrco(i,k ) )*g/dp +! c_up = dellaqc(i,k) + !-- water vapor budget (flux divergence of q_up-q_env - condensation + !term) + dellaq(i,k) =-(zuo(i,k+1)*(qco(i,k+1)-qo_cup(i,k+1) ) - & + zuo(i,k )*(qco(i,k )-qo_cup(i,k ) ) )*g/dp & + - c_up - 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp + dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) - & + zuo(i,k )*(uc (i,k )-u_cup(i,k ) ) )*g/dp + dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) - & + zuo(i,k )*(vc (i,k )-v_cup(i,k ) ) )*g/dp + + enddo + endif + enddo + +! +!--- using dellas, calculate changed environmental profiles +! + mbdt=.5 !3.e-4 + + do k=kts,ktf + do i=its,itf + dellat(i,k)=0. + if(ierr(i)/=0)cycle + xhe(i,k)=dellah(i,k)*mbdt+heo(i,k) + xq (i,k)=max(1.e-16,(dellaq(i,k)+dellaqc(i,k))*mbdt+qo(i,k)) + dellat(i,k)=(1./cp)*(dellah(i,k)-xlv*(dellaq(i,k))) + xt (i,k)= (-dellaqc(i,k)*xlv/cp+dellat(i,k))*mbdt+tn(i,k) + xt (i,k)= max(190.,xt(i,k)) + + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then +! xhkb(i)=hkbo(i)+(dellah(i,k22(i)))*mbdt + xhe(i,ktf)=heo(i,ktf) + xq(i,ktf)=qo(i,ktf) + xt(i,ktf)=tn(i,ktf) + endif + enddo +! +! + if(make_calc_for_xk) then +! +!--- calculate moist static energy, heights, qes +! + call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) +! +!--- environmental values on cloud levels +! + call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, & + xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) +! +! +!**************************** static control + do k=kts,ktf + do i=its,itf + xhc(i,k)=0. + xdby(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,xhe_cup (i,1:kte),xhkb (i),k22(i),x_add) + do k=1,start_level(i)-1 + xhc(i,k)=xhe_cup(i,k) + enddo + k=start_level(i) + xhc(i,k)=xhkb(i) + endif !ierr + enddo +! +! + do i=its,itf + if(ierr(i).eq.0)then + xzu(i,1:ktf)=zuo(i,1:ktf) + do k=start_level(i)+1,ktop(i) + xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1)+ & + up_massentro(i,k-1)*xhe(i,k-1)) / & + (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + xdby(i,k)=xhc(i,k)-xhes_cup(i,k) + enddo + do k=ktop(i)+1,ktf + xhc (i,k)=xhes_cup(i,k) + xdby(i,k)=0. + xzu (i,k)=0. + enddo + endif + enddo + +! +!--- workfunctions for updraft +! + call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) +! + endif +! +! +! now for shallow forcing +! + do i=its,itf + xmb(i)=0. + xff_shal(1:3)=0. + if(ierr(i).eq.0)then + xmbmax(i)=1.0 +! xmbmax(i)=100.*(p(i,kbcon(i))-p(i,kbcon(i)+1))/(g*dtime) +! +!-stabilization closure + xkshal=(xaa0(i)-aa1(i))/mbdt + if(xkshal.le.0.and.xkshal.gt.-.01*mbdt) & + xkshal=-.01*mbdt + if(xkshal.gt.0.and.xkshal.lt.1.e-2) & + xkshal=1.e-2 + + xff_shal(1)=max(0.,-(aa1(i)-aa0(i))/(xkshal*dtime)) +! +!- closure from grant (2001) + xff_shal(2)=.03*zws(i) +!- boundary layer qe closure + blqe=0. + trash=0. + do k=1,kbcon(i) + blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g + enddo + trash=max((hc(i,kbcon(i))-he_cup(i,kbcon(i))),1.e1) + xff_shal(3)=max(0.,blqe/trash) + xff_shal(3)=min(xmbmax(i),xff_shal(3)) +!- average + xmb(i)=(xff_shal(1)+xff_shal(2)+xff_shal(3))/3. + xmb(i)=min(xmbmax(i),xmb(i)) + if(ichoice > 0)xmb(i)=min(xmbmax(i),xff_shal(ichoice)) + if(xmb(i) <= 0.)then + ierr(i)=21 + ierrc(i)="21" + endif + endif + if(ierr(i).ne.0)then + k22 (i)=0 + kbcon(i)=0 + ktop (i)=0 + xmb (i)=0. + outt (i,:)=0. + outu (i,:)=0. + outv (i,:)=0. + outq (i,:)=0. + outqc(i,:)=0. + else if(ierr(i).eq.0)then + xmb_out(i)=xmb(i) +! +! final tendencies +! + pre(i)=0. + do k=2,ktop(i) + outt (i,k)= dellat (i,k)*xmb(i) + outq (i,k)= dellaq (i,k)*xmb(i) + outqc(i,k)= dellaqc(i,k)*xmb(i) + pre (i) = pre(i)+pwo(i,k)*xmb(i) + enddo + outt (i,1)= dellat (i,1)*xmb(i) + outq (i,1)= dellaq (i,1)*xmb(i) + outu(i,1)=dellu(i,1)*xmb(i) + outv(i,1)=dellv(i,1)*xmb(i) + do k=kts+1,ktop(i) + outu(i,k)=.25*(dellu(i,k-1)+2.*dellu(i,k)+dellu(i,k+1))*xmb(i) + outv(i,k)=.25*(dellv(i,k-1)+2.*dellv(i,k)+dellv(i,k+1))*xmb(i) + enddo + + endif + enddo +! +! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) +! + do i=its,itf + if(ierr(i).eq.0) then + dts=0. + fpi=0. + do k=kts,ktop(i) + dp=(po_cup(i,k)-po_cup(i,k+1))*100. +!total ke dissiptaion estimate + dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g +! fpi needed for calcualtion of conversion to pot. energyintegrated + fpi = fpi +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp + enddo + if(fpi.gt.0.)then + do k=kts,ktop(i) + fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi + outt(i,k)=outt(i,k)+fp*dts*g/cp + enddo + endif + endif + enddo +! +! done shallow +!--------------------------done------------------------------ +! +! do k=1,30 +! print*,'hlisq',qco(1,k),qrco(1,k),pwo(1,k) +! enddo + + end subroutine cu_gf_sh_run +end module cu_gf_sh diff --git a/module_bl_mynn.F90 b/module_bl_mynn.F90 new file mode 100644 index 000000000..ff8e6619a --- /dev/null +++ b/module_bl_mynn.F90 @@ -0,0 +1,6100 @@ +!WRF:MODEL_LAYER:PHYSICS +! +! translated from NN f77 to F90 and put into WRF by Mariusz Pagowski +! NOAA/GSD & CIRA/CSU, Feb 2008 +! changes to original code: +! 1. code is 1D (in z) +! 2. no advection of TKE, covariances and variances +! 3. Cranck-Nicholson replaced with the implicit scheme +! 4. removed terrain dependent grid since input in WRF in actual +! distances in z[m] +! 5. cosmetic changes to adhere to WRF standard (remove common blocks, +! intent etc) +!------------------------------------------------------------------- +!Modifications implemented by Joseph Olson and Jaymes Kenyon NOAA/GSD/MDB - CU/CIRES +! +! Departures from original MYNN (Nakanish & Niino 2009) +! 1. Addition of BouLac mixing length in the free atmosphere. +! 2. Changed the turbulent mixing length to be integrated from the +! surface to the top of the BL + a transition layer depth. +! v3.4.1: Option to use Kitamura/Canuto modification which removes +! the critical Richardson number and negative TKE (default). +! Hybrid PBL height diagnostic, which blends a theta-v-based +! definition in neutral/convective BL and a TKE-based definition +! in stable conditions. +! TKE budget output option (bl_mynn_tkebudget) +! v3.5.0: TKE advection option (bl_mynn_tkeadvect) +! v3.5.1: Fog deposition related changes. +! v3.6.0: Removed fog deposition from the calculation of tendencies +! Added mixing of qc, qi, qni +! Added output for wstar, delta, TKE_PBL, & KPBL for correct +! coupling to shcu schemes +! v3.8.0: Added subgrid scale cloud output for coupling to radiation +! schemes (activated by setting icloud_bl =1 in phys namelist). +! Added WRF_DEBUG prints (at level 3000) +! Added Tripoli and Cotton (1981) correction. +! Added namelist option bl_mynn_cloudmix to test effect of mixing +! cloud species (default = 1: on). +! Added mass-flux option (bl_mynn_edmf, = 1 for DMP mass-flux, 0: off). +! Related options: +! bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme +! bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme +! Added mixing length option (bl_mynn_mixlength, see notes below) +! Added more sophisticated saturation checks, following Thompson scheme +! Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau +! and Bechtold (2002, JAS, with mods) +! Added capability to mix chemical species when env variable +! WRF_CHEM = 1, thanks to Wayne Angevine. +! Added scale-aware mixing length, following Junshi Ito's work +! Ito et al. (2015, BLM). +! v3.9.0 Improvement to the mass-flux scheme (dynamic number of plumes, +! better plume/cloud depth, significant speed up, better cloud +! fraction). +! Added Stochastic Parameter Perturbation (SPP) implementation. +! Many miscellaneous tweaks to the mixing lengths and stratus +! component of the subgrid clouds. +! v.4.0 Removed or added alternatives to WRF-specific functions/modules +! for the sake of portability to other models. +! the sake of portability to other models. +! Further refinement of mass-flux scheme from SCM experiments with +! Wayne Angevine: switch to linear entrainment and back to +! Simpson and Wiggert-type w-equation. +! Addition of TKE production due to radiation cooling at top of +! clouds (proto-version); not activated by default. +! Some code rewrites to move if-thens out of loops in an attempt to +! improve computational efficiency. +! New tridiagonal solver, which is supposedly 14% faster and more +! conservative. Impact seems very small. +! Many miscellaneous tweaks to the mixing lengths and stratus +! component of the subgrid-scale (SGS) clouds. +! v4.1 Big improvements in downward SW radiation due to revision of subgrid clouds +! - better cloud fraction and subgrid scale mixing ratios. +! - may experience a small cool bias during the daytime now that high +! SW-down bias is greatly reduced... +! Some tweaks to increase the turbulent mixing during the daytime for +! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact). +! Improved ensemble spread from changes to SPP in MYNN +! - now perturbing eddy diffusivity and eddy viscosity directly +! - now perturbing background rh (in SGS cloud calc only) +! - now perturbing entrainment rates in mass-flux scheme +! Added IF checks (within IFDEFS) to protect mixchem code from being used +! when HRRR smoke is used (no impact on regular non-wrf chem use) +! Important bug fix for wrf chem when transporting chemical species in MF scheme +! Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2) +! Removed unused stochastic code for mass-flux scheme +! Changed mass-flux scheme to be integrated on interface levels instead of +! mass levels - impact is small +! Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option. +! - activated with bl_mynn_mixscalars = 1; this sets scalar_pblmix = 0 +! - added tridagonal solver used in scalar_pblmix option to duplicate tendencies +! - this alone changes the interface call considerably from v4.0. +! Slight revision to TKE production due to radiation cooling at top of clouds +! Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998, JAS). +! - improves TKE in SGS clouds +! Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp) +! Misc changes made for FV3/MPAS compatibility +! +! Many of these changes are now documented in Olson et al. (2019, +! NOAA Technical Memorandum) +! +! For more explanation of some configuration options, see "JOE's mods" below: +!------------------------------------------------------------------- + +MODULE module_bl_mynn + +!================================================================== +!FV3 CONSTANTS + use physcons, only : cp => con_cp, & + & g => con_g, & + & r_d => con_rd, & + & r_v => con_rv, & + & cpv => con_cvap, & + & cliq => con_cliq, & + & Cice => con_csol, & + & rcp => con_rocp, & + & XLV => con_hvap, & + & XLF => con_hfus, & + & EP_1 => con_fvirt, & + & EP_2 => con_eps + + IMPLICIT NONE + + REAL , PARAMETER :: karman = 0.4 + REAL , PARAMETER :: XLS = 2.85E6 + REAL , PARAMETER :: p1000mb = 100000. + REAL , PARAMETER :: rvovrd = r_v/r_d + REAL , PARAMETER :: SVP1 = 0.6112 + REAL , PARAMETER :: SVP2 = 17.67 + REAL , PARAMETER :: SVP3 = 29.65 + REAL , PARAMETER :: SVPT0 = 273.15 + + INTEGER , PARAMETER :: param_first_scalar = 1, & + & p_qc = 2, & + & p_qr = 0, & + & p_qi = 2, & + & p_qs = 0, & + & p_qg = 0, & + & p_qnc= 0, & + & p_qni= 0 + +!END FV3 CONSTANTS +!==================================================================== +!WRF CONSTANTS +! USE module_model_constants, only: & +! &karman, g, p1000mb, & +! &cp, r_d, r_v, rcp, xlv, xlf, xls, & +! &svp1, svp2, svp3, svpt0, ep_1, ep_2, rvovrd, & +! &cpv, cliq, cice +! +! USE module_state_description, only: param_first_scalar, & +! &p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni +! +! IMPLICIT NONE +! +!END WRF CONSTANTS +!=================================================================== +! From here on, these are used for any model +! The parameters below depend on stability functions of module_sf_mynn. + REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & + cphh_st=5.0, cphh_unst=16.0 + + REAL, PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv, rd=r_d, & + &rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2 + + REAL, PARAMETER :: tref=300.0 ! reference temperature (K) + REAL, PARAMETER :: TKmin=253.0 ! for total water conversion, Tripoli and Cotton (1981) + REAL, PARAMETER :: tv0=p608*tref, tv1=(1.+p608)*tref, gtr=g/tref + +! Closure constants + REAL, PARAMETER :: & + &vk = karman, & + &pr = 0.74, & + &g1 = 0.235, & ! NN2009 = 0.235 + &b1 = 24.0, & + &b2 = 15.0, & ! CKmod NN2009 + &c2 = 0.729, & ! 0.729, & !0.75, & + &c3 = 0.340, & ! 0.340, & !0.352, & + &c4 = 0.0, & + &c5 = 0.2, & + &a1 = b1*( 1.0-3.0*g1 )/6.0, & +! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & + &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & + &a2 = a1*( g1-c1 )/( g1*pr ), & + &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) + + REAL, PARAMETER :: & + &cc2 = 1.0-c2, & + &cc3 = 1.0-c3, & + &e1c = 3.0*a2*b2*cc3, & + &e2c = 9.0*a1*a2*cc2, & + &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), & + &e4c = 12.0*a1*a2*cc2, & + &e5c = 6.0*a1*a1 + +! Constants for min tke in elt integration (qmin), max z/L in els (zmax), +! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): + REAL, PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 +! Note that the following mixing-length constants are now specified in mym_length +! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.4 + +! Constants for gravitational settling +! REAL, PARAMETER :: gno=1.e6/(1.e8)**(2./3.), gpw=5./3., qcgmin=1.e-8 + REAL, PARAMETER :: gno=1.0 !original value seems too agressive: 4.64158883361278196 + REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + +! Constants for cloud PDF (mym_condensation) + REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 + +! 'parameters' for Poisson distribution (EDMF scheme) + REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0 + + !Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) + !For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the + !Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010). + !Note that this change required further modification of other parameters + !above (c2, c3). If you want to remove this option, set c2 and c3 constants + !(above) back to NN2009 values (see commented out lines next to the + !parameters above). This only removes the negative TKE problem + !but does not necessarily improve performance - neutral impact. + REAL, PARAMETER :: CKmod=1. + + !Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts + !on the cloud PDF and mass-flux scheme, using Honnert et al. (2011) similarity function + !for TKE in the upper PBL/cloud layer. + REAL, PARAMETER :: scaleaware=1. + + !Temporary switch to deactivate the mixing of chemical species (already done when WRF_CHEM = 1) + INTEGER, PARAMETER :: bl_mynn_mixchem = 0 + + !Adding top-down diffusion driven by cloud-top radiative cooling + INTEGER, PARAMETER :: bl_mynn_topdown = 1 + + !Option to activate heating due to dissipation of TKE (to activate, set to 1.0) + REAL, PARAMETER :: dheat_opt = 1. + + !option to print out more stuff for debugging purposes + LOGICAL, PARAMETER :: debug_code = .false. + +! JAYMES- +! Constants used for empirical calculations of saturation +! vapor pressures (in function "esat") and saturation mixing ratios +! (in function "qsat"), reproduced from module_mp_thompson.F, +! v3.6 + REAL, PARAMETER:: J0= .611583699E03 + REAL, PARAMETER:: J1= .444606896E02 + REAL, PARAMETER:: J2= .143177157E01 + REAL, PARAMETER:: J3= .264224321E-1 + REAL, PARAMETER:: J4= .299291081E-3 + REAL, PARAMETER:: J5= .203154182E-5 + REAL, PARAMETER:: J6= .702620698E-8 + REAL, PARAMETER:: J7= .379534310E-11 + REAL, PARAMETER:: J8=-.321582393E-13 + + REAL, PARAMETER:: K0= .609868993E03 + REAL, PARAMETER:: K1= .499320233E02 + REAL, PARAMETER:: K2= .184672631E01 + REAL, PARAMETER:: K3= .402737184E-1 + REAL, PARAMETER:: K4= .565392987E-3 + REAL, PARAMETER:: K5= .521693933E-5 + REAL, PARAMETER:: K6= .307839583E-7 + REAL, PARAMETER:: K7= .105785160E-9 + REAL, PARAMETER:: K8= .161444444E-12 +! end- + +!JOE & JAYMES'S mods +! +! Mixing Length Options +! specifed through namelist: bl_mynn_mixlength +! added: 16 Apr 2015 +! +! 0: Uses original MYNN mixing length formulation (except elt is calculated from +! a 10-km vertical integration). No scale-awareness is applied to the master +! mixing length (el), regardless of "scaleaware" setting. +! +! 1 (*DEFAULT*): Instead of (0), uses BouLac mixing length in free atmosphere. +! This helps remove excessively large mixing in unstable layers aloft. Scale- +! awareness in dx is available via the "scaleaware" setting. As of Apr 2015, +! this mixing length formulation option is used in the ESRL RAP/HRRR configuration. +! +! 2: As in (1), but elb is lengthened using separate cloud mixing length functions +! for statically stable and unstable regimes. This elb adjustment is only +! possible for nonzero cloud fractions, such that cloud-free cells are treated +! as in (1), but BouLac calculation is used more sparingly - when elb > 500 m. +! This is to reduce the computational expense that comes with the BouLac calculation. +! Also, This option is scale-aware in dx if "scaleaware" = 1. (Following Ito et al. 2015). +! +!JOE & JAYMES- end + + + + INTEGER :: mynn_level + + CHARACTER*128 :: mynn_message + + INTEGER, PARAMETER :: kdebug=27 + +CONTAINS + +! ********************************************************************** +! * An improved Mellor-Yamada turbulence closure model * +! * * +! * Aug/2005 M. Nakanishi (N.D.A) * +! * Modified: Dec/2005 M. Nakanishi (N.D.A) * +! * naka@nda.ac.jp * +! * * +! * Contents: * +! * 1. mym_initialize (to be called once initially) * +! * gives the closure constants and initializes the turbulent * +! * quantities. * +! * (2) mym_level2 (called in the other subroutines) * +! * calculates the stability functions at Level 2. * +! * (3) mym_length (called in the other subroutines) * +! * calculates the master length scale. * +! * 4. mym_turbulence * +! * calculates the vertical diffusivity coefficients and the * +! * production terms for the turbulent quantities. * +! * 5. mym_predict * +! * predicts the turbulent quantities at the next step. * +! * 6. mym_condensation * +! * determines the liquid water content and the cloud fraction * +! * diagnostically. * +! * * +! * call mym_initialize * +! * | * +! * |<----------------+ * +! * | | * +! * call mym_condensation | * +! * call mym_turbulence | * +! * call mym_predict | * +! * | | * +! * |-----------------+ * +! * | * +! * end * +! * * +! * Variables worthy of special mention: * +! * tref : Reference temperature * +! * thl : Liquid water potential temperature * +! * qw : Total water (water vapor+liquid water) content * +! * ql : Liquid water content * +! * vt, vq : Functions for computing the buoyancy flux * +! * * +! * If the water contents are unnecessary, e.g., in the case of * +! * ocean models, thl is the potential temperature and qw, ql, vt * +! * and vq are all zero. * +! * * +! * Grid arrangement: * +! * k+1 +---------+ * +! * | | i = 1 - nx * +! * (k) | * | j = 1 - ny * +! * | | k = 1 - nz * +! * k +---------+ * +! * i (i) i+1 * +! * * +! * All the predicted variables are defined at the center (*) of * +! * the grid boxes. The diffusivity coefficients are, however, * +! * defined on the walls of the grid boxes. * +! * # Upper boundary values are given at k=nz. * +! * * +! * References: * +! * 1. Nakanishi, M., 2001: * +! * Boundary-Layer Meteor., 99, 349-378. * +! * 2. Nakanishi, M. and H. Niino, 2004: * +! * Boundary-Layer Meteor., 112, 1-31. * +! * 3. Nakanishi, M. and H. Niino, 2006: * +! * Boundary-Layer Meteor., (in press). * +! * 4. Nakanishi, M. and H. Niino, 2009: * +! * Jour. Meteor. Soc. Japan, 87, 895-912. * +! ********************************************************************** +! +! SUBROUTINE mym_initialize: +! +! Input variables: +! iniflag : <>0; turbulent quantities will be initialized +! = 0; turbulent quantities have been already +! given, i.e., they will not be initialized +! nx, ny, nz : Dimension sizes of the +! x, y and z directions, respectively +! tref : Reference temperature (K) +! dz(nz) : Vertical grid spacings (m) +! # dz(nz)=dz(nz-1) +! zw(nz+1) : Heights of the walls of the grid boxes (m) +! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1) +! h(nx,ny) : G^(1/2) in the terrain-following coordinate +! # h=1-zg/zt, where zg is the height of the +! terrain and zt the top of the model domain +! pi0(nx,my,nz) : Exner function at zw*h+zg (J/kg K) +! defined by c_p*( p_basic/1000hPa )^kappa +! This is usually computed by integrating +! d(pi0)/dz = -h*g/tref. +! rmo(nx,ny) : Inverse of the Obukhov length (m^(-1)) +! flt, flq(nx,ny) : Turbulent fluxes of sensible and latent heat, +! respectively, e.g., flt=-u_*Theta_* (K m/s) +!! flt - liquid water potential temperature surface flux +!! flq - total water flux surface flux +! ust(nx,ny) : Friction velocity (m/s) +! pmz(nx,ny) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) +! is the first grid point above the surafce, z0 +! the roughness length and zeta=(z1*h+z0)*rmo +! phh(nx,ny) : phi_h at z1*h+z0 +! u, v(nx,nz,ny): Components of the horizontal wind (m/s) +! thl(nx,nz,ny) : Liquid water potential temperature +! (K) +! qw(nx,nz,ny) : Total water content Q_w (kg/kg) +! +! Output variables: +! ql(nx,nz,ny) : Liquid water content (kg/kg) +! v?(nx,nz,ny) : Functions for computing the buoyancy flux +! qke(nx,nz,ny) : Twice the turbulent kinetic energy q^2 +! (m^2/s^2) +! tsq(nx,nz,ny) : Variance of Theta_l (K^2) +! qsq(nx,nz,ny) : Variance of Q_w +! cov(nx,nz,ny) : Covariance of Theta_l and Q_w (K) +! el(nx,nz,ny) : Master length scale L (m) +! defined on the walls of the grid boxes +! +! Work arrays: see subroutine mym_level2 +! pd?(nx,nz,ny) : Half of the production terms at Level 2 +! defined on the walls of the grid boxes +! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s) +! +! # As to dtl, ...gh, see subroutine mym_turbulence. +! +!------------------------------------------------------------------- + SUBROUTINE mym_initialize ( & + & kts,kte, & + & dz, zw, & + & u, v, thl, qw, & +! & ust, rmo, pmz, phh, flt, flq, & + & zi, theta, sh, & + & ust, rmo, el, & + & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + & spp_pbl,rstoch_col) +! +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte + INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf +! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq + REAL, INTENT(IN) :: ust, rmo, Psig_bl + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& + edmf_w1,edmf_a1,edmf_qc1 + REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov + REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke + + REAL, DIMENSION(kts:kte) :: & + &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& + &gm,gh,sm,sh,qkw,vt,vq + INTEGER :: k,l,lmax + REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq + REAL :: zi + REAL, DIMENSION(kts:kte) :: theta + + REAL, DIMENSION(kts:kte) :: rstoch_col + INTEGER ::spp_pbl + +! ** At first ql, vt and vq are set to zero. ** + DO k = kts,kte + ql(k) = 0.0 + vt(k) = 0.0 + vq(k) = 0.0 + END DO +! + CALL mym_level2 ( kts,kte,& + & dz, & + & u, v, thl, qw, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! +! ** Preliminary setting ** + + el (kts) = 0.0 + qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0) +! + phm = phh*b2 / ( b1*pmz )**(1.0/3.0) + tsq(kts) = phm*( flt/ust )**2 + qsq(kts) = phm*( flq/ust )**2 + cov(kts) = phm*( flt/ust )*( flq/ust ) +! + DO k = kts+1,kte + vkz = vk*zw(k) + el (k) = vkz/( 1.0 + vkz/100.0 ) + qke(k) = 0.0 +! + tsq(k) = 0.0 + qsq(k) = 0.0 + cov(k) = 0.0 + END DO +! +! ** Initialization with an iterative manner ** +! ** lmax is the iteration count. This is arbitrary. ** + lmax = 5 +! + DO l = 1,lmax +! + CALL mym_length ( & + & kts,kte, & + & dz, zw, & + & rmo, flt, flq, & + & vt, vq, & + & qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) +! + DO k = kts+1,kte + elq = el(k)*qkw(k) + pdk(k) = elq*( sm(k)*gm (k)+& + &sh(k)*gh (k) ) + pdt(k) = elq* sh(k)*dtl(k)**2 + pdq(k) = elq* sh(k)*dqw(k)**2 + pdc(k) = elq* sh(k)*dtl(k)*dqw(k) + END DO +! +! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** + vkz = vk*0.5*dz(kts) +! + elv = 0.5*( el(kts+1)+el(kts) ) / vkz + qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0) +! + phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0) + tsq(kts) = phm*( flt/ust )**2 + qsq(kts) = phm*( flq/ust )**2 + cov(kts) = phm*( flt/ust )*( flq/ust ) +! + DO k = kts+1,kte-1 + b1l = b1*0.25*( el(k+1)+el(k) ) + tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin) +! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k) + qke(k) = tmpq**(2.0/3.0) + +! + IF ( qke(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*( b1l/b1 ) / SQRT( qke(k) ) + END IF +! + tsq(k) = b2l*( pdt(k+1)+pdt(k) ) + qsq(k) = b2l*( pdq(k+1)+pdq(k) ) + cov(k) = b2l*( pdc(k+1)+pdc(k) ) + END DO + +! + END DO + +!! qke(kts)=qke(kts+1) +!! tsq(kts)=tsq(kts+1) +!! qsq(kts)=qsq(kts+1) +!! cov(kts)=cov(kts+1) + + qke(kte)=qke(kte-1) + tsq(kte)=tsq(kte-1) + qsq(kte)=qsq(kte-1) + cov(kte)=cov(kte-1) + +! +! RETURN + + END SUBROUTINE mym_initialize + +! +! ================================================================== +! SUBROUTINE mym_level2: +! +! Input variables: see subroutine mym_initialize +! +! Output variables: +! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m) +! dqw(nx,nz,ny) : Vertical gradient of Q_w +! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m) +! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2)) +! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2)) +! sm (nx,nz,ny) : Stability function for momentum, at Level 2 +! sh (nx,nz,ny) : Stability function for heat, at Level 2 +! +! These are defined on the walls of the grid boxes. +! + SUBROUTINE mym_level2 (kts,kte,& + & dz, & + & u, v, thl, qw, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq + + REAL, DIMENSION(kts:kte), INTENT(out) :: & + &dtl,dqw,dtv,gm,gh,sm,sh + + INTEGER :: k + + REAL :: rfc,f1,f2,rf1,rf2,smc,shc,& + &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf + + REAL :: a2den + +! ev = 2.5e6 +! tv0 = 0.61*tref +! tv1 = 1.61*tref +! gtr = 9.81/tref +! + rfc = g1/( g1+g2 ) + f1 = b1*( g1-c1 ) +3.0*a2*( 1.0 -c2 )*( 1.0-c5 ) & + & +2.0*a1*( 3.0-2.0*c2 ) + f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) + rf1 = b1*( g1-c1 )/f1 + rf2 = b1* g1 /f2 + smc = a1 /a2* f1/f2 + shc = 3.0*a2*( g1+g2 ) +! + ri1 = 0.5/smc + ri2 = rf1*smc + ri3 = 4.0*rf2*smc -2.0*ri2 + ri4 = ri2**2 +! + DO k = kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 + duz = duz /dzk**2 + dtz = ( thl(k)-thl(k-1) )/( dzk ) + dqz = ( qw(k)-qw(k-1) )/( dzk ) +! + vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 + vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q + dtq = vtt*dtz +vqq*dqz +! + dtl(k) = dtz + dqw(k) = dqz + dtv(k) = dtq +!? dtv(i,j,k) = dtz +tv0*dqz +!? : +( ev/pi0(i,j,k)-tv1 ) +!? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) ) +! + gm (k) = duz + gh (k) = -dtq*gtr +! +! ** Gradient Richardson number ** + ri = -gh(k)/MAX( duz, 1.0e-10 ) + + !a2den is needed for the Canuto/Kitamura mod + IF (CKmod .eq. 1) THEN + a2den = 1. + MAX(ri,0.0) + ELSE + a2den = 1. + 0.0 + ENDIF + + rfc = g1/( g1+g2 ) + f1 = b1*( g1-c1 ) +3.0*(a2/a2den)*( 1.0 -c2 )*( 1.0-c5 ) & + & +2.0*a1*( 3.0-2.0*c2 ) + f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) + rf1 = b1*( g1-c1 )/f1 + rf2 = b1* g1 /f2 + smc = a1 /(a2/a2den)* f1/f2 + shc = 3.0*(a2/a2den)*( g1+g2 ) + + ri1 = 0.5/smc + ri2 = rf1*smc + ri3 = 4.0*rf2*smc -2.0*ri2 + ri4 = ri2**2 + +! ** Flux Richardson number ** + rf = MIN( ri1*( ri+ri2-SQRT(ri**2-ri3*ri+ri4) ), rfc ) +! + sh (k) = shc*( rfc-rf )/( 1.0-rf ) + sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k) + END DO +! +! RETURN + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_level2 + +! ================================================================== +! SUBROUTINE mym_length: +! +! Input variables: see subroutine mym_initialize +! +! Output variables: see subroutine mym_initialize +! +! Work arrays: +! elt(nx,ny) : Length scale depending on the PBL depth (m) +! vsc(nx,ny) : Velocity scale q_c (m/s) +! at first, used for computing elt +! +! NOTE: the mixing lengths are meant to be calculated at the full- +! sigmal levels (or interfaces beween the model layers). +! + SUBROUTINE mym_length ( & + & kts,kte, & + & dz, zw, & + & rmo, flt, flq, & + & vt, vq, & + & qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) + +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl + REAL, DIMENSION(kts:kte), INTENT(IN) :: qke,vt,vq,cldfra_bl1D,& + edmf_w1,edmf_a1,edmf_qc1 + REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el + REAL, DIMENSION(kts:kte), INTENT(in) :: dtv + + REAL :: elt,vsc + + REAL, DIMENSION(kts:kte), INTENT(IN) :: theta + REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw + REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg + + ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE + ! MIXING LENGTHS: + REAL :: cns, & ! for surface layer (els) in stable conditions + alp1, & ! for turbulent length scale (elt) + alp2, & ! for buoyancy length scale (elb) + alp3, & ! for buoyancy enhancement factor of elb + alp4, & ! for surface layer (els) in unstable conditions + alp5, & ! for BouLac mixing length or above PBLH + alp6 ! for mass-flux/ + + !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. + !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH + !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES + !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). + REAL, PARAMETER :: minzi = 300. !min mixed-layer height + REAL, PARAMETER :: maxdz = 750. !max (half) transition layer depth + !=0.3*2500 m PBLH, so the transition + !layer stops growing for PBLHs > 2.5 km. + REAL, PARAMETER :: mindz = 300. !300 !min (half) transition layer depth + + !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER + REAL, PARAMETER :: ZSLH = 100. ! Max height correlated to surface conditions (m) + REAL, PARAMETER :: CSL = 2. ! CSL = constant of proportionality to L O(1) + REAL :: z_m + + + INTEGER :: i,j,k + REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,elb,els,els1,elf, & + & el_stab,el_unstab,el_mf,el_stab_mf,elb_mf,PBLH_PLUS_ENT,el_les + +! tv0 = 0.61*tref +! gtr = 9.81/tref + + SELECT CASE(bl_mynn_mixlength) + + CASE (0) ! ORIGINAL MYNN MIXING LENGTH + + cns = 2.7 + alp1 = 0.23 + alp2 = 1.0 + alp3 = 5.0 + alp4 = 100. + alp5 = 0.4 + + ! Impose limits on the height integration for elt and the transition layer depth + zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km. + h1=MAX(0.3*zi2,mindz) + h1=MIN(h1,maxdz) ! 1/2 transition layer depth + h2=h1/2.0 ! 1/4 transition layer depth + + qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + END DO + + elt = 1.0e-5 + vsc = 1.0e-5 + + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. zi2+h1) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO + + elt = alp1*elt/vsc + vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) + + ! ** Strictly, el(i,j,1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) + + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels + + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + bv = SQRT( gtr*dtv(k) ) + elb = alp2*qkw(k) / bv & + & *( 1.0 + alp3/alp2*& + &SQRT( vsc/( bv*elt ) ) ) + elf = alp2 * qkw(k)/bv + + ELSE + elb = 1.0e10 + elf = elb + ENDIF + + z_m = MAX(0.,zwk - 4.) + + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 + END IF + + ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: + ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + ! el(k) = elb/( elb/elt+elb/els+1.0 ) + + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + + END DO + + CASE (1) !OPERATIONAL FORM OF MIXING LENGTH + + cns = 2.3 + alp1 = 0.23 + alp2 = 0.65 + alp3 = 3.0 + alp4 = 20. + alp5 = 0.4 + + ! Impose limits on the height integration for elt and the transition layer depth + zi2=MAX(zi,minzi) + h1=MAX(0.3*zi2,mindz) + h1=MIN(h1,maxdz) ! 1/2 transition layer depth + h2=h1/2.0 ! 1/4 transition layer depth + + qtke(kts)=MAX(qke(kts)/2.,0.01) !tke at full sigma levels + thetaw(kts)=theta(kts) !theta at full-sigma levels + qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + qtke(k) = (qkw(k)**2.)/2. ! q -> TKE + thetaw(k)= theta(k)*abk + theta(k-1)*afk + END DO + + elt = 1.0e-5 + vsc = 1.0e-5 + + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. zi2+h1) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO + + elt = alp1*elt/vsc + vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) + + ! ** Strictly, el(i,j,1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) !full-sigma levels + + ! COMPUTE BouLac mixing length + CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg) + + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels + + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + bv = SQRT( gtr*dtv(k) ) + elb = alp2*qkw(k) / bv & ! formulation, + & *( 1.0 + alp3/alp2*& ! except keep + &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by + elb = MIN(elb, zwk) ! zwk + elf = alp2 * qkw(k)/bv + ELSE + elb = 1.0e10 + elf = elb + ENDIF + + z_m = MAX(0.,zwk - 4.) + + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 + END IF + + ! ** NOW BLEND THE MIXING LENGTH SCALES: + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + !add blending to use BouLac mixing length in free atmos; + !defined relative to the PBLH (zi) + transition layer (h1) + el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + el(k) = el(k)*(1.-wt) + alp5*elBLmin(k)*wt + + ! include scale-awareness, except for original MYNN + el(k) = el(k)*Psig_bl + + END DO + + CASE (2) !Experimental mixing length formulation + + cns = 3.5 + alp1 = 0.23 + alp2 = 0.6 !0.3 + alp3 = 2.0 + alp4 = 10. + alp5 = 0.6 !0.3 !like alp2, but for free atmosphere + alp6 = 10.0 !used for MF mixing length instead of BouLac (x times MF) + + ! Impose limits on the height integration for elt and the transition layer depth + !zi2=MAX(zi,minzi) + zi2=MAX(zi, 100.) + h1=MAX(0.3*zi2,mindz) + h1=MIN(h1,maxdz) ! 1/2 transition layer depth + h2=h1*0.5 ! 1/4 transition layer depth + + qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels + qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + qtke(k) = 0.5*(qkw(k)**2.) ! q -> TKE + END DO + + elt = 1.0e-5 + vsc = 1.0e-5 + + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + PBLH_PLUS_ENT = MAX(zi+h1, 100.) + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. PBLH_PLUS_ENT) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk !consider reducing 0.3 + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO + + elt = MAX(alp1*elt/vsc, 10.) + vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) + + ! ** Strictly, el(i,j,1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) + + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels + cldavg = 0.5*(cldfra_bl1D(k-1)+cldfra_bl1D(k)) + + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + bv = SQRT( gtr*dtv(k) ) + !elb_mf = alp2*qkw(k) / bv & + elb_mf = MAX(alp2*qkw(k), & + &MAX(1.-2.0*cldavg,0.0)**0.5*alp6*edmf_a1(k)*edmf_w1(k)) / bv & + & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) + elb = MIN(alp5*qkw(k)/bv, zwk) + elf = elb/(1. + (elb/600.)) !bound free-atmos mixing length to < 600 m. + !IF (zwk > zi .AND. elf > 400.) THEN + ! ! COMPUTE BouLac mixing length + ! !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0) + ! !elf = alp5*elBLavg0 + ! elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk) + !ENDIF + + ELSE + ! use version in development for RAP/HRRR 2016 + ! JAYMES- + ! tau_cloud is an eddy turnover timescale; + ! see Teixeira and Cheinet (2004), Eq. 1, and + ! Cheinet and Teixeira (2003), Eq. 7. The + ! coefficient 0.5 is tuneable. Expression in + ! denominator is identical to vsc (a convective + ! velocity scale), except that elt is relpaced + ! by zi, and zero is replaced by 1.0e-4 to + ! prevent division by zero. + tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(flt,1.0e-4))**(1.0/3.0)),25.),100.) + !minimize influence of surface heat flux on tau far away from the PBLH. + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + tau_cloud = tau_cloud*(1.-wt) + 50.*wt + + elb = MIN(tau_cloud*SQRT(MIN(qtke(k),50.)), zwk) + elf = elb + elb_mf = elb + END IF + + z_m = MAX(0.,zwk - 4.) + + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 + END IF + + ! ** NOW BLEND THE MIXING LENGTH SCALES: + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + ! "el_unstab" = blended els-elt + el_unstab = els/(1. + (els1/elt)) + el(k) = MIN(el_unstab, elb_mf) + el(k) = el(k)*(1.-wt) + elf*wt + + ! include scale-awareness. For now, use simple asymptotic kz -> 12 m. + el_les= MIN(els/(1. + (els1/12.)), elb_mf) + el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les + + END DO + + END SELECT + + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_length + +! ================================================================== + SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) +! +! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW +! and modified for integration into the MYNN PBL scheme. +! WHILE loops were added to reduce the computational expense. +! This subroutine computes the length scales up and down +! and then computes the min, average of the up/down +! length scales, and also considers the distance to the +! surface. +! +! dlu = the distance a parcel can be lifted upwards give a finite +! amount of TKE. +! dld = the distance a parcel can be displaced downwards given a +! finite amount of TKE. +! lb1 = the minimum of the length up and length down +! lb2 = the average of the length up and length down +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: k,kts,kte + REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + REAL, INTENT(OUT) :: lb1,lb2 + REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + + !LOCAL VARS + INTEGER :: izz, found + REAL :: dlu,dld + REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + + + !---------------------------------- + ! FIND DISTANCE UPWARD + !---------------------------------- + zup=0. + dlu=zw(kte+1)-zw(k)-dz(k)/2. + zzz=0. + zup_inf=0. + beta=g/theta(k) !Buoyancy coefficient + + !print*,"FINDING Dup, k=",k," zw=",zw(k) + + if (k .lt. kte) then !cant integrate upwards from highest level + found = 0 + izz=k + DO WHILE (found .EQ. 0) + + if (izz .lt. kte) then + dzt=dz(izz) ! layer depth above + zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k + !print*," ",k,izz,theta(izz),dz(izz) + zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1 + zzz=zzz+dzt ! depth of layer k to izz+1 + !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz) + if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then + bbb=(theta(izz+1)-theta(izz))/dzt + if (bbb .ne. 0.) then + !fractional distance up into the layer where TKE becomes < PE + tl=(-beta*(theta(izz)-theta(k)) + & + & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2. + & + & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta + else + if (theta(izz) .ne. theta(k))then + tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k))) + else + tl=0. + endif + endif + dlu=zzz-dzt+tl + !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl + found =1 + endif + zup_inf=zup + izz=izz+1 + ELSE + found = 1 + ENDIF + + ENDDO + + endif + + !---------------------------------- + ! FIND DISTANCE DOWN + !---------------------------------- + zdo=0. + zdo_sup=0. + dld=zw(k) + zzz=0. + + !print*,"FINDING Ddown, k=",k," zwk=",zw(k) + if (k .gt. kts) then !cant integrate downwards from lowest level + + found = 0 + izz=k + DO WHILE (found .EQ. 0) + + if (izz .gt. kts) then + dzt=dz(izz-1) + zdo=zdo+beta*theta(k)*dzt + !print*," ",k,izz,theta(izz),dz(izz-1) + zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2. + zzz=zzz+dzt + !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz) + if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then + bbb=(theta(izz)-theta(izz-1))/dzt + if (bbb .ne. 0.) then + tl=(beta*(theta(izz)-theta(k))+ & + & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2. + & + & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta + else + if (theta(izz) .ne. theta(k)) then + tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k))) + else + tl=0. + endif + endif + dld=zzz-dzt+tl + !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl + found = 1 + endif + zdo_sup=zdo + izz=izz-1 + ELSE + found = 1 + ENDIF + ENDDO + + endif + + !---------------------------------- + ! GET MINIMUM (OR AVERAGE) + !---------------------------------- + !The surface layer length scale can exceed z for large z/L, + !so keep maximum distance down > z. + dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos + lb1 = min(dlu,dld) !minimum + !JOE-fight floating point errors + dlu=MAX(0.1,MIN(dlu,1000.)) + dld=MAX(0.1,MIN(dld,1000.)) + lb2 = sqrt(dlu*dld) !average - biased towards smallest + !lb2 = 0.5*(dlu+dld) !average + + if (k .eq. kte) then + lb1 = 0. + lb2 = 0. + endif + !print*,"IN MYNN-BouLac",k,lb1 + !print*,"IN MYNN-BouLac",k,dld,dlu + + END SUBROUTINE boulac_length0 + +! ================================================================== + SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) +! +! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW +! and modified for integration into the MYNN PBL scheme. +! WHILE loops were added to reduce the computational expense. +! This subroutine computes the length scales up and down +! and then computes the min, average of the up/down +! length scales, and also considers the distance to the +! surface. +! +! dlu = the distance a parcel can be lifted upwards give a finite +! amount of TKE. +! dld = the distance a parcel can be displaced downwards given a +! finite amount of TKE. +! lb1 = the minimum of the length up and length down +! lb2 = the average of the length up and length down +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte + REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + REAL, DIMENSION(kts:kte), INTENT(OUT) :: lb1,lb2 + REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + + !LOCAL VARS + INTEGER :: iz, izz, found + REAL, DIMENSION(kts:kte) :: dlu,dld + REAL, PARAMETER :: Lmax=2000. !soft limit + REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + + !print*,"IN MYNN-BouLac",kts, kte + + do iz=kts,kte + + !---------------------------------- + ! FIND DISTANCE UPWARD + !---------------------------------- + zup=0. + dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)/2. + zzz=0. + zup_inf=0. + beta=g/theta(iz) !Buoyancy coefficient + + !print*,"FINDING Dup, k=",iz," zw=",zw(iz) + + if (iz .lt. kte) then !cant integrate upwards from highest level + + found = 0 + izz=iz + DO WHILE (found .EQ. 0) + + if (izz .lt. kte) then + dzt=dz(izz) ! layer depth above + zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz + !print*," ",iz,izz,theta(izz),dz(izz) + zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1 + zzz=zzz+dzt ! depth of layer iz to izz+1 + !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz) + if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then + bbb=(theta(izz+1)-theta(izz))/dzt + if (bbb .ne. 0.) then + !fractional distance up into the layer where TKE becomes < PE + tl=(-beta*(theta(izz)-theta(iz)) + & + & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + & + & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta + else + if (theta(izz) .ne. theta(iz))then + tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz))) + else + tl=0. + endif + endif + dlu(iz)=zzz-dzt+tl + !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl + found =1 + endif + zup_inf=zup + izz=izz+1 + ELSE + found = 1 + ENDIF + + ENDDO + + endif + + !---------------------------------- + ! FIND DISTANCE DOWN + !---------------------------------- + zdo=0. + zdo_sup=0. + dld(iz)=zw(iz) + zzz=0. + + !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz) + if (iz .gt. kts) then !cant integrate downwards from lowest level + + found = 0 + izz=iz + DO WHILE (found .EQ. 0) + + if (izz .gt. kts) then + dzt=dz(izz-1) + zdo=zdo+beta*theta(iz)*dzt + !print*," ",iz,izz,theta(izz),dz(izz-1) + zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2. + zzz=zzz+dzt + !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz) + if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then + bbb=(theta(izz)-theta(izz-1))/dzt + if (bbb .ne. 0.) then + tl=(beta*(theta(izz)-theta(iz))+ & + & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + & + & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta + else + if (theta(izz) .ne. theta(iz)) then + tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz))) + else + tl=0. + endif + endif + dld(iz)=zzz-dzt+tl + !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl + found = 1 + endif + zdo_sup=zdo + izz=izz-1 + ELSE + found = 1 + ENDIF + ENDDO + + endif + + !---------------------------------- + ! GET MINIMUM (OR AVERAGE) + !---------------------------------- + !The surface layer length scale can exceed z for large z/L, + !so keep maximum distance down > z. + dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos + lb1(iz) = min(dlu(iz),dld(iz)) !minimum + !JOE-fight floating point errors + dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) + dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) + lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest + !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average + + !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%). + lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax)) + lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax)) + + if (iz .eq. kte) then + lb1(kte) = lb1(kte-1) + lb2(kte) = lb2(kte-1) + endif + !print*,"IN MYNN-BouLac",kts, kte,lb1(iz) + !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz) + + ENDDO + + END SUBROUTINE boulac_length +! +! ================================================================== +! SUBROUTINE mym_turbulence: +! +! Input variables: see subroutine mym_initialize +! levflag : <>3; Level 2.5 +! = 3; Level 3 +! +! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. +! +! Output variables: see subroutine mym_initialize +! dfm(nx,nz,ny) : Diffusivity coefficient for momentum, +! divided by dz (not dz*h(i,j)) (m/s) +! dfh(nx,nz,ny) : Diffusivity coefficient for heat, +! divided by dz (not dz*h(i,j)) (m/s) +! dfq(nx,nz,ny) : Diffusivity coefficient for q^2, +! divided by dz (not dz*h(i,j)) (m/s) +! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l +! (K/s) +! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w +! (kg/kg s) +! pd?(nx,nz,ny) : Half of the production terms +! +! Only tcd and qcd are defined at the center of the grid boxes +! +! # DO NOT forget that tcd and qcd are added on the right-hand side +! of the equations for Theta_l and Q_w, respectively. +! +! Work arrays: see subroutine mym_initialize and level2 +! +! # dtl, dqw, dtv, gm and gh are allowed to share storage units with +! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. +! + SUBROUTINE mym_turbulence ( & + & kts,kte, & + & levflag, & + & dz, zw, & + & u, v, thl, ql, qw, & + & qke, tsq, qsq, cov, & + & vt, vq, & + & rmo, flt, flq, & + & zi,theta, & + & sh, & + & El, & + & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & + & bl_mynn_tkebudget, & + & Psig_bl,Psig_shcu,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + & TKEprodTD, & + & spp_pbl,rstoch_col) + +!------------------------------------------------------------------- +! + INTEGER, INTENT(IN) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + INTEGER, INTENT(IN) :: levflag,bl_mynn_mixlength,bl_mynn_edmf + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,& + &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& + &TKEprodTD + + REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& + &pdk,pdt,pdq,pdc,tcd,qcd,el + + REAL, DIMENSION(kts:kte), INTENT(inout) :: & + qWT1D,qSHEAR1D,qBUOY1D,qDISS1D + REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new + REAL :: dudz,dvdz,dTdz,& + upwp,vpwp,Tpwp + INTEGER, INTENT(in) :: bl_mynn_tkebudget + + REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh + + INTEGER :: k +! REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c + REAL :: e6c,dzk,afk,abk,vtt,vqq,& + &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh + + REAL :: zi, cldavg + REAL, DIMENSION(kts:kte), INTENT(in) :: theta + + REAL :: a2den, duz, ri, HLmod !JOE-Canuto/Kitamura mod +!JOE-stability criteria for cw + REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2 +!JOE-end + + DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel + DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv + DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden + +! Stochastic + INTEGER, INTENT(IN) :: spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col + REAL :: prlimit + + +! +! tv0 = 0.61*tref +! gtr = 9.81/tref +! +! cc2 = 1.0-c2 +! cc3 = 1.0-c3 +! e1c = 3.0*a2*b2*cc3 +! e2c = 9.0*a1*a2*cc2 +! e3c = 9.0*a2*a2*cc2*( 1.0-c5 ) +! e4c = 12.0*a1*a2*cc2 +! e5c = 6.0*a1*a1 +! + + CALL mym_level2 (kts,kte,& + & dz, & + & u, v, thl, qw, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! + CALL mym_length ( & + & kts,kte, & + & dz, zw, & + & rmo, flt, flq, & + & vt, vq, & + & qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength, & + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf ) +! + + DO k = kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + elsq = el (k)**2 + q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) + q3sq = qkw(k)**2 + +!JOE-Canuto/Kitamura mod + duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 + duz = duz /dzk**2 + ! ** Gradient Richardson number ** + ri = -gh(k)/MAX( duz, 1.0e-10 ) + IF (CKmod .eq. 1) THEN + a2den = 1. + MAX(ri,0.0) + ELSE + a2den = 1. + 0.0 + ENDIF +!JOE-end +! +! Modified: Dec/22/2005, from here, (dlsq -> elsq) + gmel = gm (k)*elsq + ghel = gh (k)*elsq +! Modified: Dec/22/2005, up to here + + ! Level 2.0 debug prints + IF ( debug_code ) THEN + IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN + print*,"MYNN; mym_turbulence2.0; sh=",sh(k)," k=",k + print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + print*," qke=",qke(k)," el=",el(k)," ri=",ri + print*," PBLH=",zi," u=",u(k)," v=",v(k) + ENDIF + ENDIF + +!JOE-Apply Helfand & Labraga stability check for all Ric +! when CKmod == 1. (currently not forced below) + IF (CKmod .eq. 1) THEN + HLmod = q2sq -1. + ELSE + HLmod = q3sq + ENDIF + +! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** + +!JOE-test new stability criteria in level 2.5 (as well as level 3) - little/no impact +! ** Limitation on q, instead of L/q ** + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) +!JOE-end + + IF ( q3sq .LT. q2sq ) THEN + !IF ( HLmod .LT. q2sq ) THEN + !Apply Helfand & Labraga mod + qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) + sm(k) = sm(k) * qdiv + sh(k) = sh(k) * qdiv +! + !JOE-Canuto/Kitamura mod + !e1 = q3sq - e1c*ghel * qdiv**2 + !e2 = q3sq - e2c*ghel * qdiv**2 + !e3 = e1 + e3c*ghel * qdiv**2 + !e4 = e1 - e4c*ghel * qdiv**2 + e1 = q3sq - e1c*ghel/a2den * qdiv**2 + e2 = q3sq - e2c*ghel/a2den * qdiv**2 + e3 = e1 + e3c*ghel/(a2den**2) * qdiv**2 + e4 = e1 - e4c*ghel/a2den * qdiv**2 + eden = e2*e4 + e3*e5c*gmel * qdiv**2 + eden = MAX( eden, 1.0d-20 ) + ELSE + !JOE-Canuto/Kitamura mod + !e1 = q3sq - e1c*ghel + !e2 = q3sq - e2c*ghel + !e3 = e1 + e3c*ghel + !e4 = e1 - e4c*ghel + e1 = q3sq - e1c*ghel/a2den + e2 = q3sq - e2c*ghel/a2den + e3 = e1 + e3c*ghel/(a2den**2) + e4 = e1 - e4c*ghel/a2den + eden = e2*e4 + e3*e5c*gmel + eden = MAX( eden, 1.0d-20 ) + + qdiv = 1.0 + sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden + !JOE-Canuto/Kitamura mod + !sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden + sh(k) = q3sq*(a2/a2den)*( e2+3.0*c1*e5c*gmel )/eden + END IF !end Helfand & Labraga check + + !JOE: Level 2.5 debug prints + ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 + IF ( debug_code ) THEN + IF (sh(k)<0.0 .OR. sm(k)<0.0 .OR. & + sh(k) > 0.76*b2 .or. (sm(k)**2*gm(k) .gt. .44**2)) THEN + print*,"MYNN; mym_turbulence2.5; sh=",sh(k)," k=",k + print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + print*," qke=",qke(k)," el=",el(k)," ri=",ri + print*," PBLH=",zi," u=",u(k)," v=",v(k) + ENDIF + ENDIF + +! ** Level 3 : start ** + IF ( levflag .EQ. 3 ) THEN + t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2 + r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2 + c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k) + t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 ) + r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 ) + c3sq = cov(k)*abk+cov(k-1)*afk + +! Modified: Dec/22/2005, from here + c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) +! + vtt = 1.0 +vt(k)*abk +vt(k-1)*afk + vqq = tv0 +vq(k)*abk +vq(k-1)*afk + t2sq = vtt*t2sq +vqq*c2sq + r2sq = vtt*c2sq +vqq*r2sq + c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 ) + t3sq = vtt*t3sq +vqq*c3sq + r3sq = vtt*c3sq +vqq*r3sq + c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 ) +! + cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden ) +! +! ** Limitation on q, instead of L/q ** + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) +! +! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** + !JOE: use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10) + ! to calculate an exact limit for c3sq: + auh = 27.*a1*((a2/a2den)**2)*b2*(g/tref)**2 + aum = 54.*(a1**2)*(a2/a2den)*b2*c1*(g/tref) + adh = 9.*a1*((a2/a2den)**2)*(12.*a1 + 3.*b2)*(g/tref)**2 + adm = 18.*(a1**2)*(a2/a2den)*(b2 - 3.*(a2/a2den))*(g/tref) + + aeh = (9.*a1*((a2/a2den)**2)*b1 +9.*a1*((a2/a2den)**2)* & + (12.*a1 + 3.*b2))*(g/tref) + aem = 3.*a1*(a2/a2den)*b1*(3.*(a2/a2den) + 3.*b2*c1 + & + (18.*a1*c1 - b2)) + & + (18.)*(a1**2)*(a2/a2den)*(b2 - 3.*(a2/a2den)) + + Req = -aeh/aem + Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req) + !For now, use default values, since tests showed little/no sensitivity + Rsl = .12 !lower limit + Rsl2= 1.0 - 2.*Rsl !upper limit + !IF (k==2)print*,"Dynamic limit RSL=",Rsl + !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN + ! print*,'--- ERROR: MYNN: Dynamic Cw '// & + ! 'limit exceeds reasonable limits' + ! print*," MYNN: Dynamic Cw limit needs attention=",Rsl + !ENDIF + + !JOE-Canuto/Kitamura mod + !e2 = q3sq - e2c*ghel * qdiv**2 + !e3 = q3sq + e3c*ghel * qdiv**2 + !e4 = q3sq - e4c*ghel * qdiv**2 + e2 = q3sq - e2c*ghel/a2den * qdiv**2 + e3 = q3sq + e3c*ghel/(a2den**2) * qdiv**2 + e4 = q3sq - e4c*ghel/a2den * qdiv**2 + eden = e2*e4 + e3 *e5c*gmel * qdiv**2 + + !JOE-Canuto/Kitamura mod + !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & + ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) + wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & + & *( e2*e4c/a2den - e3c*e5c*gmel/(a2den**2) * qdiv**2 ) + + IF ( wden .NE. 0.0 ) THEN + !JOE: test dynamic limits + !clow = q3sq*( 0.12-cw25 )*eden/wden + !cupp = q3sq*( 0.76-cw25 )*eden/wden + clow = q3sq*( Rsl -cw25 )*eden/wden + cupp = q3sq*( Rsl2-cw25 )*eden/wden +! + IF ( wden .GT. 0.0 ) THEN + c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) + ELSE + c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp ) + END IF + END IF +! + e1 = e2 + e5c*gmel * qdiv**2 + eden = MAX( eden, 1.0d-20 ) +! Modified: Dec/22/2005, up to here + + !JOE-Canuto/Kitamura mod + !e6c = 3.0*a2*cc3*gtr * dlsq/elsq + e6c = 3.0*(a2/a2den)*cc3*gtr * dlsq/elsq + + !============================ + ! ** for Gamma_theta ** + !! enum = qdiv*e6c*( t3sq-t2sq ) + IF ( t2sq .GE. 0.0 ) THEN + enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) + ELSE + enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) + ENDIF + gamt =-e1 *enum /eden + + !============================ + ! ** for Gamma_q ** + !! enum = qdiv*e6c*( r3sq-r2sq ) + IF ( r2sq .GE. 0.0 ) THEN + enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) + ELSE + enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) + ENDIF + gamq =-e1 *enum /eden + + !============================ + ! ** for Sm' and Sh'd(Theta_V)/dz ** + !! enum = qdiv*e6c*( c3sq-c2sq ) + enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0) + + !JOE-Canuto/Kitamura mod + !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 + smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c/(a2den**2) + & + & e4c/a2den)*a1/(a2/a2den) + + gamv = e1 *enum*gtr/eden + sm(k) = sm(k) +smd + + !============================ + ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** + qdiv = 1.0 + + ! Level 3 debug prints + IF ( debug_code ) THEN + IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. & + qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN + print*," MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k + print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + print*," qke=",qke(k)," el=",el(k)," ri=",ri + print*," PBLH=",zi," u=",u(k)," v=",v(k) + ENDIF + ENDIF + +! ** Level 3 : end ** + + ELSE +! ** At Level 2.5, qdiv is not reset. ** + gamt = 0.0 + gamq = 0.0 + gamv = 0.0 + END IF +! +! Add stochastic perturbation of prandtl number limit + if (spp_pbl==1) then + prlimit = MIN(MAX(1.,2.5 + 5.0*rstoch_col(k)), 10.) + IF(sm(k) > sh(k)*Prlimit) THEN + sm(k) = sh(k)*Prlimit + ENDIF + ENDIF +! +! Add min background stability function (diffusivity) within model levels +! with active plumes and low cloud fractions. + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + + ! for mass-flux columns + sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + ! for clouds + sm(k) = MAX(sm(k), 0.03*MIN(cldavg,1.0) ) + sh(k) = MAX(sh(k), 0.03*MIN(cldavg,1.0) ) + + ENDIF +! + elq = el(k)*qkw(k) + elh = elq*qdiv + + ! Production of TKE (pdk), T-variance (pdt), + ! q-variance (pdq), and covariance (pdc) + pdk(k) = elq*( sm(k)*gm(k) & + & +sh(k)*gh(k)+gamv ) + & ! JAYMES TKE + & TKEprodTD(k) ! JOE-top-down + pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) + pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) + pdc(k) = elh*( sh(k)*dtl(k)+gamt )& + &*dqw(k)*0.5 & + &+elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 + + ! Contergradient terms + tcd(k) = elq*gamt + qcd(k) = elq*gamq + + ! Eddy Diffusivity/Viscosity divided by dz + dfm(k) = elq*sm(k) / dzk + dfh(k) = elq*sh(k) / dzk +! Modified: Dec/22/2005, from here +! ** In sub.mym_predict, dfq for the TKE and scalar variance ** +! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) ** + dfq(k) = dfm(k) +! Modified: Dec/22/2005, up to here + + IF ( bl_mynn_tkebudget == 1) THEN + !TKE BUDGET + dudz = ( u(k)-u(k-1) )/dzk + dvdz = ( v(k)-v(k-1) )/dzk + dTdz = ( thl(k)-thl(k-1) )/dzk + + upwp = -elq*sm(k)*dudz + vpwp = -elq*sm(k)*dvdz + Tpwp = -elq*sh(k)*dTdz + Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp) + + IF ( k .EQ. kts+1 ) THEN + qWT1D(kts)=0. + q3sq_old =0. + qWTP_old =0. + !** Limitation on q, instead of L/q ** + dlsq1 = MAX(el(kts)**2,1.0) + IF ( q3sq_old/dlsq1 .LT. -gh(k) ) q3sq_old = -dlsq1*gh(k) + ENDIF + + !!!Vertical Transport Term + qWTP_new = elq*Sqfac*sm(k)*(q3sq - q3sq_old)/dzk + qWT1D(k) = 0.5*(qWTP_new - qWTP_old)/dzk + qWTP_old = elq*Sqfac*sm(k)*(q3sq - q3sq_old)/dzk + q3sq_old = q3sq + + !!!Shear Term + !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) + qSHEAR1D(k) = elq*sm(k)*gm(k) + + !!!Buoyancy Term + !!!qBUOY1D(k)=g*Tpwp/thl(k) + !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv) + qBUOY1D(k) = elq*(sh(k)*(-dTdz*g/thl(k)) + gamv) + + !!!Dissipation Term + qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) + ENDIF + + END DO +! + + dfm(kts) = 0.0 + dfh(kts) = 0.0 + dfq(kts) = 0.0 + tcd(kts) = 0.0 + qcd(kts) = 0.0 + + tcd(kte) = 0.0 + qcd(kte) = 0.0 + +! + DO k = kts,kte-1 + dzk = dz(k) + tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk ) + qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) + END DO +! + + IF ( bl_mynn_tkebudget == 1) THEN + !JOE-TKE BUDGET + qWT1D(kts)=0. + qSHEAR1D(kts)=qSHEAR1D(kts+1) + qBUOY1D(kts)=qBUOY1D(kts+1) + qDISS1D(kts)=qDISS1D(kts+1) + ENDIF + + if (spp_pbl==1) then + DO k = kts,kte + dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) + dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) + END DO + endif + +! RETURN +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_turbulence + +! ================================================================== +! SUBROUTINE mym_predict: +! +! Input variables: see subroutine mym_initialize and turbulence +! qke(nx,nz,ny) : qke at (n)th time level +! tsq, ...cov : ditto +! +! Output variables: +! qke(nx,nz,ny) : qke at (n+1)th time level +! tsq, ...cov : ditto +! +! Work arrays: +! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s) +! bp (nx,nz,ny) : = 1/2*F, see below +! rp (nx,nz,ny) : = P-1/2*F*Q, see below +! +! # The equation for a turbulent quantity Q can be expressed as +! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1) +! where A is the advection, D the diffusion, P the production, +! F*Q the dissipation and h and v denote horizontal and vertical, +! respectively. If Q is q^2, F is 2q/B_1L. +! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite +! difference equation is written as +! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} ) +! + dt/2*( Dv{n} - Av{n} - F*Q{n} ) +! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2) +! where n denotes the time level. +! When the advection and diffusion terms are discretized as +! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3) +! Eq.(2) can be rewritten as +! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1) +! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} ) +! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4) +! where Q on the left-hand side is at (n+1)th time level. +! +! In this subroutine, a(k), b(k) and c(k) are obtained from +! subprogram coefvu and are passed to subprogram tinteg via +! common. 1/2*F and P-1/2*F*Q are stored in bp and rp, +! respectively. Subprogram tinteg solves Eq.(4). +! +! Modify this subroutine according to your numerical integration +! scheme (program). +! +!------------------------------------------------------------------- + SUBROUTINE mym_predict (kts,kte,& + & levflag, & + & delt,& + & dz, & + & ust, flt, flq, pmz, phh, & + & el, dfq, & + & pdk, pdt, pdq, pdc,& + & qke, tsq, qsq, cov, & + & s_aw,s_awqke,bl_mynn_edmf_tke & + &) + +!------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + INTEGER, INTENT(IN) :: levflag + INTEGER, INTENT(IN) :: bl_mynn_edmf_tke + REAL, INTENT(IN) :: delt + REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq,el + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc + REAL, INTENT(IN) :: flt, flq, ust, pmz, phh + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov +! WA 8/3/15 + REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw + + INTEGER :: k + REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q + REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff + REAL, DIMENSION(kts:kte) :: dtz + REAL, DIMENSION(kts:kte) :: a,b,c,d,x + + + ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) + IF (bl_mynn_edmf_tke == 0) THEN + onoff=0.0 + ELSE + onoff=1.0 + ENDIF + +! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** + vkz = vk*0.5*dz(kts) +! +! ** dfq for the TKE is 3.0*dfm. ** +! + DO k = kts,kte +!! qke(k) = MAX(qke(k), 0.0) + qkw(k) = SQRT( MAX( qke(k), 0.0 ) ) + df3q(k)=Sqfac*dfq(k) + dtz(k)=delt/dz(k) + END DO +! + pdk1 = 2.0*ust**3*pmz/( vkz ) + phm = 2.0/ust *phh/( vkz ) + pdt1 = phm*flt**2 + pdq1 = phm*flq**2 + pdc1 = phm*flt*flq +! +! ** pdk(i,j,1)+pdk(i,j,2) corresponds to pdk1. ** + pdk(kts) = pdk1 -pdk(kts+1) + +!! pdt(kts) = pdt1 -pdt(kts+1) +!! pdq(kts) = pdq1 -pdq(kts+1) +!! pdc(kts) = pdc1 -pdc(kts+1) + pdt(kts) = pdt(kts+1) + pdq(kts) = pdq(kts+1) + pdc(kts) = pdc(kts+1) +! +! ** Prediction of twice the turbulent kinetic energy ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b1l = b1*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b1l + rp(k) = pdk(k+1) + pdk(k) + END DO + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt. + DO k=kts,kte-1 +! a(k-kts+1)=-dtz(k)*df3q(k) +! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt +! c(k-kts+1)=-dtz(k)*df3q(k+1) +! d(k-kts+1)=rp(k)*delt + qke(k) +! WA 8/3/15 add EDMF contribution + a(k-kts+1)=-dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff + b(k-kts+1)=1. + dtz(k)*(df3q(k)+df3q(k+1)) & + + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt + c(k-kts+1)=-dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(k-kts+1)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*df3q(k) +!! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1)) +!! c(k-kts+1)=-dtz(k)*df3q(k+1) +!! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! qke(k)=max(d(k-kts+1), 1.e-4) + qke(k)=max(x(k), 1.e-4) + ENDDO + + + IF ( levflag .EQ. 3 ) THEN +! +! Modified: Dec/22/2005, from here +! ** dfq for the scalar variance is 1.0*dfm. ** +! CALL coefvu ( dfq, 1.0 ) make change here +! Modified: Dec/22/2005, up to here +! +! ** Prediction of the temperature variance ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdt(k+1) + pdt(k) + END DO + +!zero gradient for tsq at bottom and top + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + a(k-kts+1)=-dtz(k)*dfq(k) + b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + c(k-kts+1)=-dtz(k)*dfq(k+1) + d(k-kts+1)=rp(k)*delt + tsq(k) + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*dfq(k) +!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) +!! c(k-kts+1)=-dtz(k)*dfq(k+1) +!! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! tsq(k)=d(k-kts+1) + tsq(k)=x(k) + ENDDO + +! ** Prediction of the moisture variance ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdq(k+1) +pdq(k) + END DO + +!zero gradient for qsq at bottom and top + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + a(k-kts+1)=-dtz(k)*dfq(k) + b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + c(k-kts+1)=-dtz(k)*dfq(k+1) + d(k-kts+1)=rp(k)*delt + qsq(k) + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*dfq(k) +!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) +!! c(k-kts+1)=-dtz(k)*dfq(k+1) +!! d(k-kts+1)=rp(k)*delt + qsq(k) -qsq(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! qsq(k)=d(k-kts+1) + qsq(k)=x(k) + ENDDO + +! ** Prediction of the temperature-moisture covariance ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdc(k+1) + pdc(k) + END DO + +!zero gradient for tqcov at bottom and top + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + a(k-kts+1)=-dtz(k)*dfq(k) + b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + c(k-kts+1)=-dtz(k)*dfq(k+1) + d(k-kts+1)=rp(k)*delt + cov(k) + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*dfq(k) +!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) +!! c(k-kts+1)=-dtz(k)*dfq(k+1) +!! d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! cov(k)=d(k-kts+1) + cov(k)=x(k) + ENDDO + + ELSE +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + IF ( qkw(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) + END IF +! + tsq(k) = b2l*( pdt(k+1)+pdt(k) ) + qsq(k) = b2l*( pdq(k+1)+pdq(k) ) + cov(k) = b2l*( pdc(k+1)+pdc(k) ) + END DO + +!! tsq(kts)=tsq(kts+1) +!! qsq(kts)=qsq(kts+1) +!! cov(kts)=cov(kts+1) + + tsq(kte)=tsq(kte-1) + qsq(kte)=qsq(kte-1) + cov(kte)=cov(kte-1) + + END IF + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_predict + +! ================================================================== +! SUBROUTINE mym_condensation: +! +! Input variables: see subroutine mym_initialize and turbulence +! exner(nz) : Perturbation of the Exner function (J/kg K) +! defined on the walls of the grid boxes +! This is usually computed by integrating +! d(pi)/dz = h*g*tv/tref**2 +! from the upper boundary, where tv is the +! virtual potential temperature minus tref. +! +! Output variables: see subroutine mym_initialize +! cld(nx,nz,ny) : Cloud fraction +! +! Work arrays: +! qmq(nx,nz,ny) : Q_w-Q_{sl}, where Q_{sl} is the saturation +! specific humidity at T=Tl +! alp(nx,nz,ny) : Functions in the condensation process +! bet(nx,nz,ny) : ditto +! sgm(nx,nz,ny) : Combined standard deviation sigma_s +! multiplied by 2/alp +! +! # qmq, alp, bet and sgm are allowed to share storage units with +! any four of other work arrays for saving memory. +! +! # Results are sensitive particularly to values of cp and rd. +! Set these values to those adopted by you. +! +!------------------------------------------------------------------- + SUBROUTINE mym_condensation (kts,kte, & + & dx, dz, & + & thl, qw, & + & p,exner, & + & tsq, qsq, cov, & + & Sh, el, bl_mynn_cloudpdf,& + & qc_bl1D, cldfra_bl1D, & + & PBLH1,HFX1, & + & Vt, Vq, th, sgm, rmo, & + & spp_pbl,rstoch_col ) + +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo + REAL, DIMENSION(kts:kte), INTENT(IN) :: dz + REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, & + &tsq, qsq, cov, th + + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm + + REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,cld,RH + REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,cldfra_bl1D + DOUBLE PRECISION :: t3sq, r3sq, c3sq + + REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,eq1,qll,& + &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,ls_min,ls,wt + INTEGER :: i,j,k + + REAL :: erf + + !JOE: NEW VARIABLES FOR ALTERNATE SIGMA + REAL::dth,dtl,dqw,dzk,els + REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el + + !JOE: variables for BL clouds + REAL::zagl,cld9,damp,edown,RHcrit,RHmean,RHsum,RHnum,Hshcu,PBLH2,ql_limit + REAL, PARAMETER :: Hfac = 3.0 !cloud depth factor for HFX (m^3/W) + REAL, PARAMETER :: HFXmin = 50.0 !min W/m^2 for BL clouds + REAL :: RH_00L, RH_00O, phi_dz, lfac + REAL, PARAMETER :: cdz = 2.0 + REAL, PARAMETER :: mdz = 1.5 + + !JAYMES: variables for tropopause-height estimation + REAL :: theta1, theta2, ht1, ht2 + INTEGER :: k_tropo + +! Stochastic + INTEGER, INTENT(IN) :: spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col + REAL :: qw_pert + +! First, obtain an estimate for the tropopause height (k), using the method employed in the +! Thompson subgrid-cloud scheme. This height will be a consideration later when determining +! the "final" subgrid-cloud properties. +! JAYMES: added 3 Nov 2016, adapted from G. Thompson + + DO k = kte-3, kts, -1 + theta1 = th(k) + theta2 = th(k+2) + ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190) + ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190) + if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & + & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then + goto 86 + endif + ENDDO + 86 continue + k_tropo = MAX(kts+2, k+2) + + zagl = 0. + + SELECT CASE(bl_mynn_cloudpdf) + + CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME + + DO k = kts,kte-1 + t = th(k)*exner(k) + +!x if ( ct .gt. 0.0 ) then +! a = 17.27 +! b = 237.3 +!x else +!x a = 21.87 +!x b = 265.5 +!x end if +! +! ** 3.8 = 0.622*6.11 (hPa) ** + + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + !NOTE: negative bl_mynn_cloudpdf will zero-out the stratus subgrid clouds + ! at the end of this subroutine. + !Sommeria and Deardorff (1977) scheme, as implemented + !in Nakanishi and Niino (2009), Appendix B + t3sq = MAX( tsq(k), 0.0 ) + r3sq = MAX( qsq(k), 0.0 ) + c3sq = cov(k) + c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) + r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq + !DEFICIT/EXCESS WATER CONTENT + qmq(k) = qw(k) -qsl + !ORIGINAL STANDARD DEVIATION: limit e-6 produces ~10% more BL clouds + !than e-10 + sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) + !NORMALIZED DEPARTURE FROM SATURATION + q1(k) = qmq(k) / sgm(k) + !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 + cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + + END DO + + CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and + !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = 0.5*( dz(k) + dz(k-1) ) + end if + dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & + b2 * MAX(Sh(k),0.03))/4. * & + (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) + qmq(k) = qw(k) -qsl + q1(k) = qmq(k) / sgm(k) + cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + END DO + + CASE (2, -2) + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !JAYMES- this added 27 Apr 2015 + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + xl = xl_blend(t) ! obtain latent heat + + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + + !SPP + qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) + + !qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; + ! the numerator of Q1 + qmq(k) = a(k) * (qw_pert - qsat_tl) + + b(k) = a(k)*rsl ! CB02 variable "b" + + dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & + & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) + + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = 0.5*( dz(k) + dz(k-1) ) + end if + + cdhdz = dtl/dzk + (g/cpm)*(1.+qw(k)) ! expression below Eq. 9 + ! in CB02 + + zagl = zagl + dz(k) + !Use analog to surface layer length scale to make the cloud mixing length scale + !become less than z in stable conditions. + els = zagl/(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) + + ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) + ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: + if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) + ! 25 m < ls_min(=zagl) < 300 m + lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: + ! lfac(750 m) = 4.4 + ! lfac(3 km) = 5.0 + ! lfac(13 km) = 6.0 + + ls = MAX(MIN(lfac*el(k),600.),ls_min) ! Bounded: ls_min < ls < 600 m + ! Note: CB02 use 900 m as a constant free-atmosphere length scale. + + ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the + ! MYNN master length scale (el) must exceed 60 m before ls + ! becomes responsive to el, otherwise ls = ls_min = 300 m. + + sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: + & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, + & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, + & +b(k)**2 * cdhdz**2))) ! < 3rd term + ! CB02 use a multiplier of 0.2, but 0.225 is chosen + ! based on tests + + q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation + + cld(k) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 + + END DO + + END SELECT + + zagl = 0. + RHsum=0. + RHnum=0. + RHmean=0.1 !initialize with small value for small PBLH cases + damp =0 + PBLH2=MAX(10.,PBLH1) + + SELECT CASE(bl_mynn_cloudpdf) + + CASE (-1 : 1) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME + ! OR KUWANO ET AL. + DO k = kts,kte-1 + t = th(k)*exner(k) + q1k = q1(k) + zagl = zagl + dz(k) + !q1=0. + !cld(k)=0. + + !COMPUTE MEAN RH IN PBL (NOT PRESSURE WEIGHTED). + IF (zagl < PBLH2 .AND. PBLH2 > 400.) THEN + RHsum=RHsum+RH(k) + RHnum=RHnum+1.0 + RHmean=RHsum/RHnum + ENDIF + + RHcrit = 1. - 0.35*(1.0 - (MAX(250.- MAX(HFX1,HFXmin),0.0)/200.)**2) + if (HFX1 > HFXmin) then + cld9=MIN(MAX(0., (rh(k)-RHcrit)/(1.1-RHcrit)), 1.)**2 + else + cld9=0.0 + endif + + edown=PBLH2*.1 + !Vary BL cloud depth (Hshcu) by mean RH in PBL and HFX + !(somewhat following results from Zhang and Klein (2013, JAS)) + Hshcu=200. + (RHmean+0.5)**1.5*MAX(HFX1,0.)*Hfac + if (zagl < PBLH2-edown) then + damp=MIN(1.0,exp(-ABS(((PBLH2-edown)-zagl)/edown))) + elseif(zagl >= PBLH2-edown .AND. zagl < PBLH2+Hshcu)then + damp=1. + elseif (zagl >= PBLH2+Hshcu)then + damp=MIN(1.0,exp(-ABS((zagl-(PBLH2+Hshcu))/500.))) + endif + cldfra_bl1D(k)=cld9*damp + !cldfra_bl1D(k)=cld(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value + + !use alternate cloud fraction to estimate qc for use in BL clouds-radiation + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql (k) = alp(k)*sgm(k)*qll + if(cldfra_bl1D(k)>0.01 .and. ql(k)<1.E-6)ql(k)=1.E-6 + qc_bl1D(k)=ql(k)*damp + !qc_bl1D(k)=ql(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value + + !now recompute estimated lwc for PBL scheme's use + !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and + !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cld(k)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql (k) = alp(k)*sgm(k)*qll + + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*ql(k) ! potential temp + + !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) + qt = 1.0 +p608*qw(k) -(1.+p608)*ql(k) + rac = alp(k)*( cld(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) + + !BUOYANCY FACTORS: wherever vt and vq are used, there is a + !"+1" and "+tv0", respectively, so these are subtracted out here. + !vt is unitless and vq has units of K. + vt(k) = qt-1.0 -rac*bet(k) + vq(k) = p608*pt-tv0 +rac + + !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, + ! add limit to qc_bl and cldfra_bl: + IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 + IF (CLDFRA_BL1D(k) < 1E-2)THEN + CLDFRA_BL1D(k)=0. + QC_BL1D(k)=0. + ENDIF + + END DO + CASE ( 2, -2) + ! JAYMES- this option added 8 May 2015 + ! The cloud water formulations are taken from CB02, Eq. 8. + ! "fng" represents the non-Gaussian contribution to the liquid + ! water flux; these formulations are from Cuijpers and Bechtold + ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, + ! hereafter BCMT95 + DO k = kts,kte-1 + t = th(k)*exner(k) + q1k = q1(k) + zagl = zagl + dz(k) + IF (q1k < 0.) THEN + ql (k) = sgm(k)*EXP(1.2*q1k-1) + ELSE IF (q1k > 2.) THEN + ql (k) = sgm(k)*q1k + ELSE + ql (k) = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) + ENDIF + + !Above tropopause: eliminate subgrid clouds from CB scheme + if (k .ge. k_tropo-1) then + cld(k) = 0. + ql(k) = 0. + endif + + !Buoyancy-flux-related calculations follow... + ! "Fng" represents the non-Gaussian transport factor + ! (non-dimensional) from from Bechtold et al. 1995 + ! (hereafter BCMT95), section 3(c). Their suggested + ! forms for Fng (from their Eq. 20) are: + !IF (q1k < -2.) THEN + ! Fng = 2.-q1k + !ELSE IF (q1k > 0.) THEN + ! Fng = 1. + !ELSE + ! Fng = 1.-1.5*q1k + !ENDIF + ! For purposes of the buoyancy flux in stratus, we will use Fng = 1 + !Fng = 1. + Q1(k)=MAX(Q1(k),-5.0) + IF (Q1(k) .GE. 1.0) THEN + Fng = 1.0 + ELSEIF (Q1(k) .GE. -1.7 .AND. Q1(k) < 1.0) THEN + Fng = EXP(-0.4*(Q1(k)-1.0)) + ELSEIF (Q1(k) .GE. -2.5 .AND. Q1(k) .LE. -1.7) THEN + Fng = 3.0 + EXP(-3.8*(Q1(k)+1.7)) + ELSE + Fng = MIN(23.9 + EXP(-1.6*(Q1(k)+2.5)), 60.) + ENDIF + Fng = MIN(Fng, 20.) + + xl = xl_blend(t) + bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor + ! of T/theta. Strictly, b(k) above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qw(k) + alpha = 0.61*th(k) + beta = (th(k)/t)*(xl/cp) - 1.61*th(k) + + vt(k) = qww - MIN(cld(k),0.99)*beta*bb*Fng - 1. + vq(k) = alpha + MIN(cld(k),0.99)*beta*a(k)*Fng - tv0 + ! vt and vq correspond to beta-theta and beta-q, respectively, + ! in NN09, Eq. B8. They also correspond to the bracketed + ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng + ! The "-1" and "-tv0" terms are included for consistency with + ! the legacy vt and vq formulations (above). + + ! increase the cloud fraction estimate below PBLH+1km + if (zagl .lt. PBLH2+1000.) cld(k) = MIN( 1., 1.5*cld(k) ) + ! return a cloud condensate and cloud fraction for icloud_bl option: + cldfra_bl1D(k) = cld(k) + qc_bl1D(k) = ql(k) + + !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, + ! add limit to qc_bl and cldfra_bl: + IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 + IF (CLDFRA_BL1D(k) < 1E-2)THEN + CLDFRA_BL1D(k)=0. + QC_BL1D(k)=0. + ENDIF + + END DO + + END SELECT !end cloudPDF option + + !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. + IF (bl_mynn_cloudpdf .LT. 0) THEN + DO k = kts,kte-1 + cldfra_bl1D(k) = 0.0 + qc_bl1D(k) = 0.0 + END DO + ENDIF +! + cld(kte) = cld(kte-1) + ql(kte) = ql(kte-1) + vt(kte) = vt(kte-1) + vq(kte) = vq(kte-1) + qc_bl1D(kte)=0. + cldfra_bl1D(kte)=0. + + RETURN + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_condensation + +! ================================================================== + SUBROUTINE mynn_tendencies(kts,kte, & + &levflag,grav_settling, & + &delt,dz,rho, & + &u,v,th,tk,qv,qc,qi,qnc,qni, & + &p,exner, & + &thl,sqv,sqc,sqi,sqw, & + &qnwfa,qnifa, & + &ust,flt,flq,flqv,flqc,wspd,qcg, & + &uoce,voce, & + &tsq,qsq,cov, & + &tcd,qcd, & + &dfm,dfh,dfq, & + &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & + &Dqnwfa,Dqnifa, & + &vdfg1,diss_heat, & + &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & + &s_awu,s_awv, & + &s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa, & + &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & + &FLAG_QNWFA,FLAG_QNIFA, & + &cldfra_bl1d, & + &ztop_shallow,ktop_shallow, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) + +!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + INTEGER, INTENT(in) :: grav_settling,levflag + INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& + bl_mynn_edmf,bl_mynn_edmf_mom, & + bl_mynn_mixscalars + LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& + FLAG_QNWFA,FLAG_QNIFA + +!! grav_settling = 1 or 2 for gravitational settling of droplets +!! grav_settling = 0 otherwise +! thl - liquid water potential temperature +! qw - total water +! dfm,dfh,dfq - as above +! flt - surface flux of thl +! flq - surface flux of qw + + REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,& + &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv,s_awqnwfa,s_awqnifa + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qni,qnc,& + &rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d,diss_heat + REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,& + &qnwfa,qnifa,dfm,dfh + REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& + &dqni,dqnc,dqnwfa,dqnifa + REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg,& + ztop_shallow + INTEGER, INTENT(IN) :: ktop_shallow + +! REAL, INTENT(IN) :: delt,ust,flt,flq,qcg,& +! &gradu_top,gradv_top,gradth_top,gradqv_top + +!local vars + + REAL, DIMENSION(kts:kte) :: dtz,vt,vq,dfhc,dfmc !Kh for clouds (Pr < 2) + REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING + qnwfa2,qnifa2 + REAL, DIMENSION(kts:kte) :: zfac,plumeKh + REAL, DIMENSION(kts:kte) :: a,b,c,d,x + REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface + & khdz, kmdz + REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw + REAL :: grav_settling2,vdfg1 !Katata-fogdes + REAL :: t,esat,qsl,onoff,kh,km,dzk + INTEGER :: k,kk + + !Activate nonlocal mixing from the mass-flux scheme for + !scalars (0.0 = no; 1.0 = yes) + REAL, PARAMETER :: nonloc = 0.0 + + dztop=.5*(dz(kte)+dz(kte-1)) + + ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) + ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so + ! we only need to zero-out the MF term + IF (bl_mynn_edmf_mom == 0) THEN + onoff=0.0 + ELSE + onoff=1.0 + ENDIF + + !Prepare "constants" for diffusion equation. + !khdz = rho*Kh/dz + dtz(kts)=delt/dz(kts) + kh=dfh(kts)*dz(kts) + km=dfm(kts)*dz(kts) + rhoz(kts)=rho(kts) + khdz(kts)=rhoz(kts)*kh/dz(kts) + kmdz(kts)=rhoz(kts)*km/dz(kts) + DO k=kts+1,kte + dtz(k)=delt/dz(k) + rhoz(k)=(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) + + dzk = 0.5 *( dz(k)+dz(k-1) ) + kh = dfh(k)*dzk + km = dfm(k)*dzk + khdz(k)= rhoz(k)*kh/dzk + kmdz(k)= rhoz(k)*km/dzk + ENDDO + rhoz(kte+1)=rho(kte) + kh=dfh(kte)*dz(kte) + km=dfm(kte)*dz(kte) + khdz(kte+1)=rhoz(kte+1)*kh/dz(kte) + kmdz(kte+1)=rhoz(kte+1)*km/dz(kte) + +!!============================================ +!! u +!!============================================ + + k=kts + + a(1)=0. + b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff + c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + +!JOE - tend test +! a(k)=0. +! b(k)=1.+dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! c(k)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + & +! dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + + DO k=kts+1,kte-1 + a(k)= - dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff + b(k)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + c(k)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*(s_awu(k)-s_awu(k+1))*onoff + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradu_top*dztop + +!! prescribed value + a(kte)=0 + b(kte)=1. + c(kte)=0. + d(kte)=u(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! du(k)=(d(k-kts+1)-u(k))/delt + du(k)=(x(k)-u(k))/delt + ENDDO + +!!============================================ +!! v +!!============================================ + + k=kts + + a(1)=0. + b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff + c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +!! d(1)=v(k) + d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + +!JOE - tend test +! a(k)=0. +! b(k)=1.+dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! c(k)= -dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + & +! dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + + DO k=kts+1,kte-1 + a(k)= - dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff + b(k)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + c(k)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*(s_awv(k)-s_awv(k+1))*onoff + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradv_top*dztop + +!! prescribed value + a(kte)=0 + b(kte)=1. + c(kte)=0. + d(kte)=v(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! dv(k)=(d(k-kts+1)-v(k))/delt + dv(k)=(x(k)-v(k))/delt + ENDDO + +!!============================================ +!! thl tendency +!! NOTE: currently, gravitational settling is removed +!!============================================ + k=kts + + a(k)=0. + b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & + & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt*dheat_opt + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) & + & + diss_heat(k)*delt*dheat_opt + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +!assume gradthl_top=gradth_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradth_top*dztop + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=thl(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte + !thl(k)=d(k-kts+1) + thl(k)=x(k) + ENDDO + +IF (bl_mynn_mixqt > 0) THEN + !============================================ + ! MIX total water (sqw = sqc + sqv + sqi) + ! NOTE: no total water tendency is output; instead, we must calculate + ! the saturation specific humidity and then + ! subtract out the moisture excess (sqc & sqi) + !============================================ + + k=kts + + a(k)=0. + b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + + !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& + + d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + + d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. +!! specified gradient at the top +!assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqw(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqw2) + +! DO k=kts,kte +! sqw2(k)=d(k-kts+1) +! ENDDO +ELSE + sqw2=sqw +ENDIF + +IF (bl_mynn_mixqt == 0) THEN +!============================================ +! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0), +! then sqc will be backed out of saturation check (below). +!============================================ + IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN + + k=kts + + a(k)=0. + b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + + d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt -dtz(k)*s_awqc(k+1) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + + d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqc(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqc2) + +! DO k=kts,kte +! sqc2(k)=d(k-kts+1) +! ENDDO + ELSE + !If not mixing clouds, set "updated" array equal to original array + sqc2=sqc + ENDIF +ENDIF + +IF (bl_mynn_mixqt == 0) THEN + !============================================ + ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0), + ! then sqv will be backed out of saturation check (below). + !============================================ + + k=kts + + a(k)=0. + b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + ENDDO + +! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +! specified gradient at the top +! assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqv(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqv2) + +! DO k=kts,kte +! sqv2(k)=d(k-kts+1) +! ENDDO +ELSE + sqv2=sqv +ENDIF + +!============================================ +! MIX CLOUD ICE ( sqi ) +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN + + k=kts + + a(k)=0. + b(k)=1.+dtz(k)*dfh(k+1) + c(k)= -dtz(k)*dfh(k+1) + d(k)=sqi(k) !+ qcd(k)*delt !should we have qcd for ice? + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*dfh(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + c(k)= -dtz(k)*dfh(k+1) + d(k)=sqi(k) !+ qcd(k)*delt + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +!assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqi(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqi2) + +! DO k=kts,kte +! sqi2(k)=d(k-kts+1) +! ENDDO +ELSE + sqi2=sqi +ENDIF + +!!============================================ +!! cloud ice number concentration (qni) +!!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNI .AND. & + bl_mynn_mixscalars > 0) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)/rho(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qni(k) - dtz(k)*s_awqni(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))/rho(k) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qni(k) + dtz(k)*(s_awqni(k)-s_awqni(k+1))*nonloc + ENDDO + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qni(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qni2(k)=d(k-kts+1) + qni2(k)=x(k) + ENDDO + +ELSE + qni2=qni +ENDIF + +!!============================================ +!! cloud water number concentration (qnc) +!! include non-local transport +!!============================================ + IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. & + bl_mynn_mixscalars > 0) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)/rho(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnc(k) - dtz(k)*s_awqnc(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))/rho(k) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnc(k) + dtz(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc + ENDDO + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnc(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnc2(k)=d(k-kts+1) + qnc2(k)=x(k) + ENDDO + +ELSE + qnc2=qnc +ENDIF + +!============================================ +! Water-friendly aerosols ( qnwfa ). +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNWFA .AND. & + bl_mynn_mixscalars > 0) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)/rho(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) - & + & 0.5*dtz(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnwfa(k) - dtz(k)*s_awqnwfa(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnwfa(k) + dtz(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnwfa(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnwfa2(k)=d(k) + qnwfa2(k)=x(k) + ENDDO + +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnwfa2=qnwfa +ENDIF + +!============================================ +! Ice-friendly aerosols ( qnifa ). +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNIFA .AND. & + bl_mynn_mixscalars > 0) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)/rho(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) - & + & 0.5*dtz(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnifa(k) - dtz(k)*s_awqnifa(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnifa(k) + dtz(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnifa(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnifa2(k)=d(k-kts+1) + qnifa2(k)=x(k) + ENDDO + +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnifa2=qnifa +ENDIF + + +!!============================================ +!! Compute tendencies and convert to mixing ratios for WRF. +!! Note that the momentum tendencies are calculated above. +!!============================================ + + IF (bl_mynn_mixqt > 0) THEN + DO k=kts,kte + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat=esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + + !IF (qsl >= sqw2(k)) THEN !unsaturated + ! sqv2(k) = MAX(0.0,sqw2(k)) + ! sqi2(k) = MAX(0.0,sqi2(k)) + ! sqc2(k) = MAX(0.0,sqw2(k) - sqv2(k) - sqi2(k)) + !ELSE !saturated + IF (FLAG_QI) THEN + !sqv2(k) = qsl + sqi2(k) = MAX(0., sqi2(k)) + sqc2(k) = MAX(0., sqw2(k) - sqi2(k) - qsl) !updated cloud water + sqv2(k) = MAX(0., sqw2(k) - sqc2(k) - sqi2(k)) !updated water vapor + ELSE + !sqv2(k) = qsl + sqi2(k) = 0.0 + sqc2(k) = MAX(0., sqw2(k) - qsl) !updated cloud water + sqv2(k) = MAX(0., sqw2(k) - sqc2(k)) ! updated water vapor + ENDIF + !ENDIF + ENDDO + ENDIF + + !===================== + ! WATER VAPOR TENDENCY + !===================== + DO k=kts,kte + Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt + !IF(-Dqv(k) > qv(k)) Dqv(k)=-qv(k) + ENDDO + + IF (bl_mynn_cloudmix > 0) THEN + !===================== + ! CLOUD WATER TENDENCY + !===================== + !qc fog settling tendency is now computed in module_bl_fogdes.F, so + !sqc should only be changed by eddy diffusion or mass-flux. + !print*,"FLAG_QC:",FLAG_QC + IF (FLAG_QC) THEN + DO k=kts,kte + Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt + IF(Dqc(k)*delt + qc(k) < 0.) THEN + !print*,' neg qc:',qsl,sqw2(k),sqi2(k),sqc2(k),qc(k),tk(k) + Dqc(k)=-qc(k)/delt + ENDIF + ENDDO + ELSE + DO k=kts,kte + Dqc(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD WATER NUM CONC TENDENCY + !=================== + IF (FLAG_QNC .AND. bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + !IF(sqc2(k)>1.e-9)qnc2(k)=MAX(qnc2(k),1.e6) + Dqnc(k) = (qnc2(k)-qnc(k))/delt + !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt + ENDDO + ELSE + DO k=kts,kte + Dqnc(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD ICE TENDENCY + !=================== + IF (FLAG_QI) THEN + DO k=kts,kte + Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt + IF(Dqi(k)*delt + qi(k) < 0.) THEN + ! !print*,' neg qi;',qsl,sqw2(k),sqi2(k),sqc2(k),qi(k),tk(k) + Dqi(k)=-qi(k)/delt + ENDIF + ENDDO + ELSE + DO k=kts,kte + Dqi(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD ICE NUM CONC TENDENCY + !=================== + IF (FLAG_QNI .AND. bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + Dqni(k)=(qni2(k)-qni(k))/delt + !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt + ENDDO + ELSE + DO k=kts,kte + Dqni(k)=0. + ENDDO + ENDIF + ELSE !-MIX CLOUD SPECIES? + !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0) + DO k=kts,kte + Dqc(k)=0. + Dqnc(k)=0. + Dqi(k)=0. + Dqni(k)=0. + ENDDO + ENDIF + + !=================== + ! THETA TENDENCY + !=================== + IF (FLAG_QI) THEN + DO k=kts,kte + Dth(k)=(thl(k) + xlvcp/exner(k)*sqc(k) & + & + xlscp/exner(k)*sqi(k) & + & - th(k))/delt + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy: + !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k) & + ! & + xlscp/MAX(tk(k),TKmin)*sqi2(k)) & + ! & - th(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k)) & + !& - th(k))/delt + ENDDO + ENDIF + + !=================== + ! AEROSOL TENDENCIES + !=================== + IF (FLAG_QNWFA .AND. FLAG_QNIFA .AND. & + bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + !===================== + ! WATER-friendly aerosols + !===================== + Dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt + !===================== + ! Ice-friendly aerosols + !===================== + Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqnwfa(k)=0. + Dqnifa(k)=0. + ENDDO + ENDIF + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mynn_tendencies + +! ================================================================== +#if (WRF_CHEM == 1) + SUBROUTINE mynn_mix_chem(kts,kte, & + levflag,grav_settling, & + delt,dz, & + nchem, kdvel, ndvel, num_vert_mix, & + chem1, vd1, & + qnc,qni, & + p,exner, & + thl,sqv,sqc,sqi,sqw, & + ust,flt,flq,flqv,flqc,wspd,qcg, & + uoce,voce, & + tsq,qsq,cov, & + tcd,qcd, & + dfm,dfh,dfq, & + s_aw, & + s_awchem, & + bl_mynn_cloudmix) + +!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kts,kte + INTEGER, INTENT(in) :: grav_settling,levflag + INTEGER, INTENT(in) :: bl_mynn_cloudmix + + REAL, DIMENSION(kts:kte), INTENT(IN) :: qni,qnc,& + &p,exner,dfm,dfh,dfq,dz,tsq,qsq,cov,tcd,qcd + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: thl,sqw,sqv,sqc,sqi + REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg + INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix + REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw + REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 + REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem + REAL, DIMENSION( ndvel ), INTENT(INOUT) :: vd1 + +!local vars + + REAL, DIMENSION(kts:kte) :: dtz,vt,vq + REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d + REAL :: rhs,gfluxm,gfluxp,dztop + REAL :: t,esl,qsl + INTEGER :: k,kk + INTEGER :: ic ! Chemical array loop index + REAL, DIMENSION( kts:kte, nchem ) :: chem_new + + dztop=.5*(dz(kte)+dz(kte-1)) + + DO k=kts,kte + dtz(k)=delt/dz(k) + ENDDO + + !============================================ + ! Patterned after mixing of water vapor in mynn_tendencies. + !============================================ + + DO ic = 1,nchem + k=kts + + a(1)=0. + b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(1)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) - dtz(k)*s_awchem(k+1,ic) + + DO k=kts+1,kte-1 + a(k)=-dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + ! d(kk)=chem1(k,ic) + qcd(k)*delt + d(k)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) + ENDDO + + ! prescribed value at top + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=chem1(kte,ic) + + CALL tridiag(kte,a,b,c,d) + + DO k=kts,kte + chem_new(k,ic)=d(k-kts+1) + ENDDO + ENDDO + + END SUBROUTINE mynn_mix_chem +#endif + +! ================================================================== + SUBROUTINE retrieve_exchange_coeffs(kts,kte,& + &dfm,dfh,dz,K_m,K_h) + +!------------------------------------------------------------------- + + INTEGER , INTENT(in) :: kts,kte + + REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh + + REAL, DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h + + + INTEGER :: k + REAL :: dzk + + K_m(kts)=0. + K_h(kts)=0. + + DO k=kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + K_m(k)=dfm(k)*dzk + K_h(k)=dfh(k)*dzk + ENDDO + + END SUBROUTINE retrieve_exchange_coeffs + +! ================================================================== + SUBROUTINE tridiag(n,a,b,c,d) + +!! to solve system of linear eqs on tridiagonal matrix n times n +!! after Peaceman and Rachford, 1955 +!! a,b,c,d - are vectors of order n +!! a,b,c - are coefficients on the LHS +!! d - is initially RHS on the output becomes a solution vector + +!------------------------------------------------------------------- + + INTEGER, INTENT(in):: n + REAL, DIMENSION(n), INTENT(in) :: a,b + REAL, DIMENSION(n), INTENT(inout) :: c,d + + INTEGER :: i + REAL :: p + REAL, DIMENSION(n) :: q + + c(n)=0. + q(1)=-c(1)/b(1) + d(1)=d(1)/b(1) + + DO i=2,n + p=1./(b(i)+a(i)*q(i-1)) + q(i)=-c(i)*p + d(i)=(d(i)-a(i)*d(i-1))*p + ENDDO + + DO i=n-1,1,-1 + d(i)=d(i)+q(i)*d(i+1) + ENDDO + + END SUBROUTINE tridiag + +! ================================================================== + subroutine tridiag2(n,a,b,c,d,x) + implicit none +! a - sub-diagonal (means it is the diagonal below the main diagonal) +! b - the main diagonal +! c - sup-diagonal (means it is the diagonal above the main diagonal) +! d - right part +! x - the answer +! n - number of unknowns (levels) + + integer,intent(in) :: n + real, dimension(n),intent(in) :: a,b,c,d + real ,dimension(n),intent(out) :: x + real ,dimension(n) :: cp,dp + real :: m + integer :: i + + ! initialize c-prime and d-prime + cp(1) = c(1)/b(1) + dp(1) = d(1)/b(1) + ! solve for vectors c-prime and d-prime + do i = 2,n + m = b(i)-cp(i-1)*a(i) + cp(i) = c(i)/m + dp(i) = (d(i)-dp(i-1)*a(i))/m + enddo + ! initialize x + x(n) = dp(n) + ! solve for x from the vectors c-prime and d-prime + do i = n-1, 1, -1 + x(i) = dp(i)-cp(i)*x(i+1) + end do + + end subroutine tridiag2 +! ================================================================== + subroutine tridiag3(kte,a,b,c,d,x) + +!ccccccccccccccccccccccccccccccc +! Aim: Inversion and resolution of a tridiagonal matrix +! A X = D +! Input: +! a(*) lower diagonal (Ai,i-1) +! b(*) principal diagonal (Ai,i) +! c(*) upper diagonal (Ai,i+1) +! d +! Output +! x results +!ccccccccccccccccccccccccccccccc + + implicit none + integer,intent(in) :: kte + integer, parameter :: kts=1 + real, dimension(kte) :: a,b,c,d + real ,dimension(kte),intent(out) :: x + integer :: in + +! integer kms,kme,kts,kte,in +! real a(kms:kme,3),c(kms:kme),x(kms:kme) + + do in=kte-1,kts,-1 + d(in)=d(in)-c(in)*d(in+1)/b(in+1) + b(in)=b(in)-c(in)*a(in+1)/b(in+1) + enddo + + do in=kts+1,kte + d(in)=d(in)-a(in)*d(in-1)/b(in-1) + enddo + + do in=kts,kte + x(in)=d(in)/b(in) + enddo + + return + end subroutine tridiag3 +! ================================================================== + SUBROUTINE mynn_bl_driver( & + &initflag,restart,grav_settling, & + &delt,dz,dx,znt, & + &u,v,w,th,qv,qc,qi,qnc,qni, & + &qnwfa,qnifa, & + &p,exner,rho,T3D, & + &xland,ts,qsfc,qcg,ps, & + &ust,ch,hfx,qfx,rmol,wspd, & + &uoce,voce, & !ocean current + &vdfg, & !Katata-added for fog dep + &Qke,tke_pbl, & + &qke_adv,bl_mynn_tkeadvect, & !ACF for QKE advection +#if (WRF_CHEM == 1) + chem3d, vd3d, nchem, & ! WA 7/29/15 For WRF-Chem + kdvel, ndvel, num_vert_mix, & +#endif + &Tsq,Qsq,Cov, & + &RUBLTEN,RVBLTEN,RTHBLTEN, & + &RQVBLTEN,RQCBLTEN,RQIBLTEN, & + &RQNCBLTEN,RQNIBLTEN, & + &RQNWFABLTEN,RQNIFABLTEN, & + &exch_h,exch_m, & + &Pblh,kpbl, & + &el_pbl, & + &dqke,qWT,qSHEAR,qBUOY,qDISS, & !JOE-TKE BUDGET + &wstar,delta, & !JOE-added for grims + &bl_mynn_tkebudget, & + &bl_mynn_cloudpdf,Sh3D, & + &bl_mynn_mixlength, & + &icloud_bl,qc_bl,cldfra_bl, & + &levflag,bl_mynn_edmf, & + &bl_mynn_edmf_mom,bl_mynn_edmf_tke, & + &bl_mynn_mixscalars, & + &bl_mynn_cloudmix,bl_mynn_mixqt, & + &edmf_a,edmf_w,edmf_qt, & + &edmf_thl,edmf_ent,edmf_qc, & + &nupdraft,maxMF,ktop_shallow, & + &spp_pbl,pattern_spp_pbl, & + &RTHRATEN, & + &FLAG_QC,FLAG_QI,FLAG_QNC, & + &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA & + &,IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE) + +!------------------------------------------------------------------- + + INTEGER, INTENT(in) :: initflag + LOGICAL, INTENT(IN) :: restart + !INPUT NAMELIST OPTIONS: + INTEGER, INTENT(in) :: levflag + INTEGER, INTENT(in) :: grav_settling + INTEGER, INTENT(in) :: bl_mynn_tkebudget + INTEGER, INTENT(in) :: bl_mynn_cloudpdf + INTEGER, INTENT(in) :: bl_mynn_mixlength + INTEGER, INTENT(in) :: bl_mynn_edmf + LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect + INTEGER, INTENT(in) :: bl_mynn_edmf_mom + INTEGER, INTENT(in) :: bl_mynn_edmf_tke + INTEGER, INTENT(in) :: bl_mynn_mixscalars + INTEGER, INTENT(in) :: bl_mynn_cloudmix + INTEGER, INTENT(in) :: bl_mynn_mixqt + INTEGER, INTENT(in) :: icloud_bl + + LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& + FLAG_QNWFA,FLAG_QNIFA + + INTEGER,INTENT(IN) :: & + & IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + +! initflag > 0 for TRUE +! else for FALSE +! levflag : <>3; Level 2.5 +! = 3; Level 3 +! grav_settling = 1 when gravitational settling accounted for +! grav_settling = 0 when gravitational settling NOT accounted for + + REAL, INTENT(in) :: delt +!WRF +! REAL, INTENT(in) :: dx +!END WRF +!FV3 + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: dx +!END FV3 + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: dz,& + &u,v,w,th,qv,p,exner,rho,T3D + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(in)::& + &qc,qi,qni,qnc,qnwfa,qnifa + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: xland,ust,& + &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd,uoce,voce, vdfg,znt + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + &Qke,Tsq,Qsq,Cov, & + &tke_pbl, & !JOE-added for coupling (TKE_PBL = QKE/2) + &qke_adv !ACF for QKE advection + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& + &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & + &RQNWFABLTEN,RQNIFABLTEN + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: & + &RTHRATEN + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & + &exch_h,exch_m + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc + + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(inout) :: & + &Pblh,wstar,delta !JOE-added for GRIMS + + REAL, DIMENSION(IMS:IME,JMS:JME) :: & + &Psig_bl,Psig_shcu + + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: & + &KPBL,nupdraft,ktop_shallow + + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: & + &maxmf + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + &el_pbl + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & + &qWT,qSHEAR,qBUOY,qDISS,dqke + ! 3D budget arrays are not allocated when bl_mynn_tkebudget == 0. + ! 1D (local) budget arrays are used for passing between subroutines. + REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: Sh3D + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + &qc_bl,cldfra_bl + REAL, DIMENSION(KTS:KTE) :: qc_bl1D,cldfra_bl1D,& + qc_bl1D_old,cldfra_bl1D_old + +! WA 7/29/15 Mix chemical arrays +#if (WRF_CHEM == 1) + INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, nchem ), INTENT(INOUT), OPTIONAL :: chem3d + REAL, DIMENSION( ims:ime, kdvel, jms:jme, ndvel ), INTENT(IN), OPTIONAL :: vd3d + REAL, DIMENSION( kts:kte, nchem ) :: chem1 + REAL, DIMENSION( kts:kte+1, nchem ) :: s_awchem1 + REAL, DIMENSION( ndvel ) :: vd1 + INTEGER ic +#endif + +!local vars + INTEGER :: ITF,JTF,KTF, IMD,JMD + INTEGER :: i,j,k + REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,sqv,sqc,sqi,sqw,& + &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + &Vt, Vq, sgm + + REAL, DIMENSION(KTS:KTE) :: thetav,sh,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& + & qke1,tsq1,qsq1,cov1,qv1,qi1,qc1,du1,dv1,dth1,dqv1,dqc1,dqi1, & + & k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1,dqnwfa1,dqnifa1 + +!JOE: mass-flux variables + REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf + REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,& + edmf_ent1,edmf_qc1 + REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1,& + s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1,& + s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1 + + REAL, DIMENSION(KTS:KTE+1) :: zw + REAL :: cpm,sqcg,flt,flq,flqv,flqc,pmz,phh,exnerg,zet,& + &afk,abk,ts_decay,th_sfc,ztop_shallow + +!JOE-add GRIMS parameters & variables + real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 + real,parameter :: h1 = 0.33333335, h2 = 0.6666667 + REAL :: govrth, sflux, bfx0, wstar3, wm2, wm3, delb +!JOE-end GRIMS +!JOE-top-down diffusion + REAL, DIMENSION(ITS:ITE,JTS:JTE) :: maxKHtopdown + REAL,DIMENSION(KTS:KTE) :: KHtopdown,zfac,wscalek2,& + zfacent,TKEprodTD + REAL :: bfxpbl,dthvx,tmp1,temps,templ,zl1,wstar3_2 + real :: ent_eff,radsum,radflux,we,rcldb,rvls,& + minrad,zminrad + real, parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 + integer :: kk,kminrad + logical :: cloudflg +!JOE-end top down + +! INTEGER, SAVE :: levflag + +! Stochastic fields + INTEGER, INTENT(IN) ::spp_pbl + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN),OPTIONAL ::pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col + + + IF ( debug_code ) THEN + print*,'in MYNN driver; at beginning' + ENDIF + +!*** Begin debugging + IMD=(IMS+IME)/2 + JMD=(JMS+JME)/2 +!*** End debugging + +!WRF +! JTF=MIN0(JTE,JDE-1) +! ITF=MIN0(ITE,IDE-1) +! KTF=MIN0(KTE,KDE-1) +!FV3 + JTF=JTE + ITF=ITE + KTF=KTE + +!WRF +! levflag=mynn_level + + IF (bl_mynn_edmf > 0) THEN + ! setup random seed + !call init_random_seed + + edmf_a(its:ite,kts:kte,jts:jte)=0. + edmf_w(its:ite,kts:kte,jts:jte)=0. + edmf_qt(its:ite,kts:kte,jts:jte)=0. + edmf_thl(its:ite,kts:kte,jts:jte)=0. + edmf_ent(its:ite,kts:kte,jts:jte)=0. + edmf_qc(its:ite,kts:kte,jts:jte)=0. + ktop_shallow(its:ite,jts:jte)=0 !int + nupdraft(its:ite,jts:jte)=0 !int + maxmf(its:ite,jts:jte)=0. + ENDIF + maxKHtopdown(its:ite,jts:jte)=0. + + ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS + IF (initflag > 0) THEN + + if (.not.restart) THEN + Sh3D(its:ite,kts:kte,jts:jte)=0. + el_pbl(its:ite,kts:kte,jts:jte)=0. + tsq(its:ite,kts:kte,jts:jte)=0. + qsq(its:ite,kts:kte,jts:jte)=0. + cov(its:ite,kts:kte,jts:jte)=0. + cldfra_bl(its:ite,kts:kte,jts:jte)=0. + qc_bl(its:ite,kts:kte,jts:jte)=0. + qke(its:ite,kts:kte,jts:jte)=0. + end if + dqc1(kts:kte)=0.0 + dqi1(kts:kte)=0.0 + dqni1(kts:kte)=0.0 + dqnc1(kts:kte)=0.0 + dqnwfa1(kts:kte)=0.0 + dqnifa1(kts:kte)=0.0 + qc_bl1D(kts:kte)=0.0 + cldfra_bl1D(kts:kte)=0.0 + qc_bl1D_old(kts:kte)=0.0 + cldfra_bl1D_old(kts:kte)=0.0 + edmf_a1(kts:kte)=0.0 + edmf_w1(kts:kte)=0.0 + edmf_qc1(kts:kte)=0.0 + sgm(kts:kte)=0.0 + vt(kts:kte)=0.0 + vq(kts:kte)=0.0 + + DO j=JTS,JTF + DO k=KTS,KTE + DO i=ITS,ITF + exch_m(i,k,j)=0. + exch_h(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + IF ( bl_mynn_tkebudget == 1) THEN + DO j=JTS,JTF + DO k=KTS,KTE + DO i=ITS,ITF + qWT(i,k,j)=0. + qSHEAR(i,k,j)=0. + qBUOY(i,k,j)=0. + qDISS(i,k,j)=0. + dqke(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + DO j=JTS,JTF + DO i=ITS,ITF + DO k=KTS,KTE !KTF + dz1(k)=dz(i,k,j) + u1(k) = u(i,k,j) + v1(k) = v(i,k,j) + w1(k) = w(i,k,j) + th1(k)=th(i,k,j) + tk1(k)=T3D(i,k,j) + rho1(k)=rho(i,k,j) + sqc(k)=qc(i,k,j)/(1.+qv(i,k,j)) + sqv(k)=qv(i,k,j)/(1.+qv(i,k,j)) + thetav(k)=th(i,k,j)*(1.+0.61*sqv(k)) + IF (PRESENT(qi) .AND. FLAG_QI ) THEN + sqi(k)=qi(i,k,j)/(1.+qv(i,k,j)) + sqw(k)=sqv(k)+sqc(k)+sqi(k) + thl(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc(k) & + & - xlscp/exner(i,k,j)*sqi(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) + ELSE + sqi(k)=0.0 + sqw(k)=sqv(k)+sqc(k) + thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) + ENDIF + + IF (k==kts) THEN + zw(k)=0. + ELSE + zw(k)=zw(k-1)+dz(i,k-1,j) + ENDIF + thvl(k)=thl(k)*(1.+0.61*sqv(k)) + if (restart) then + qke1(k) = qke(i,k,j) + else + qke1(k)=0.1-MIN(zw(k)*0.001, 0.0) !for initial PBLH calc only + end if + el(k)=el_pbl(i,k,j) + sh(k)=Sh3D(i,k,j) + tsq1(k)=tsq(i,k,j) + qsq1(k)=qsq(i,k,j) + cov1(k)=cov(i,k,j) + if (spp_pbl==1) then + rstoch_col(k)=pattern_spp_pbl(i,k,j) + else + rstoch_col(k)=0.0 + endif + + ENDDO + + zw(kte+1)=zw(kte)+dz(i,kte,j) + +! CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& + CALL GET_PBLH(KTS,KTE,PBLH(i,j),thvl,& + & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) + + IF (scaleaware > 0.) THEN + CALL SCALE_AWARE(dx(i,j),PBLH(i,j),Psig_bl(i,j),Psig_shcu(i,j)) + ELSE + Psig_bl(i,j)=1.0 + Psig_shcu(i,j)=1.0 + ENDIF + + ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS + CALL mym_initialize ( & + &kts,kte, & + &dz1, zw, u1, v1, thl, sqv, & + &PBLH(i,j), th1, sh, & + &ust(i,j), rmol(i,j), & + &el, Qke1, Tsq1, Qsq1, Cov1, & + &Psig_bl(i,j), cldfra_bl1D, & + &bl_mynn_mixlength, & + &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf,& + &spp_pbl,rstoch_col ) + + IF (.not.restart) THEN + !UPDATE 3D VARIABLES + DO k=KTS,KTE !KTF + el_pbl(i,k,j)=el(k) + sh3d(i,k,j)=sh(k) + qke(i,k,j)=qke1(k) + tsq(i,k,j)=tsq1(k) + qsq(i,k,j)=qsq1(k) + cov(i,k,j)=cov1(k) + !ACF,JOE- initialize qke_adv array if using advection + IF (bl_mynn_tkeadvect) THEN + qke_adv(i,k,j)=qke1(k) + ENDIF + ENDDO + ENDIF + +!*** Begin debugging +! k=kdebug +! IF(I==IMD .AND. J==JMD)THEN +! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k) +! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k,j) +! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) +! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",Tsq(i,k,j) +! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) +! ENDIF +!*** End debugging + + ENDDO + ENDDO + + ENDIF ! end initflag + + !ACF- copy qke_adv array into qke if using advection + IF (bl_mynn_tkeadvect) THEN + qke=qke_adv + ENDIF + + DO j=JTS,JTF + DO i=ITS,ITF + DO k=KTS,KTE !KTF + !JOE-TKE BUDGET + IF ( bl_mynn_tkebudget == 1) THEN + dqke(i,k,j)=qke(i,k,j) + END IF + dz1(k)= dz(i,k,j) + u1(k) = u(i,k,j) + v1(k) = v(i,k,j) + w1(k) = w(i,k,j) + th1(k)= th(i,k,j) + tk1(k)=T3D(i,k,j) + rho1(k)=rho(i,k,j) + qv1(k)= qv(i,k,j) + qc1(k)= qc(i,k,j) + sqv(k)= qv(i,k,j)/(1.+qv(i,k,j)) + sqc(k)= qc(i,k,j)/(1.+qv(i,k,j)) + IF(icloud_bl > 0)cldfra_bl1D_old(k)=cldfra_bl(i,k,j) + IF(icloud_bl > 0)qc_bl1D_old(k)=qc_bl(i,k,j) + dqc1(k)=0.0 + dqi1(k)=0.0 + dqni1(k)=0.0 + dqnc1(k)=0.0 + dqnwfa1(k)=0.0 + dqnifa1(k)=0.0 + IF(PRESENT(qi) .AND. FLAG_QI)THEN + qi1(k)= qi(i,k,j) + sqi(k)= qi(i,k,j)/(1.+qv(i,k,j)) + sqw(k)= sqv(k)+sqc(k)+sqi(k) + thl(k)= th(i,k,j) - xlvcp/exner(i,k,j)*sqc(k) & + & - xlscp/exner(i,k,j)*sqi(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) + ELSE + qi1(k)=0.0 + sqi(k)=0.0 + sqw(k)= sqv(k)+sqc(k) + thl(k)= th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) + ENDIF + + IF (PRESENT(qni) .AND. FLAG_QNI ) THEN + qni1(k)=qni(i,k,j) + ELSE + qni1(k)=0.0 + ENDIF + IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN + qnc1(k)=qnc(i,k,j) + ELSE + qnc1(k)=0.0 + ENDIF + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA ) THEN + qnwfa1(k)=qnwfa(i,k,j) + ELSE + qnwfa1(k)=0.0 + ENDIF + IF (PRESENT(qnifa) .AND. FLAG_QNIFA ) THEN + qnifa1(k)=qnifa(i,k,j) + ELSE + qnifa1(k)=0.0 + ENDIF + thetav(k)=th(i,k,j)*(1.+0.608*sqv(k)) + thvl(k)=thl(k)*(1.+0.61*sqv(k)) + p1(k) = p(i,k,j) + ex1(k)= exner(i,k,j) + el(k) = el_pbl(i,k,j) + qke1(k)=qke(i,k,j) + sh(k) = sh3d(i,k,j) + tsq1(k)=tsq(i,k,j) + qsq1(k)=qsq(i,k,j) + cov1(k)=cov(i,k,j) + if (spp_pbl==1) then + rstoch_col(k)=pattern_spp_pbl(i,k,j) + else + rstoch_col(k)=0.0 + endif + + + !edmf + edmf_a1(k)=0.0 + edmf_w1(k)=0.0 + edmf_qc1(k)=0.0 + s_aw1(k)=0. + s_awthl1(k)=0. + s_awqt1(k)=0. + s_awqv1(k)=0. + s_awqc1(k)=0. + s_awu1(k)=0. + s_awv1(k)=0. + s_awqke1(k)=0. + s_awqnc1(k)=0. + s_awqni1(k)=0. + s_awqnwfa1(k)=0. + s_awqnifa1(k)=0. + +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + IF (PRESENT(chem3d) .AND. PRESENT(vd3d)) THEN + ! WA 7/29/15 Set up chemical arrays + DO ic = 1,nchem + chem1(k,ic) = chem3d(i,k,j,ic) + s_awchem1(k,ic)=0. + ENDDO + DO ic = 1,ndvel + IF (k == KTS) THEN + vd1(ic) = vd3d(i,1,j,ic) + ENDIF + ENDDO + ELSE + DO ic = 1,nchem + chem1(k,ic) = 0. + s_awchem1(k,ic)=0. + ENDDO + DO ic = 1,ndvel + IF (k == KTS) THEN + vd1(ic) = 0. + ENDIF + ENDDO + ENDIF + ENDIF +#endif + + IF (k==kts) THEN + zw(k)=0. + ELSE + zw(k)=zw(k-1)+dz(i,k-1,j) + ENDIF + ENDDO ! end k + + zw(kte+1)=zw(kte)+dz(i,kte,j) + !EDMF + s_aw1(kte+1)=0. + s_awthl1(kte+1)=0. + s_awqt1(kte+1)=0. + s_awqv1(kte+1)=0. + s_awqc1(kte+1)=0. + s_awu1(kte+1)=0. + s_awv1(kte+1)=0. + s_awqke1(kte+1)=0. + s_awqnc1(kte+1)=0. + s_awqni1(kte+1)=0. + s_awqnwfa1(kte+1)=0. + s_awqnifa1(kte+1)=0. +#if (WRF_CHEM == 1) + DO ic = 1,nchem + s_awchem1(kte+1,ic)=0. + ENDDO +#endif + +! CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& + CALL GET_PBLH(KTS,KTE,PBLH(i,j),thvl,& + & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) + + IF (scaleaware > 0.) THEN + CALL SCALE_AWARE(dx(i,j),PBLH(i,j),Psig_bl(i,j),Psig_shcu(i,j)) + ELSE + Psig_bl(i,j)=1.0 + Psig_shcu(i,j)=1.0 + ENDIF + + sqcg= 0.0 !JOE, it was: qcg(i,j)/(1.+qcg(i,j)) + cpm=cp*(1.+0.84*qv(i,kts,j)) + exnerg=(ps(i,j)/p1000mb)**rcp + + !----------------------------------------------------- + !ORIGINAL CODE + !flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & + ! +xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j) -sqcg/exnerg) + !flq = qfx(i,j)/ rho(i,kts,j) & + ! -ch(i,j)*(sqc(kts) -sqcg ) + !----------------------------------------------------- + ! Katata-added - The deposition velocity of cloud (fog) + ! water is used instead of CH. + flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & + & +xlvcp*vdfg(i,j)*(sqc(kts)/exner(i,kts,j)- sqcg/exnerg) + flq = qfx(i,j)/ rho(i,kts,j) & + & -vdfg(i,j)*(sqc(kts) - sqcg ) +!JOE-test- should this be after the call to mym_condensation?-using old vt & vq +!same as original form +! flt = flt + xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j) -sqcg/exnerg) + flqv = qfx(i,j)/rho(i,kts,j) + flqc = -vdfg(i,j)*(sqc(kts) - sqcg ) + th_sfc = ts(i,j)/ex1(kts) + + zet = 0.5*dz(i,kts,j)*rmol(i,j) + if ( zet >= 0.0 ) then + pmz = 1.0 + (cphm_st-1.0) * zet + phh = 1.0 + cphh_st * zet + else + pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet + phh = 1.0/SQRT(1.0-cphh_unst*zet) + end if + + !-- Estimate wstar & delta for GRIMS shallow-cu------- + govrth = g/th1(kts) + sflux = hfx(i,j)/rho(i,kts,j)/cpm + & + qfx(i,j)/rho(i,kts,j)*ep_1*th1(kts) + bfx0 = max(sflux,0.) + wstar3 = (govrth*bfx0*pblh(i,j)) + wstar(i,j) = wstar3**h1 + wm3 = wstar3 + 5.*ust(i,j)**3. + wm2 = wm3**h2 + delb = govrth*d3*pblh(i,j) + delta(i,j) = min(d1*pblh(i,j) + d2*wm2/delb, 100.) + !-- End GRIMS----------------------------------------- + + CALL mym_condensation ( kts,kte, & + &dx(i,j),dz1,thl,sqw,p1,ex1, & + &tsq1, qsq1, cov1, & + &Sh,el,bl_mynn_cloudpdf, & + &qc_bl1D,cldfra_bl1D, & + &PBLH(i,j),HFX(i,j), & + &Vt, Vq, th1, sgm, rmol(i,j), & + &spp_pbl, rstoch_col ) + + !ADD TKE source driven by cloud top cooling + IF (bl_mynn_topdown.eq.1)then + cloudflg=.false. + minrad=100. + kminrad=kpbl(i,j) + zminrad=PBLH(i,j) + KHtopdown(kts:kte)=0.0 + TKEprodTD(kts:kte)=0.0 + maxKHtopdown(i,j)=0.0 + !CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS + DO kk = MAX(1,kpbl(i,j)-2),kpbl(i,j)+3 + if(sqc(kk).gt. 1.e-6 .OR. sqi(kk).gt. 1.e-6 .OR. & + cldfra_bl1D(kk).gt.0.5) then + cloudflg=.true. + endif + if(rthraten(i,kk,j) < minrad)then + minrad=rthraten(i,kk,j) + kminrad=kk + zminrad=zw(kk) + 0.5*dz1(kk) + endif + ENDDO + IF (MAX(kminrad,kpbl(i,j)) < 2)cloudflg = .false. + IF (cloudflg) THEN + zl1 = dz1(kts) + k = MAX(kpbl(i,j)-1, kminrad-1) + !Best estimate of height of TKE source (top of downdrafts): + !zminrad = 0.5*pblh(i,j) + 0.5*zminrad + + templ=thl(k)*ex1(k) + !rvls is ws at full level + rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1)) + temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(rd*templ**2)) + rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1)) + rcldb=max(sqw(k)-rvls,0.) + + !entrainment efficiency + dthvx = (thl(k+2) + th1(k+2)*ep_1*sqw(k+2)) & + - (thl(k) + th1(k) *ep_1*sqw(k)) + dthvx = max(dthvx,0.1) + tmp1 = xlvcp * rcldb/(ex1(k)*dthvx) + !Originally from Nichols and Turton (1986), where a2 = 60, but lowered + !here to 8, as in Grenier and Bretherton (2001). + ent_eff = 0.2 + 0.2*8.*tmp1 + + radsum=0. + DO kk = MAX(1,kpbl(i,j)-3),kpbl(i,j)+3 + radflux=rthraten(i,kk,j)*ex1(kk) !converts theta/s to temp/s + radflux=radflux*cp/g*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + ENDDO + radsum=MIN(radsum,60.0) + + !entrainment from PBL top thermals + bfx0 = max(radsum/rho1(k)/cp - max(sflux,0.0),0.) + !bfx0 = max(radsum/rho1(k)/cp,0.) + wm3 = g/thetav(k)*bfx0*MIN(pblh(i,j),1500.) ! this is wstar3(i) + wm2 = wm2 + wm3**h2 + bfxpbl = - ent_eff * bfx0 + dthvx = max(thetav(k+1)-thetav(k),0.1) + we = max(bfxpbl/dthvx,-sqrt(wm3**h2)) + + DO kk = kts,kpbl(i,j)+3 + !Analytic vertical profile + zfac(kk) = min(max((1.-(zw(kk+1)-zl1)/(zminrad-zl1)),zfmin),1.) + zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3 + + !Calculate an eddy diffusivity profile (not used at the moment) + wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**h1 + !Modify shape of KH to be similar to Lock et al (2000): use pfac = 3.0 + KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac + KHtopdown(kk) = MAX(KHtopdown(kk),0.0) + !Do not include xkzm at kpbl-1 since it changes entrainment + !if (kk.eq.kpbl(i,j)-1 .and. cloudflg .and. we.lt.0.0) then + ! KHtopdown(kk) = 0.0 + !endif + + !Calculate TKE production = 2(g/TH)(w'TH'), where w'TH' = A(TH/g)wstar^3/PBLH, + !A = ent_eff, and wstar is associated with the radiative cooling at top of PBL. + !An analytic profile controls the magnitude of this TKE prod in the vertical. + TKEprodTD(kk)=2.*ent_eff*wm3/MAX(pblh(i,j),100.)*zfacent(kk) + TKEprodTD(kk)= MAX(TKEprodTD(kk),0.0) + ENDDO + ENDIF !end cloud check + maxKHtopdown(i,j)=MAXVAL(KHtopdown(:)) + ELSE + maxKHtopdown(i,j)=0.0 + KHtopdown(kts:kte) = 0.0 + TKEprodTD(kts:kte)=0.0 + ENDIF !end top-down check + + IF (bl_mynn_edmf == 1) THEN + !PRINT*,"Calling DMP Mass-Flux: i= ",i," j=",j + CALL DMP_mf( & + &kts,kte,delt,zw,dz1,p1, & + &bl_mynn_edmf_mom, & + &bl_mynn_edmf_tke, & + &bl_mynn_mixscalars, & + &u1,v1,w1,th1,thl,thetav,tk1, & + &sqw,sqv,sqc,qke1, & + &qnc1,qni1,qnwfa1,qnifa1, & + &ex1,Vt,Vq,sgm, & + &ust(i,j),flt,flq,flqv,flqc, & + &PBLH(i,j),KPBL(i,j),DX(i,j), & + &xland(i,j),th_sfc, & + ! now outputs - tendencies + ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & + ! outputs - updraft properties + & edmf_a1,edmf_w1,edmf_qt1, & + & edmf_thl1,edmf_ent1,edmf_qc1, & + ! for the solver + & s_aw1,s_awthl1,s_awqt1, & + & s_awqv1,s_awqc1, & + & s_awu1,s_awv1,s_awqke1, & + & s_awqnc1,s_awqni1, & + & s_awqnwfa1,s_awqnifa1, & +#if (WRF_CHEM == 1) + & nchem,chem1,s_awchem1, & +#endif + & qc_bl1D,cldfra_bl1D, & + & FLAG_QC,FLAG_QI, & + & FLAG_QNC,FLAG_QNI, & + & FLAG_QNWFA,FLAG_QNIFA, & + & Psig_shcu(i,j), & + & nupdraft(i,j),ktop_shallow(i,j), & + & maxmf(i,j),ztop_shallow, & + & spp_pbl,rstoch_col & + ) + + ENDIF + + CALL mym_turbulence ( & + &kts,kte,levflag, & + &dz1, zw, u1, v1, thl, sqc, sqw, & + &qke1, tsq1, qsq1, cov1, & + &vt, vq, & + &rmol(i,j), flt, flq, & + &PBLH(i,j),th1, & + &Sh,el, & + &Dfm,Dfh,Dfq, & + &Tcd,Qcd,Pdk, & + &Pdt,Pdq,Pdc, & + &qWT1,qSHEAR1,qBUOY1,qDISS1, & + &bl_mynn_tkebudget, & + &Psig_bl(i,j),Psig_shcu(i,j), & + &cldfra_bl1D,bl_mynn_mixlength, & + &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + &TKEprodTD, & + &spp_pbl,rstoch_col) + + CALL mym_predict (kts,kte,levflag, & + &delt, dz1, & + &ust(i,j), flt, flq, pmz, phh, & + &el, dfq, pdk, pdt, pdq, pdc, & + &Qke1, Tsq1, Qsq1, Cov1, & + &s_aw1, s_awqke1, bl_mynn_edmf_tke) + + DO k=kts,kte-1 + ! Set max dissipative heating rate close to 0.1 K per hour (=0.000027...) + diss_heat(k) = MIN(MAX(0.5*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.00002) + ENDDO + diss_heat(kte) = 0. + + CALL mynn_tendencies(kts,kte, & + &levflag,grav_settling, & + &delt, dz1, rho1, & + &u1, v1, th1, tk1, qv1, & + &qc1, qi1, qnc1, qni1, & + &p1, ex1, thl, sqv, sqc, sqi, sqw,& + &qnwfa1, qnifa1, & + &ust(i,j),flt,flq,flqv,flqc, & + &wspd(i,j),qcg(i,j), & + &uoce(i,j),voce(i,j), & + &tsq1, qsq1, cov1, & + &tcd, qcd, & + &dfm, dfh, dfq, & + &Du1, Dv1, Dth1, Dqv1, & + &Dqc1, Dqi1, Dqnc1, Dqni1, & + &Dqnwfa1, Dqnifa1, & + &vdfg(i,j), diss_heat, & + ! mass flux components + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1,s_awu1,s_awv1, & + &s_awqnc1,s_awqni1, & + &s_awqnwfa1,s_awqnifa1, & + &FLAG_QC,FLAG_QI,FLAG_QNC, & + &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & + &cldfra_bl1d, & + &ztop_shallow,ktop_shallow(i,j), & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) + +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + CALL mynn_mix_chem(kts,kte, & + levflag,grav_settling, & + delt, dz1, & + nchem, kdvel, ndvel, num_vert_mix, & + chem1, vd1, & + qnc1,qni1, & + p1, ex1, thl, sqv, sqc, sqi, sqw,& + ust(i,j),flt,flq,flqv,flqc, & + wspd(i,j),qcg(i,j), & + uoce(i,j),voce(i,j), & + tsq1, qsq1, cov1, & + tcd, qcd, & + &dfm, dfh, dfq, & + ! mass flux components + & s_aw1, & + & s_awchem1, & + &bl_mynn_cloudmix) + ENDIF +#endif + + + CALL retrieve_exchange_coeffs(kts,kte,& + &dfm, dfh, dz1, K_m1, K_h1) + + !UPDATE 3D ARRAYS + DO k=KTS,KTE !KTF + exch_m(i,k,j)=K_m1(k) + exch_h(i,k,j)=K_h1(k) + RUBLTEN(i,k,j)=du1(k) + RVBLTEN(i,k,j)=dv1(k) + RTHBLTEN(i,k,j)=dth1(k) + RQVBLTEN(i,k,j)=dqv1(k) + IF(bl_mynn_cloudmix > 0)THEN + IF (PRESENT(qc) .AND. FLAG_QC) RQCBLTEN(i,k,j)=dqc1(k) + IF (PRESENT(qi) .AND. FLAG_QI) RQIBLTEN(i,k,j)=dqi1(k) + ELSE + IF (PRESENT(qc) .AND. FLAG_QC) RQCBLTEN(i,k,j)=0. + IF (PRESENT(qi) .AND. FLAG_QI) RQIBLTEN(i,k,j)=0. + ENDIF + IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN + IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=dqnc1(k) + IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=dqni1(k) + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k,j)=dqnwfa1(k) + IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k,j)=dqnifa1(k) + ELSE + IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=0. + IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=0. + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k,j)=0. + IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k,j)=0. + ENDIF + + IF(icloud_bl > 0)THEN + !make BL clouds scale aware - may already be done in mym_condensation + qc_bl(i,k,j)=qc_bl1D(k) !*Psig_shcu(i,j) + cldfra_bl(i,k,j)=cldfra_bl1D(k) !*Psig_shcu(i,j) + + !DIAGNOSTIC-DECAY FOR SUBGRID-SCALE CLOUDS + IF (CLDFRA_BL(i,k,j) < cldfra_bl1D_old(k)) THEN + !DECAY TIMESCALE FOR CALM CONDITION IS THE EDDY TURNOVER + !TIMESCALE, BUT FOR + !WINDY CONDITIONS, IT IS THE ADVECTIVE TIMESCALE. USE THE + !MINIMUM OF THE TWO. + ts_decay = MIN( 1800., 3.*dx(i,j)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) + cldfra_bl(i,k,j)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.25*delt/ts_decay)) + IF (cldfra_bl(i,k,j) < 0.005) THEN + CLDFRA_BL(i,k,j)= 0. + QC_BL(i,k,j) = 0. + ENDIF + ENDIF + + !Reapply checks on cldfra_bl and qc_bl to avoid FPEs in radiation driver + ! when these two quantities are multiplied by eachother (they may have changed + ! in the MF scheme: + !IF (icloud_bl > 0) THEN + IF ( zw(k) < 3000.0 ) THEN + IF (QC_BL(i,k,j) < 5E-6 .AND. CLDFRA_BL(i,k,j) > 0.005) QC_BL(i,k,j)= 5E-6 + ELSE + IF (QC_BL(i,k,j) < 1E-8 .AND. CLDFRA_BL(i,k,j) > 0.005) QC_BL(i,k,j)= 1E-8 + ENDIF + ENDIF + + el_pbl(i,k,j)=el(k) + qke(i,k,j)=qke1(k) + tsq(i,k,j)=tsq1(k) + qsq(i,k,j)=qsq1(k) + cov(i,k,j)=cov1(k) + sh3d(i,k,j)=sh(k) + + IF ( bl_mynn_tkebudget == 1) THEN + dqke(i,k,j) = (qke1(k)-dqke(i,k,j))*0.5 !qke->tke + qWT(i,k,j) = qWT1(k)*delt + qSHEAR(i,k,j)= qSHEAR1(k)*delt + qBUOY(i,k,j) = qBUOY1(k)*delt + qDISS(i,k,j) = qDISS1(k)*delt + ENDIF + + !update updraft properties + IF (bl_mynn_edmf > 0) THEN + edmf_a(i,k,j)=edmf_a1(k) + edmf_w(i,k,j)=edmf_w1(k) + edmf_qt(i,k,j)=edmf_qt1(k) + edmf_thl(i,k,j)=edmf_thl1(k) + edmf_ent(i,k,j)=edmf_ent1(k) + edmf_qc(i,k,j)=edmf_qc1(k) + ENDIF + + !*** Begin debug prints + IF ( debug_code ) THEN + IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," sh=",sh(k) + IF ( qke(i,k,j) < -1. .OR. qke(i,k,j)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," qke=",qke(i,k,j) + IF ( el_pbl(i,k,j) < 0. .OR. el_pbl(i,k,j)> 2000.)print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," el_pbl=",el_pbl(i,k,j) + IF ( ABS(vt(k)) > 0.8 )print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vt=",vt(k) + IF ( ABS(vq(k)) > 6000.)print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vq=",vq(k) + IF ( exch_m(i,k,j) < 0. .OR. exch_m(i,k,j)> 2000.)print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," exxch_m=",exch_m(i,k,j) + IF ( vdfg(i,j) < 0. .OR. vdfg(i,j)>5. )print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vdfg=",vdfg(i,j) + IF ( ABS(QFX(i,j))>.001)print*,& + "SUSPICIOUS VALUES AT: i,j=",i,j," QFX=",QFX(i,j) + IF ( ABS(HFX(i,j))>1000.)print*,& + "SUSPICIOUS VALUES AT: i,j=",i,j," HFX=",HFX(i,j) + IF (icloud_bl > 0) then + IF( cldfra_bl(i,k,j) < 0.0 .OR. cldfra_bl(i,k,j)> 1.)THEN + PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k,j)," qc_bl=",QC_BL(i,k,j) + ENDIF + ENDIF + ENDIF + !*** End debug prints + ENDDO + + !JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) + ! TKE_PBL is defined on interfaces, while QKE is at middle of layer. + tke_pbl(i,kts,j) = 0.5*MAX(qke(i,kts,j),1.0e-10) + DO k = kts+1,kte + afk = dz1(k)/( dz1(k)+dz1(k-1) ) + abk = 1.0 -afk + tke_pbl(i,k,j) = 0.5*MAX(qke(i,k,j)*abk+qke(i,k-1,j)*afk,1.0e-3) + ENDDO + +!*** Begin debugging +! IF(I==IMD .AND. J==JMD)THEN +! k=kdebug +! PRINT*,"MYNN DRIVER END: k=",1," sh=",sh(k) +! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j) +! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) +! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j) +! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) +! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j) +! ENDIF +!*** End debugging + + ENDDO + ENDDO + +!ACF copy qke into qke_adv if using advection + IF (bl_mynn_tkeadvect) THEN + qke_adv=qke + ENDIF +!ACF-end + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mynn_bl_driver + +! ================================================================== + SUBROUTINE mynn_bl_init_driver( & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + &RQCBLTEN,RQIBLTEN & !,RQNIBLTEN,RQNCBLTEN & + &,QKE,TKE_PBL,EXCH_H & +! &,icloud_bl,qc_bl,cldfra_bl & !JOE-subgrid bl clouds + &,RESTART,ALLOWED_TO_READ,LEVEL & + &,IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE) + + !--------------------------------------------------------------- + LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART + INTEGER,INTENT(IN) :: LEVEL !,icloud_bl + + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & + & IMS,IME,JMS,JME,KMS,KME, & + & ITS,ITE,JTS,JTE,KTS,KTE + + + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + &RQCBLTEN,RQIBLTEN,& !RQNIBLTEN,RQNCBLTEN & + &QKE,TKE_PBL,EXCH_H + +! REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & +! &qc_bl,cldfra_bl + + INTEGER :: I,J,K,ITF,JTF,KTF + + JTF=MIN0(JTE,JDE-1) + KTF=MIN0(KTE,KDE-1) + ITF=MIN0(ITE,IDE-1) + + IF(.NOT.RESTART)THEN + DO J=JTS,JTF + DO K=KTS,KTF + DO I=ITS,ITF + RUBLTEN(i,k,j)=0. + RVBLTEN(i,k,j)=0. + RTHBLTEN(i,k,j)=0. + RQVBLTEN(i,k,j)=0. + if( p_qc >= param_first_scalar ) RQCBLTEN(i,k,j)=0. + if( p_qi >= param_first_scalar ) RQIBLTEN(i,k,j)=0. + !if( p_qnc >= param_first_scalar ) RQNCBLTEN(i,k,j)=0. + !if( p_qni >= param_first_scalar ) RQNIBLTEN(i,k,j)=0. + !QKE(i,k,j)=0. + TKE_PBL(i,k,j)=0. + EXCH_H(i,k,j)=0. +! if(icloud_bl > 0) qc_bl(i,k,j)=0. +! if(icloud_bl > 0) cldfra_bl(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + mynn_level=level + + END SUBROUTINE mynn_bl_init_driver + +! ================================================================== + + SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) + + !--------------------------------------------------------------- + ! NOTES ON THE PBLH FORMULATION + ! + !The 1.5-theta-increase method defines PBL heights as the level at + !which the potential temperature first exceeds the minimum potential + !temperature within the boundary layer by 1.5 K. When applied to + !observed temperatures, this method has been shown to produce PBL- + !height estimates that are unbiased relative to profiler-based + !estimates (Nielsen-Gammon et al. 2008). However, their study did not + !include LLJs. Banta and Pichugina (2008) show that a TKE-based + !threshold is a good estimate of the PBL height in LLJs. Therefore, + !a hybrid definition is implemented that uses both methods, weighting + !the TKE-method more during stable conditions (PBLH < 400 m). + !A variable tke threshold (TKEeps) is used since no hard-wired + !value could be found to work best in all conditions. + !--------------------------------------------------------------- + + INTEGER,INTENT(IN) :: KTS,KTE + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + REAL, INTENT(OUT) :: zi + REAL, INTENT(IN) :: landsea + REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D + REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D + !LOCAL VARS + REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv + REAL :: delt_thv !delta theta-v; dependent on land/sea point + REAL, PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m). + REAL, PARAMETER :: sbl_damp = 400. !transition length for blending (m). + INTEGER :: I,J,K,kthv,ktke,kzi,kzi2 + + !ADD KPBL (kzi) + !KZI2 is the TKE-based part of the hybrid KPBL + kzi = 2 + kzi2= 2 + + !FIND MIN THETAV IN THE LOWEST 200 M AGL + k = kts+1 + kthv = 1 + minthv = 9.E9 + DO WHILE (zw1D(k) .LE. 200.) + !DO k=kts+1,kte-1 + IF (minthv > thetav1D(k)) then + minthv = thetav1D(k) + kthv = k + ENDIF + k = k+1 + !IF (zw1D(k) .GT. sbl_lim) exit + ENDDO + + !FIND THETAV-BASED PBLH (BEST FOR DAYTIME). + zi=0. + k = kthv+1 + IF((landsea-1.5).GE.0)THEN + ! WATER + delt_thv = 0.75 + ELSE + ! LAND + delt_thv = 1.25 + ENDIF + + zi=0. + k = kthv+1 +! DO WHILE (zi .EQ. 0.) + DO k=kts+1,kte-1 + IF (thetav1D(k) .GE. (minthv + delt_thv))THEN + !kzi = MAX(k-1,1) + zi = zw1D(k) - dz1D(k-1)* & + & MIN((thetav1D(k)-(minthv + delt_thv))/ & + & MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) + kzi= MAX(k-1,1) + NINT((zi-zw1D(k-1))/dz1D(k-1)) + ENDIF + !k = k+1 + IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD + IF (zi .NE. 0.0) exit + ENDDO + !print*,"IN GET_PBLH:",thsfc,zi + + !FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE + !THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM). + !THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE + !WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM. + ktke = 1 + maxqke = MAX(Qke1D(kts),0.) + !Use 5% of tke max (Kosovic and Curry, 2000; JAS) + !TKEeps = maxtke/20. = maxqke/40. + TKEeps = maxqke/40. + TKEeps = MAX(TKEeps,0.02) !0.025) + PBLH_TKE=0. + + k = ktke+1 +! DO WHILE (PBLH_TKE .EQ. 0.) + DO k=kts+1,kte-1 + !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE. + qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE + qtkem1=MAX(Qke1D(k-1)/2.,0.) + IF (qtke .LE. TKEeps) THEN + !kzi2 = MAX(k-1,1) + PBLH_TKE = zw1D(k) - dz1D(k-1)* & + & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0) + !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL. + PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1)) + kzi2 = MAX(k-1,1) + NINT((PBLH_TKE-zw1D(k-1))/dz1D(k-1)) + !print *,"PBLH_TKE:",i,j,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) + ENDIF + !k = k+1 + IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD + IF (PBLH_TKE .NE. 0.) exit + ENDDO + + !With TKE advection turned on, the TKE-based PBLH can be very large + !in grid points with convective precipitation (> 8 km!), + !so an artificial limit is imposed to not let PBLH_TKE exceed the + !theta_v-based PBL height +/- 350 m. + !This has no impact on 98-99% of the domain, but is the simplest patch + !that adequately addresses these extremely large PBLHs. + PBLH_TKE = MIN(PBLH_TKE,zi+350.) + PBLH_TKE = MAX(PBLH_TKE,MAX(zi-350.,10.)) + + wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 + IF (maxqke <= 0.05) THEN + !Cold pool situation - default to theta_v-based def + ELSE + !BLEND THE TWO PBLH TYPES HERE: + zi=PBLH_TKE*(1.-wt) + zi*wt + ENDIF + + !ADD KPBL (kzi) for coupling to some Cu schemes + kzi = MAX(INT(kzi2*(1.-wt) + kzi*wt),1) + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE GET_PBLH + +! ================================================================== +! Dynamic Multi-Plume (DMP) Mass-Flux Scheme +! +! Much thanks to Kay Suslj of NASA-JPL for contributing the original version +! of this mass-flux scheme. Considerable changes have been made from it's +! original form. Some additions include: +! 1) scale-aware tapering as dx -> 0 +! 2) transport of TKE (extra namelist option) +! 3) Chaboureau-Bechtold cloud fraction & coupling to radiation (when icloud_bl > 0) +! 4) some extra limits for numerical stability +! This scheme remains under development, so consider it experimental code. +! + SUBROUTINE DMP_mf( & + & kts,kte,dt,zw,dz,p, & + & momentum_opt, & + & tke_opt, & + & scalar_opt, & + & u,v,w,th,thl,thv,tk, & + & qt,qv,qc,qke, & + qnc,qni,qnwfa,qnifa, & + & exner,vt,vq,sgm, & + & ust,flt,flq,flqv,flqc, & + & pblh,kpbl,DX,landsea,ts, & + ! outputs - updraft properties + & edmf_a,edmf_w, & + & edmf_qt,edmf_thl, & + & edmf_ent,edmf_qc, & + ! outputs - variables needed for solver + & s_aw,s_awthl,s_awqt, & + & s_awqv,s_awqc, & + & s_awu,s_awv,s_awqke, & + & s_awqnc,s_awqni, & + & s_awqnwfa,s_awqnifa, & +#if (WRF_CHEM == 1) + & nchem,chem,s_awchem, & +#endif + ! in/outputs - subgrid scale clouds + & qc_bl1d,cldfra_bl1d, & + ! inputs - flags for moist arrays + & F_QC,F_QI, & + F_QNC,F_QNI, & + & F_QNWFA,F_QNIFA, & + & Psig_shcu, & + ! output info + &nup2,ktop,maxmf,ztop, & + ! unputs for stochastic perturbations + &spp_pbl,rstoch_col) + + ! inputs: + INTEGER, INTENT(IN) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + +! Stochastic + INTEGER, INTENT(IN) :: spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col + + REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,& + exner,dz,THV,P,qke,qnc,qni,qnwfa,qnifa + REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma + REAL, INTENT(IN) :: DT,UST,FLT,FLQ,FLQV,FLQC,PBLH,& + DX,Psig_shcu,landsea,ts + LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA + + ! outputs - updraft properties + REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & + & edmf_qt,edmf_thl, edmf_ent,edmf_qc + !add one local edmf variable: + REAL,DIMENSION(KTS:KTE) :: edmf_th + ! output + INTEGER, INTENT(OUT) :: nup2,ktop + REAL, INTENT(OUT) :: maxmf,ztop + ! outputs - variables needed for solver + REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*wis_awphi + s_awthl, & !sum ai*wi*phii + s_awqt, & + s_awqv, & + s_awqc, & + s_awqnc, & + s_awqni, & + s_awqnwfa, & + s_awqnifa, & + s_awu, & + s_awv, & + s_awqke, s_aw2 + + REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d + + INTEGER, PARAMETER :: NUP=10, debug_mf=0 + + !------------- local variables ------------------- + ! updraft properties defined on interfaces (k=1 is the top of the + ! first model layer + REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & + UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & + UPQNI,UPQNWFA,UPQNIFA + ! entrainment variables + REAL,DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf + INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi + ! internal variables + INTEGER :: K,I,k50 + REAL :: fltv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & + pwmin,pwmax,wmin,wmax,wlv,wtv,Psig_w,maxw,maxqc,wpbl + REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & + Wn2,Wn,EntEXP,EntW,BCOEFF,THVkm1,THVk,Pk + + ! w parameters + REAL,PARAMETER :: & + &Wa=2./3., & + &Wb=0.002,& + &Wc=1.5 + + ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from + ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. + REAL,PARAMETER :: & + & L0=100.,& + & ENT0=0.1 + + ! Implement ideas from Neggers (2016, JAMES): + REAL, PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts + REAL, PARAMETER :: lmax = 1000.! diameter of largest plume + REAL, PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand + REAL, PARAMETER :: dcut = 1.0 ! max diameter of plume to parameterize relative to dx (km) + REAL :: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). + ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes. + ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. + REAL :: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx + +#if (WRF_CHEM == 1) + INTEGER, INTENT(IN) :: nchem + REAL,DIMENSION(kts:kte, nchem) :: chem + REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem + REAL,DIMENSION(nchem) :: chemn + REAL,DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM + INTEGER :: ic + REAL,DIMENSION(KTS:KTE+1, nchem) :: edmf_chem +#endif + + !JOE: add declaration of ERF + REAL :: ERF + + LOGICAL :: superadiabatic + + ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION + REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm + REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,& + Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid + + ! Variables for plume interpolation/saturation check + REAL,DIMENSION(KTS:KTE) :: exneri,dzi + REAL :: THp, QTp, QCp, esat, qsl + + ! WA TEST 11/9/15 for consistent reduction of updraft params + REAL :: csigma,acfac,EntThrottle + + !JOE- plume overshoot + INTEGER :: overshoot + REAL :: bvf, Frz + + !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux). + !This limiter makes adjustments to the entire column. + REAL :: adjustment, flx1 + REAL, PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact + ! over land (decrease maxMF by 10-20%), but no impact over water. +! check the inputs +! print *,'dt',dt +! print *,'dz',dz +! print *,'u',u +! print *,'v',v +! print *,'thl',thl +! print *,'qt',qt +! print *,'ust',ust +! print *,'flt',flt +! print *,'flq',flq +! print *,'pblh',pblh + +! Initialize individual updraft properties + UPW=0. + UPTHL=0. + UPTHV=0. + UPQT=0. + UPA=0. + UPU=0. + UPV=0. + UPQC=0. + UPQV=0. + UPQKE=0. + UPQNC=0. + UPQNI=0. + UPQNWFA=0. + UPQNIFA=0. +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 + ENDIF +#endif + ENT=0.001 +! Initialize mean updraft properties + edmf_a =0. + edmf_w =0. + edmf_qt =0. + edmf_thl=0. + edmf_ent=0. + edmf_qc =0. +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + edmf_chem(kts:kte+1,1:nchem) = 0.0 + ENDIF +#endif +! Initialize the variables needed for implicit solver + s_aw=0. + s_awthl=0. + s_awqt=0. + s_awqv=0. + s_awqc=0. + s_awu=0. + s_awv=0. + s_awqke=0. + s_awqnc=0. + s_awqni=0. + s_awqnwfa=0. + s_awqnifa=0. +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + s_awchem(kts:kte+1,1:nchem) = 0.0 + ENDIF +#endif + + + ! Taper off MF scheme when significant resolved-scale motions + ! are present This function needs to be asymetric... + k = 1 + maxw = 0.0 + cloud_base = 9000.0 +! DO WHILE (ZW(k) < pblh + 500.) + DO k=1,kte-1 + IF(ZW(k) > pblh + 500.) exit + + wpbl = w(k) + IF(w(k) < 0.)wpbl = 2.*w(k) + maxw = MAX(maxw,ABS(wpbl)) + + !Find highest k-level below 50m AGL + IF(ZW(k)<=50.)k50=k + + !Search for cloud base + IF(qc(k)>1E-5 .AND. cloud_base == 9000.0)THEN + cloud_base = 0.5*(ZW(k)+ZW(k+1)) + ENDIF + + !k = k + 1 + ENDDO + !print*," maxw before manipulation=", maxw + maxw = MAX(0.,maxw - 0.5) ! do nothing for small w, but + Psig_w = MAX(0.0, 1.0 - maxw/0.5) ! linearly taper off for w > 0.5 m/s + Psig_w = MIN(Psig_w, Psig_shcu) + !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu + + fltv = flt + svp1*flq + !PRINT*," fltv=",fltv," zi=",pblh + + !Completely shut off MF scheme for strong resolved-scale vertical velocities. + IF(Psig_w == 0.0 .and. fltv > 0.0) fltv = -1.*fltv + +! if surface buoyancy is positive we do integration, otherwise not, and make sure that +! PBLH > twice the height of the surface layer (set at z0 = 50m) +! Also, ensure that it is at least slightly superadiabatic up through 50 m + superadiabatic = .false. + IF((landsea-1.5).GE.0)THEN + hux = -0.002 ! WATER ! dT/dz must be < - 0.2 K per 100 m. + ELSE + hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m. + ENDIF + DO k=1,MAX(1,k50-1) + IF (k == 1) then + IF ((th(k)-ts)/(0.5*dz(k)) < hux) THEN + superadiabatic = .true. + ELSE + superadiabatic = .false. + exit + ENDIF + ELSE + IF ((th(k)-th(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) THEN + superadiabatic = .true. + ELSE + superadiabatic = .false. + exit + ENDIF + ENDIF + ENDDO + + ! Determine the numer of updrafts/plumes in the grid column: + ! Some of these criteria may be a little redundant but useful for bullet-proofing. + ! (1) largest plume = 1.0 * dx. + ! (2) Apply a scale-break, assuming no plumes with diameter larger than PBLH can exist. + ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base. + ! (4) add shear-dependent limit, when plume model breaks down. (taken out) + ! (5) land-only limit to reduce plume sizes in weakly forced conditions + ! Criteria (1) + NUP2 = max(1,min(NUP,INT(dx*dcut/dl))) + ! Criteria (2) and (4) + !wspd_pbl=SQRT(MAX(u(kpbl)**2 + v(kpbl)**2, 0.01)) + maxwidth = 1.1*PBLH !- MIN(15.*MAX(wspd_pbl - 7.5, 0.), 0.3*PBLH) + ! Criteria (3) +! maxwidth = MIN(maxwidth,0.5*cloud_base) + maxwidth = MIN(maxwidth,0.75*cloud_base) + ! Criteria (5) + IF((landsea-1.5).LT.0)THEN + IF (cloud_base .LT. 2000.) THEN + !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.120)/0.03) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.090)/0.03) + .5),1000.), 0.) + ELSE + width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.) + !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) + ENDIF + maxwidth = MIN(maxwidth,width_flx) + ENDIF + ! Convert maxwidth to number of plumes + NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2) + + !Initialize values: + ktop = 0 + ztop = 0.0 + maxmf= 0.0 + + IF ( fltv > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then + !PRINT*," Conditions met to run mass-flux scheme",fltv,pblh + + ! Find coef C for number size density N + cn = 0. + d=-1.9 !set d to value suggested by Neggers 2015 (JAMES). + !d=-1.9 + .2*tanh((fltv - 0.05)/0.15) + do I=1,NUP !NUP2 + IF(I > NUP2) exit + l = dl*I ! diameter of plume + cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume + enddo + C = Atot/cn !Normalize C according to the defined total fraction (Atot) + + ! Find the portion of the total fraction (Atot) of each plume size: + An2 = 0. + do I=1,NUP !NUP2 + IF(I > NUP2) exit + l = dl*I ! diameter of plume + N = C*l**d ! number density of plume n + UPA(1,I) = N*l*l/(dx*dx) * dl ! fractional area of plume n + ! Make updraft area (UPA) a function of the buoyancy flux +! acfac = .5*tanh((fltv - 0.05)/0.2) + .5 +! acfac = .5*tanh((fltv - 0.07)/0.09) + .5 +! acfac = .5*tanh((fltv - 0.03)/0.09) + .5 + acfac = .5*tanh((fltv - 0.02)/0.09) + .5 +! acfac = .5*tanh((fltv - 0.015)/0.05) + .5 + UPA(1,I)=UPA(1,I)*acfac + An2 = An2 + UPA(1,I) ! total fractional area of all plumes + !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 + end do + + ! set initial conditions for updrafts + z0=50. + pwmin=0.1 ! was 0.5 + pwmax=0.4 ! was 3.0 + + wstar=max(1.E-2,(g/thv(1)*fltv*pblh)**(1./3.)) + qstar=max(flq,1.0E-5)/wstar + thstar=flt/wstar + + IF((landsea-1.5).GE.0)THEN + csigma = 1.34 ! WATER + ELSE + csigma = 1.34 ! LAND + ENDIF + sigmaW =1.34*wstar*(z0/pblh)**(1./3.)*(1 - 0.8*z0/pblh) + sigmaQT=csigma*qstar*(z0/pblh)**(-1./3.) + sigmaTH=csigma*thstar*(z0/pblh)**(-1./3.) + + wmin=MIN(sigmaW*pwmin,0.1) + wmax=MIN(sigmaW*pwmax,0.5) + + !recompute acfac for plume excess + acfac = .5*tanh((fltv - 0.08)/0.07) + .5 + + !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 + DO I=1,NUP !NUP2 + IF(I > NUP2) exit + wlv=wmin+(wmax-wmin)/NUP2*(i-1) + wtv=wmin+(wmax-wmin)/NUP2*i + + !SURFACE UPDRAFT VERTICAL VELOCITY + !UPW(1,I)=0.5*(wlv+wtv) + UPW(1,I)=wmin + REAL(i)/REAL(NUP)*(wmax-wmin) + !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt + + !SURFACE UPDRAFT AREA + !UPA(1,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.5*ERF(wlv/(sqrt(2.)*sigmaW)) + !UPA(1,I)=0.25*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.25*ERF(wlv/(sqrt(2.)*sigmaW)) !12.0 + + UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQC(1,I)=0 + !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& + & +0.58*UPW(1,I)*sigmaQT/sigmaW + UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & + & +0.58*UPW(1,I)*sigmaTH/sigmaW +!was UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) !assume no saturated parcel at surface + UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & + & +0.58*UPW(1,I)*sigmaTH/sigmaW + UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + UPCHEM(1,I,ic)= (CHEM(KTS,ic)*DZ(KTS+1)+CHEM(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + enddo + ENDIF +#endif + + ENDDO + + EntThrottle = 0.001 !MAX(0.02/MAX((flt*1.25*1004.)-25.,5.),0.0002) + !QCn = 0. + ! do integration updraft + DO I=1,NUP !NUP2 + IF(I > NUP2) exit + QCn = 0. + overshoot = 0 + l = dl*I ! diameter of plume + DO k=KTS+1,KTE-1 + !w-dependency for entrainment a la Tian and Kuang (2016) + !ENT(k,i) = 0.5/(MIN(MAX(UPW(K-1,I),0.75),1.5)*l) + ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.5)*l) + !Entrainment from Negggers (2015, JAMES) + !ENT(k,i) = 0.02*l**-0.35 - 0.0009 + !JOE - implement minimum background entrainment + ENT(k,i) = max(ENT(k,i),0.0003) + !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang + !JOE - increase entrainment for plumes extending very high. + IF(ZW(k) >= MIN(pblh+1500., 3500.))THEN + ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,3500.))*5.0E-6 + ENDIF + IF(UPW(K-1,I) > 2.0) ENT(k,i) = ENT(k,i) + EntThrottle*(UPW(K-1,I) - 2.0) + + !SPP + ENT(k,i) = ENT(k,i) * (1.0 - rstoch_col(k)) + + ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) + + ! Linear entrainment: + EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) + QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp + THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp + Un =UPU(k-1,I) *(1.-EntExp) + U(k)*EntExp + Vn =UPV(k-1,I) *(1.-EntExp) + V(k)*EntExp + QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp + QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp + QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp + QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp + QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp + + ! Exponential Entrainment: + !EntExp= exp(-ENT(K,I)*(ZW(k)-ZW(k-1))) + !QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp + !THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp + !Un =U(K) *(1-EntExp)+UPU(K-1,I)*EntExp + !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp + !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp + +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + ! Exponential Entrainment: + !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp + ! Linear entrainment: + chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem(k,ic)*EntExp + enddo + ENDIF +#endif + + ! Define pressure at model interface + Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + ! Compute plume properties thvn and qcn + call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn) + + ! Define environment THV at the model interface levels + THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + +! B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0) + B=g*(THVn/THVk - 1.0) + IF(B>0.)THEN + BCOEFF = 0.15 !w typically stays < 2.5, so doesnt hit the limits nearly as much + ELSE + BCOEFF = 0.2 !0.33 + ENDIF + + ! Original StEM with exponential entrainment + !EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1))) + !Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I)) + ! Original StEM with linear entrainment + !Wn2=UPW(K-1,I)**2*(1.-EntExp) + EntExp*0.5*Wa*B/(Wb+Wc*ENT(K,I)) + !Wn2=MAX(Wn2,0.0) + !WA: TEMF form +! IF (B>0.0 .AND. UPW(K-1,I) < 0.2 ) THEN + IF (UPW(K-1,I) < 0.2 ) THEN + Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / MAX(UPW(K-1,I),0.2)) * MIN(ZW(k)-ZW(k-1), 250.) + ELSE + Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / UPW(K-1,I)) * MIN(ZW(k)-ZW(k-1), 250.) + ENDIF + !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. + !Add max increase of 2.0 m/s for coarse vertical resolution. + IF(Wn > UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN + Wn = UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) + ENDIF + !Add symmetrical max decrease in w + IF(Wn < UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN + Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) + ENDIF + Wn = MIN(MAX(Wn,0.0), 3.0) + + IF (debug_mf == 1) THEN + IF (Wn .GE. 3.0) THEN + ! surface values + print *," **** SUSPICIOUSLY LARGE W:" + print *,' QCn:',QCn,' ENT=',ENT(k,i),' Nup2=',Nup2 + print *,'pblh:',pblh,' Wn:',Wn,' UPW(k-1)=',UPW(K-1,I) + print *,'K=',k,' B=',B,' dz=',ZW(k)-ZW(k-1) + ENDIF + ENDIF + + !Allow strongly forced plumes to overshoot if KE is sufficient + IF (fltv > 0.05 .AND. Wn <= 0 .AND. overshoot == 0) THEN + overshoot = 1 + IF ( THVk-THVkm1 .GT. 0.0 ) THEN + bvf = SQRT( gtr*(THVk-THVkm1)/dz(k) ) + !vertical Froude number + Frz = UPW(K-1,I)/(bvf*dz(k)) + IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I) + ENDIF + ELSEIF (fltv > 0.05 .AND. overshoot == 1) THEN + !Do not let overshooting parcel go more than 1 layer up + Wn = 0.0 + ENDIF + + !Limit very tall plumes +! Wn2=Wn2*EXP(-MAX(ZW(k)-(pblh+2000.),0.0)/1000.) +! IF(ZW(k) >= pblh+3000.)Wn2=0. + Wn=Wn*EXP(-MAX(ZW(k+1)-MIN(pblh+2000.,3000.),0.0)/1000.) + IF(ZW(k+1) >= MIN(pblh+3000.,4500.))Wn=0. + + !JOE- minimize the plume penetratration in stratocu-topped PBL + ! IF (fltv < 0.06) THEN + ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. + ! ENDIF + + IF (Wn > 0.) THEN + UPW(K,I)=Wn !Wn !sqrt(Wn2) + UPTHV(K,I)=THVn + UPTHL(K,I)=THLn + UPQT(K,I)=QTn + UPQC(K,I)=QCn + UPU(K,I)=Un + UPV(K,I)=Vn + UPQKE(K,I)=QKEn + UPQNC(K,I)=QNCn + UPQNI(K,I)=QNIn + UPQNWFA(K,I)=QNWFAn + UPQNIFA(K,I)=QNIFAn + UPA(K,I)=UPA(K-1,I) +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + UPCHEM(k,I,ic) = chemn(ic) + enddo + ENDIF +#endif + ktop = MAX(ktop,k) + ELSE + exit !exit k-loop + END IF + ENDDO + IF (debug_mf == 1) THEN + IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. & + MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN + ! surface values + print *,'flq:',flq,' fltv:',fltv,' Nup2=',Nup2 + print *,'pblh:',pblh,' wstar:',wstar,' ktop=',ktop + print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT + ! means + print *,'u:',u + print *,'v:',v + print *,'thl:',thl + print *,'UPA:',UPA(:,I) + print *,'UPW:',UPW(:,I) + print *,'UPTHL:',UPTHL(:,I) + print *,'UPQT:',UPQT(:,I) + print *,'ENT:',ENT(:,I) + ENDIF + ENDIF + ENDDO + ELSE + !At least one of the conditions was not met for activating the MF scheme. + NUP2=0. + END IF !end criteria for mass-flux scheme + + ktop=MIN(ktop,KTE-1) ! Just to be safe... + IF (ktop == 0) THEN + ztop = 0.0 + ELSE + ztop=zw(ktop+1) + ENDIF + + IF(nup2 > 0) THEN + + !Calculate the fluxes for each variable + DO k=KTS,KTE + IF(k > KTOP) exit + DO i=1,NUP !NUP2 + IF(I > NUP2) exit + s_aw(k+1) = s_aw(k+1) + UPA(K,i)*UPW(K,i)*Psig_w + s_awthl(k+1)= s_awthl(k+1) + UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w + s_awqt(k+1) = s_awqt(k+1) + UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w + s_awqc(k+1) = s_awqc(k+1) + UPA(K,i)*UPW(K,i)*UPQC(K,i)*Psig_w + IF (momentum_opt > 0) THEN + s_awu(k+1) = s_awu(k+1) + UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w + s_awv(k+1) = s_awv(k+1) + UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w + ENDIF + IF (tke_opt > 0) THEN + s_awqke(k+1)= s_awqke(k+1) + UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w + ENDIF +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + s_awchem(k+1,ic) = s_awchem(k+1,ic) + UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w + enddo + ENDIF +#endif + ENDDO + s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) + ENDDO + IF (scalar_opt > 0) THEN + DO k=KTS,KTE + IF(k > KTOP) exit + DO I=1,NUP !NUP2 + IF (I > NUP2) exit + s_awqnc(k+1)= s_awqnc(K+1) + UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w + s_awqni(k+1)= s_awqni(K+1) + UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w + s_awqnwfa(k+1)= s_awqnwfa(K+1) + UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w + s_awqnifa(k+1)= s_awqnifa(K+1) + UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w + ENDDO + ENDDO + ENDIF + + !Flux limiter: Check for too large heat flux at top of first model layer + ! Given that the temperature profile is calculated as: + ! d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & + ! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt*dheat_opt + ! So, s_awthl(kts+1) must be less than flt + THVk = (THL(kts)*DZ(kts+1)+THL(kts+1)*DZ(kts))/(DZ(kts+1)+DZ(kts)) + flx1 = MAX(s_aw(kts+1)*(s_awthl(kts+1)/s_aw(kts+1) - THVk),0.0) + !flx1 = -dt/dz(kts)*s_awthl(kts+1) + !flx1 = (s_awthl(kts+1)-s_awthl(kts))!/(0.5*(dz(k)+dz(k-1))) + adjustment=1.0 + !Print*,"Flux limiter in MYNN-EDMF:" + !Print*,"flx1=",flx1," s_awthl(kts+1)=",s_awthl(kts+1)," s_awthl(kts)=",s_awthl(kts) + IF (flx1 > fluxportion*flt .AND. flx1>0.0) THEN + adjustment= fluxportion*flt/flx1 + s_aw = s_aw*adjustment + s_awthl= s_awthl*adjustment + s_awqt = s_awqt*adjustment + s_awqc = s_awqc*adjustment + s_awqv = s_awqv*adjustment + s_awqnc= s_awqnc*adjustment + s_awqni= s_awqni*adjustment + s_awqnwfa= s_awqnwfa*adjustment + s_awqnifa= s_awqnifa*adjustment + IF (momentum_opt > 0) THEN + s_awu = s_awu*adjustment + s_awv = s_awv*adjustment + ENDIF + IF (tke_opt > 0) THEN + s_awqke= s_awqke*adjustment + ENDIF +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + s_awchem = s_awchem*adjustment + ENDIF +#endif + UPA = UPA*adjustment + ENDIF + !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt + + !Calculate mean updraft properties for output: + DO k=KTS,KTE-1 + IF(k > KTOP) exit + DO I=1,NUP !NUP2 + IF(I > NUP2) exit + edmf_a(K) =edmf_a(K) +UPA(K,i) + edmf_w(K) =edmf_w(K) +UPA(K,i)*UPW(K,i) + edmf_qt(K) =edmf_qt(K) +UPA(K,i)*UPQT(K,i) + edmf_thl(K)=edmf_thl(K)+UPA(K,i)*UPTHL(K,i) + edmf_ent(K)=edmf_ent(K)+UPA(K,i)*ENT(K,i) + edmf_qc(K) =edmf_qc(K) +UPA(K,i)*UPQC(K,i) +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + edmf_chem(k,ic) = edmf_chem(k,ic) + UPA(K,I)*UPCHEM(k,i,ic) + enddo + ENDIF +#endif + ENDDO + + IF (edmf_a(k)>0.) THEN + edmf_w(k)=edmf_w(k)/edmf_a(k) + edmf_qt(k)=edmf_qt(k)/edmf_a(k) + edmf_thl(k)=edmf_thl(k)/edmf_a(k) + edmf_ent(k)=edmf_ent(k)/edmf_a(k) + edmf_qc(k)=edmf_qc(k)/edmf_a(k) +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) + enddo + ENDIF +#endif + edmf_a(k)=edmf_a(k)*Psig_w + + !FIND MAXIMUM MASS-FLUX IN THE COLUMN: + IF(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) + ENDIF + ENDDO + + !First, compute exner, plume theta, and dz centered at interface + !Here, k=1 is the top of the first model layer. These values do not + !need to be defined at k=kte (unused level). + DO K=KTS,KTE-1 + exneri(k) = (exner(k)*DZ(k+1)+exner(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K) + dzi(k) = 0.5*(DZ(k)+DZ(k+1)) + ENDDO + +!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in +! mym_condensation. Here, a shallow-cu component is added, but no cumulus +! clouds can be added at k=1 (start loop at k=2). + DO K=KTS+1,KTE-2 + IF(k > KTOP) exit + IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN + + satvp = 3.80*exp(17.27*(th(k)-273.)/ & + (th(k)-36.))/(.01*p(k)) + rhgrid = max(.01,MIN( 1., qv(k) /satvp)) + + !then interpolate plume thl, th, and qt to mass levels + THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) + QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) + !convert TH to T + t = THp*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + + !condensed liquid in the plume on mass levels + IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN + QCp = 0.5*(edmf_qc(k)+edmf_qc(k-1)) + ELSE + QCp = MAX(0.0, QTp-qsl) + ENDIF + + !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq + + xl = xl_blend(tk(k)) ! obtain blended heat capacity + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 + a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + b9 = a*rsl ! CB02 variable "b" + + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*QCp*0.5*(edmf_a(k)+edmf_a(k-1)) ! potential temp (env + plume) + bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from + ! "b9" in CB02 by a factor + ! of T/theta. Strictly, b9 above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qt(k) + alpha = 0.61*pt + t = TH(k)*exner(k) + beta = pt*xl/(t*cp) - 1.61*pt + !Buoyancy flux terms have been moved to the end of this section... + + !Now calculate convective component of the cloud fraction: + if (a > 0.0) then + f = MIN(1.0/a, 4.0) ! f is vertical profile scaling function (CB2005) + else + f = 1.0 + endif + sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & + & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + !sigq = MAX(sigq, 1.0E-4) + sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components + + qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; + ! the numerator of Q1 + mf_cf = min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) + IF ( debug_code ) THEN + print*,"In MYNN, StEM edmf" + print*," CB: env qt=",qt(k)," qsat=",qsat_tl + print*," satdef=",QTp - qsat_tl + print*," CB: sigq=",sigq," qmq=",qmq," tlk=",tlk + print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) + ENDIF + + IF (cldfra_bl1d(k) < 0.5) THEN + IF (mf_cf > 0.5*(edmf_a(k)+edmf_a(k-1))) THEN + cldfra_bl1d(k) = mf_cf + qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf + ELSE + cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) + qc_bl1d(k) = QCp + ENDIF + ENDIF + + !Now recalculate the terms for the buoyancy flux for mass-flux clouds: + !See mym_condensation for details on these formulations. The + !cloud-fraction bounding was added to improve cloud retention, + !following RAP and HRRR testing. + !Fng = 2.05 ! the non-Gaussian transport factor (assumed constant) + !Use Bechtold and Siebesma (1998) piecewise estimation of Fng: + Q1 = qmq/MAX(sigq,1E-10) + Q1=MAX(Q1,-5.0) + IF (Q1 .GE. 1.0) THEN + Fng = 1.0 + ELSEIF (Q1 .GE. -1.7 .AND. Q1 < 1.0) THEN + Fng = EXP(-0.4*(Q1-1.0)) + ELSEIF (Q1 .GE. -2.5 .AND. Q1 .LE. -1.7) THEN + Fng = 3.0 + EXP(-3.8*(Q1+1.7)) + ELSE + Fng = MIN(23.9 + EXP(-1.6*(Q1+2.5)), 60.) + ENDIF + + vt(k) = qww - MIN(0.4,cldfra_bl1D(k))*beta*bb*Fng - 1. + vq(k) = alpha + MIN(0.4,cldfra_bl1D(k))*beta*a*Fng - tv0 + ENDIF + + ENDDO + + ENDIF !end nup2 > 0 + + !modify output (negative: dry plume, positive: moist plume) + IF (ktop > 0) THEN + maxqc = maxval(edmf_qc(1:ktop)) + IF ( maxqc < 1.E-8) maxmf = -1.0*maxmf + ENDIF + +! +! debugging +! +IF (edmf_w(1) > 4.0) THEN +! surface values + print *,'flq:',flq,' fltv:',fltv + print *,'pblh:',pblh,' wstar:',wstar + print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT +! means +! print *,'u:',u +! print *,'v:',v +! print *,'thl:',thl +! print *,'thv:',thv +! print *,'qt:',qt +! print *,'p:',p + +! updrafts +! DO I=1,NUP2 +! print *,'up:A',i +! print *,UPA(:,i) +! print *,'up:W',i +! print*,UPW(:,i) +! print *,'up:thv',i +! print *,UPTHV(:,i) +! print *,'up:thl',i +! print *,UPTHL(:,i) +! print *,'up:qt',i +! print *,UPQT(:,i) +! print *,'up:tQC',i +! print *,UPQC(:,i) +! print *,'up:ent',i +! print *,ENT(:,i) +! ENDDO + +! mean updrafts + print *,' edmf_a',edmf_a(1:14) + print *,' edmf_w',edmf_w(1:14) + print *,' edmf_qt:',edmf_qt(1:14) + print *,' edmf_thl:',edmf_thl(1:14) + +ENDIF !END Debugging + + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + +END SUBROUTINE DMP_MF +!================================================================= + +subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) +! +! zero or one condensation for edmf: calculates THV and QC +! +real,intent(in) :: QT,THL,P,zagl +real,intent(out) :: THV +real,intent(inout):: QC + +integer :: niter,i +real :: diff,exn,t,th,qs,qcold + +! constants used from module_model_constants.F +! p1000mb +! rcp ... Rd/cp +! xlv ... latent heat for water (2.5e6) +! cp +! rvord .. rv/rd (1.6) + +! number of iterations + niter=50 +! minimum difference (usually converges in < 8 iterations with diff = 2e-5) + diff=2.e-5 + + EXN=(P/p1000mb)**rcp + !QC=0. !better first guess QC is incoming from lower level, do not set to zero + do i=1,NITER + T=EXN*THL + xlv/cp*QC + QS=qsat_blend(T,P) + QCOLD=QC + QC=0.5*QC + 0.5*MAX((QT-QS),0.) + if (abs(QC-QCOLD) 0.0) THEN +! PRINT*,"EDMF SAT, p:",p," iterations:",i +! PRINT*," T=",T," THL=",THL," THV=",THV +! PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs +! ENDIF + + !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE + !TH = THL + xlv/cp/EXN*QC + !THV= TH*(1. + 0.608*QT) + + !print *,'t,p,qt,qs,qc' + !print *,t,p,qt,qs,qc + + +end subroutine condensation_edmf + +!=============================================================== + +SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) + + !--------------------------------------------------------------- + ! NOTES ON SCALE-AWARE FORMULATION + ! + !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011, + ! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS) + ! + ! Psig_bl tapers local mixing + ! Psig_shcu tapers nonlocal mixing + + REAL,INTENT(IN) :: dx,PBL1 + REAL, INTENT(OUT) :: Psig_bl,Psig_shcu + REAL :: dxdh + + Psig_bl=1.0 + Psig_shcu=1.0 + dxdh=MAX(dx,10.)/MIN(PBL1,3000.) + ! Honnert et al. 2011, TKE in PBL *** original form used until 201605 + !Psig_bl= ((dxdh**2) + 0.07*(dxdh**0.667))/((dxdh**2) + & + ! (3./21.)*(dxdh**0.67) + (3./42.)) + ! Honnert et al. 2011, TKE in entrainment layer + !Psig_bl= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & + ! (3./20.)*(dxdh**0.67) + (7./21.)) + ! New form to preseve parameterized mixing - only down 5% at dx = 750 m + Psig_bl= ((dxdh**2) + 0.106*(dxdh**0.667))/((dxdh**2) +0.066*(dxdh**0.667) + 0.071) + + !assume a 500 m cloud depth for shallow-cu clods + dxdh=MAX(dx,10.)/MIN(PBL1+500.,3500.) + ! Honnert et al. 2011, TKE in entrainment layer *** original form used until 201605 + !Psig_shcu= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & + ! (3./20.)*(dxdh**0.67) + (7./21.)) + + ! Honnert et al. 2011, TKE in cumulus + !Psig(i)= ((dxdh**2) + 1.67*(dxdh**1.4))/((dxdh**2) +1.66*(dxdh**1.4) + + !0.2) + + ! Honnert et al. 2011, w'q' in PBL + !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.03*(dxdh**1.4) - + !(4./13.))/((dxdh**2) + 0.03*(dxdh**1.4) + (4./13.)) + ! Honnert et al. 2011, w'q' in cumulus + !Psig(i)= ((dxdh**2) - 0.07*(dxdh**1.4))/((dxdh**2) -0.07*(dxdh**1.4) + + !0.02) + + ! Honnert et al. 2011, q'q' in PBL + !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.25*(dxdh**0.667) -0.73)/((dxdh**2) + !-0.03*(dxdh**0.667) + 0.73) + ! Honnert et al. 2011, q'q' in cumulus + !Psig(i)= ((dxdh**2) - 0.34*(dxdh**1.4))/((dxdh**2) - 0.35*(dxdh**1.4) + !+ 0.37) + + ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in PBL (same as Honnert's above) + !Psig_shcu= ((dxdh**2) + 0.070*(dxdh**0.667))/((dxdh**2) + !+0.142*(dxdh**0.667) + 0.071) + ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in entrainment zone *** switch to this form 201605 + Psig_shcu= ((dxdh**2) + 0.145*(dxdh**0.667))/((dxdh**2) +0.172*(dxdh**0.667) + 0.170) + + ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in PBL + !Psig(i)= 0.5 + 0.5*((dxdh**2) -0.098)/((dxdh**2) + 0.106) + ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in entrainment zone + !Psig(i)= 0.5 + 0.5*((dxdh**2) - 0.112*(dxdh**0.25) -0.071)/((dxdh**2) + !+ 0.054*(dxdh**0.25) + 0.10) + + !print*,"in scale_aware; dx, dxdh, Psig(i)=",dx,dxdh,Psig(i) + !If(Psig_bl(i) < 0.0 .OR. Psig(i) > 1.)print*,"dx, dxdh, Psig(i)=",dx,dxdh,Psig_bl(i) + If(Psig_bl > 1.0) Psig_bl=1.0 + If(Psig_bl < 0.0) Psig_bl=0.0 + + If(Psig_shcu > 1.0) Psig_shcu=1.0 + If(Psig_shcu < 0.0) Psig_shcu=0.0 + + END SUBROUTINE SCALE_AWARE + +! ===================================================================== + + FUNCTION esat_blend(t) +! JAYMES- added 22 Apr 2015 +! +! This calculates saturation vapor pressure. Separate ice and liquid functions +! are used (identical to those in module_mp_thompson.F, v3.6). Then, the +! final returned value is a temperature-dependant "blend". Because the final +! value is "phase-aware", this formulation may be preferred for use throughout +! the module (replacing "svp"). + + IMPLICIT NONE + + REAL, INTENT(IN):: t + REAL :: esat_blend,XC,ESL,ESI,chi + + XC=MAX(-80.,t-273.16) + +! For 253 < t < 273.16 K, the vapor pressures are "blended" as a function of temperature, +! using the approach of Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting +! values are returned from the function. + IF (t .GE. 273.16) THEN + esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ELSE IF (t .LE. 253.) THEN + esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + ELSE + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + chi = (273.16-t)/20.16 + esat_blend = (1.-chi)*ESL + chi*ESI + END IF + + END FUNCTION esat_blend + +! ==================================================================== + + FUNCTION qsat_blend(t, P, waterice) +! JAYMES- this function extends function "esat" and returns a "blended" +! saturation mixing ratio. + + IMPLICIT NONE + + REAL, INTENT(IN):: t, P + CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: waterice + CHARACTER(LEN=1) :: wrt + REAL :: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi + + IF ( .NOT. PRESENT(waterice) ) THEN + wrt = 'b' + ELSE + wrt = waterice + ENDIF + + XC=MAX(-80.,t-273.16) + + IF ((t .GE. 273.16) .OR. (wrt .EQ. 'w')) THEN + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + qsat_blend = 0.622*ESL/(P-ESL) + ELSE IF (t .LE. 253.) THEN + ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + qsat_blend = 0.622*ESI/(P-ESI) + ELSE + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + RSLF = 0.622*ESL/(P-ESL) + RSIF = 0.622*ESI/(P-ESI) + chi = (273.16-t)/20.16 + qsat_blend = (1.-chi)*RSLF + chi*RSIF + END IF + + END FUNCTION qsat_blend + +! =================================================================== + + FUNCTION xl_blend(t) +! JAYMES- this function interpolates the latent heats of vaporization and +! sublimation into a single, temperature-dependant, "blended" value, following +! Chaboureau and Bechtold (2002), Appendix. + + IMPLICIT NONE + + REAL, INTENT(IN):: t + REAL :: xl_blend,xlvt,xlst,chi + + IF (t .GE. 273.16) THEN + xl_blend = xlv + (cpv-cliq)*(t-273.16) !vaporization/condensation + ELSE IF (t .LE. 253.) THEN + xl_blend = xls + (cpv-cice)*(t-273.16) !sublimation/deposition + ELSE + xlvt = xlv + (cpv-cliq)*(t-273.16) !vaporization/condensation + xlst = xls + (cpv-cice)*(t-273.16) !sublimation/deposition + chi = (273.16-t)/20.16 + xl_blend = (1.-chi)*xlvt + chi*xlst !blended + END IF + + END FUNCTION xl_blend + +! =================================================================== +! =================================================================== +! =================================================================== + +END MODULE module_bl_mynn From a55fca00a8a75d7861272aa7b83db6f42b330c35 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Tue, 26 Feb 2019 08:01:19 -0700 Subject: [PATCH 09/15] CMakeLists.txt: bugfix, add back in -fimf-arch-consistency=true in DEBUG/REPRO mode --- CMakeLists.txt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 2df5a8817..8143a32ec 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -168,10 +168,16 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 ./physics/micro_mg3_0.F90 PROPERTIES COMPILE_FLAGS "-fimf-arch-consistency=true") + # Add all of the above files to the list of schemes with special compiler flags + list(APPEND SCHEMES_SFX ./physics/micro_mg2_0.F90 + ./physics/micro_mg3_0.F90) elseif (${CMAKE_BUILD_TYPE} MATCHES "Bitforbit") SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 ./physics/micro_mg3_0.F90 PROPERTIES COMPILE_FLAGS "-fimf-arch-consistency=true") + # Add all of the above files to the list of schemes with special compiler flags + list(APPEND SCHEMES_SFX ./physics/micro_mg2_0.F90 + ./physics/micro_mg3_0.F90) elseif (TRANSITION) # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I, -no-prec-div with -prec-div, and # -no-prec-sqrt with -prec-sqrt for certain files for bit-for-bit reproducibility From 9e46e5e7aaf8eba19cc3b911364493df2b50ac3a Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 27 Feb 2019 13:42:12 -0700 Subject: [PATCH 10/15] CMakeLists.txt: reduce optimization for gcm_shoc.F90; force-remove bounds-check for auto-generated physics caps (similar to the existing force-removal of pointer association checks) --- CMakeLists.txt | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 8143a32ec..9e59ca1ba 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -204,6 +204,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/sflx.f ./physics/satmedmfvdif.F ./physics/cs_conv.F90 + ./physics/gcm_shoc.F90 PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT2}") # Add all of the above files to the list of schemes with special compiler flags list(APPEND SCHEMES_SFX ./physics/micro_mg2_0.F90 @@ -214,6 +215,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/sflx.f ./physics/satmedmfvdif.F ./physics/cs_conv.F90 + ./physics/gcm_shoc.F90 ./physics/gfdl_fv_sat_adj.F90) endif (${CMAKE_BUILD_TYPE} MATCHES "Debug") @@ -254,21 +256,22 @@ else (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") endif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") # The auto-generated caps can contain calls to physics schemes in -# which some of the arguments (pointers) are not associated. This is -# on purpose to avoid allocating fields that are not used inside the +# which some of the arguments (pointers, arrays) are not associated/allocated. +# This is on purpose to avoid allocating fields that are not used inside the # scheme if, for example, certain conditions are not met. To avoid # Fortran runtime errors, it is necessary to remove checks for pointers -# that are not associated from the caps ONLY. For the physics schemes, -# these checks can and should remain enabled. Overwriting the check flags -# explicitly works for Intel and GNU, but not for PGI. +# that are not associated and for array bounds from the caps ONLY. For the +# physics schemes, these checks can and should remain enabled. Overwriting +# the pointer check flags explicitly works for Intel and GNU, but not for PGI. if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") - set_property(SOURCE ${CAPS} PROPERTY COMPILE_FLAGS "-fcheck=no-pointer") + set_property(SOURCE ${CAPS} PROPERTY COMPILE_FLAGS "-fcheck=no-pointer,no-bounds") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") - set_property(SOURCE ${CAPS} PROPERTY COMPILE_FLAGS "-check nopointers") + set_property(SOURCE ${CAPS} PROPERTY COMPILE_FLAGS "-check nopointers,nobounds") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") if (CMAKE_Fortran_FLAGS MATCHES ".*chkptr.*") message (FATAL_ERROR "PGI compiler option chkptr cannot be used for CCPP physics") endif (CMAKE_Fortran_FLAGS MATCHES ".*chkptr.*") + set_property(SOURCE ${CAPS} PROPERTY COMPILE_FLAGS "-Mnobounds") endif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") if (PROJECT STREQUAL "CCPP-FV3") From 6b8634d1a6205e59e0dc469de6b147c70db0aaa6 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 27 Feb 2019 13:43:27 -0700 Subject: [PATCH 11/15] physics/cs_conv.F90, physics/GFS_suite_interstitial.F90: remove hard-coded dimensions for arrays that may not be allocated, depending on the choice of microphysics --- physics/GFS_suite_interstitial.F90 | 8 ++++++-- physics/cs_conv.F90 | 4 +++- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 8abe472b2..5606ed1f1 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -615,7 +615,9 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, satmedmf, trans_tr real(kind=kind_phys), dimension(im), intent(in) :: xlat real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: gq0 - real(kind=kind_phys), dimension(im, levs), intent(inout) :: rhc, save_qc, save_qi + real(kind=kind_phys), dimension(im, levs), intent(inout) :: rhc, save_qc + ! save_qi is not allocated for Zhao-Carr MP + real(kind=kind_phys), dimension(:, :), intent(inout) :: save_qi real(kind=kind_phys), dimension(im, levs, nn), intent(inout) :: clw character(len=*), intent(out) :: errmsg @@ -829,7 +831,9 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, lgocart, tracers_t logical, intent(in) :: ltaerosol, lgocart real(kind=kind_phys), intent(in) :: con_pi, dtf - real(kind=kind_phys), dimension(im,levs), intent(in) :: save_qc, save_qi + real(kind=kind_phys), dimension(im,levs), intent(in) :: save_qc + ! save_qi is not allocated for Zhao-Carr MP + real(kind=kind_phys), dimension(:, :), intent(in) :: save_qi real(kind=kind_phys), dimension(im,levs,ntrac), intent(inout) :: gq0 real(kind=kind_phys), dimension(im,levs,nn), intent(inout) :: clw diff --git a/physics/cs_conv.F90 b/physics/cs_conv.F90 index 6a4ad57ba..0562acdf4 100644 --- a/physics/cs_conv.F90 +++ b/physics/cs_conv.F90 @@ -59,7 +59,9 @@ subroutine cs_conv_pre_run(im, levs, ntrac, ncld, q, clw1, clw2, & ! --- input/output real(r8), dimension(ntrac-ncld+2), intent(out) :: fswtr, fscav real(r8), dimension(im), intent(out) :: wcbmax - real(r8), dimension(im,levs), intent(out) :: save_q1,save_q2,save_q3 + real(r8), dimension(im,levs), intent(out) :: save_q1,save_q2 + ! save_q3 is not allocated for Zhao-Carr MP + real(r8), dimension(:,:), intent(out) :: save_q3 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg From e2652e85238016acd55c5f2bcdad36eee6f68809 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 27 Feb 2019 16:13:40 -0700 Subject: [PATCH 12/15] physics/module_bl_mynn.F90: remove trailing whitespaces --- physics/module_bl_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 661bde35e..81d9e1089 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -113,7 +113,7 @@ MODULE module_bl_mynn & p_qnc= 0, & & p_qni= 0 -!END FV3 CONSTANTS +!END FV3 CONSTANTS !==================================================================== !WRF CONSTANTS ! USE module_model_constants, only: & From 587e72aeb698e71cd21ea6edb29faa7a0b8792a4 Mon Sep 17 00:00:00 2001 From: "haiqin.li" Date: Thu, 28 Feb 2019 03:10:25 +0000 Subject: [PATCH 13/15] "delete from the top layer" --- cu_gf_deep.F90 | 4877 ----------------------------------- cu_gf_driver.F90 | 836 ------ cu_gf_sh.F90 | 937 ------- module_bl_mynn.F90 | 6100 -------------------------------------------- 4 files changed, 12750 deletions(-) delete mode 100644 cu_gf_deep.F90 delete mode 100644 cu_gf_driver.F90 delete mode 100644 cu_gf_sh.F90 delete mode 100644 module_bl_mynn.F90 diff --git a/cu_gf_deep.F90 b/cu_gf_deep.F90 deleted file mode 100644 index d30b6b117..000000000 --- a/cu_gf_deep.F90 +++ /dev/null @@ -1,4877 +0,0 @@ -module cu_gf_deep - use machine , only : kind_phys - real(kind=kind_phys), parameter::g=9.81 - real(kind=kind_phys), parameter:: cp=1004. - real(kind=kind_phys), parameter:: xlv=2.5e6 - real(kind=kind_phys), parameter::r_v=461. - real(kind=kind_phys), parameter :: tcrit=258. -! tuning constant for cloudwater/ice detrainment - real(kind=kind_phys), parameter:: c1= 0.003 !.002 ! .0005 -! parameter to turn on or off evaporation of rainwater as done in sas - integer, parameter :: irainevap=0 -! max allowed fractional coverage (frh_thresh) - real(kind=kind_phys), parameter::frh_thresh = .9 -! rh threshold. if fractional coverage ~ frh_thres, do not use cupa any further - real(kind=kind_phys), parameter::rh_thresh = .97 -! tuning constant for j. brown closure (ichoice = 4,5,6) - real(kind=kind_phys), parameter::betajb=1.2 -! tuning for shallow and mid convection. ec uses 1.5 - integer, parameter:: use_excess=0 - real(kind=kind_phys), parameter :: fluxtune=1.5 -! flag to turn off or modify mom transport by downdrafts - !real(kind=kind_phys), parameter :: pgcd = 1. - real(kind=kind_phys), parameter :: pgcd = 0.1 -! -! aerosol awareness, do not user yet! -! - integer, parameter :: autoconv=1 - integer, parameter :: aeroevap=1 - real(kind=kind_phys), parameter :: ccnclean=250. -! still 16 ensembles for clousres - integer, parameter:: maxens3=16 - -!---meltglac------------------------------------------------- - logical, parameter :: melt_glac = .true. !- turn on/off ice phase/melting - real(kind=kind_phys), parameter :: & - t_0 = 273.16, & ! k - t_ice = 250.16, & ! k - xlf = 0.333e6 ! latent heat of freezing (j k-1 kg-1) -!---meltglac------------------------------------------------- -!-----srf-08aug2017-----begin - real(kind=kind_phys), parameter :: qrc_crit= 2.e-4 -!-----srf-08aug2017-----end - -contains - - subroutine cu_gf_deep_run( & - itf,ktf,its,ite, kts,kte & - - ,dicycle & ! diurnal cycle flag - ,ichoice & ! choice of closure, use "0" for ensemble average - ,ipr & ! this flag can be used for debugging prints - ,ccn & ! not well tested yet - ,dtime & - ,imid & ! flag to turn on mid level convection - - ,kpbl & ! level of boundary layer height - ,dhdt & ! boundary layer forcing (one closure for shallow) - ,xland & ! land mask - - ,zo & ! heights above surface - ,forcing & ! only diagnostic - ,t & ! t before forcing - ,q & ! q before forcing - ,z1 & ! terrain - ,tn & ! t including forcing - ,qo & ! q including forcing - ,po & ! pressure (mb) - ,psur & ! surface pressure (mb) - ,us & ! u on mass points - ,vs & ! v on mass points - ,rho & ! density - ,hfx & ! w/m2, positive upward - ,qfx & ! w/m2, positive upward - ,dx & ! dx is grid point dependent here - ,mconv & ! integrated vertical advection of moisture - ,omeg & ! omega (pa/s) - - ,csum & ! used to implement memory, set to zero if not avail - ,cnvwt & ! gfs needs this - ,zuo & ! nomalized updraft mass flux - ,zdo & ! nomalized downdraft mass flux - ,zdm & ! nomalized downdraft mass flux from mid scheme - ,edto & - ,edtm & - ,xmb_out & !the xmb's may be needed for dicycle - ,xmbm_in & - ,xmbs_in & - ,pre & - ,outu & ! momentum tendencies at mass points - ,outv & - ,outt & ! temperature tendencies - ,outq & ! q tendencies - ,outqc & ! ql/qice tendencies - ,kbcon & - ,ktop & - ,cupclw & ! used for direct coupling to radiation, but with tuning factors - ,ierr & ! ierr flags are error flags, used for debugging - ,ierrc & -! the following should be set to zero if not available - ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist - ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist - ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist - ,nranflag & ! flag to what you want perturbed - ! 1 = momentum transport - ! 2 = normalized vertical mass flux profile - ! 3 = closures - ! more is possible, talk to developer or - ! implement yourself. pattern is expected to be - ! betwee -1 and +1 -#if ( wrf_dfi_radar == 1 ) - ,do_capsuppress,cap_suppress_j & -#endif - ,k22 & - ,jmin,tropics) - - implicit none - - integer & - ,intent (in ) :: & - nranflag,itf,ktf,its,ite, kts,kte,ipr,imid - integer, intent (in ) :: & - ichoice - real(kind=kind_phys), dimension (its:ite,4) & - ,intent (in ) :: rand_clos - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: rand_mom,rand_vmas - -#if ( wrf_dfi_radar == 1 ) -! -! option of cap suppress: -! do_capsuppress = 1 do -! do_capsuppress = other don't -! -! - integer, intent(in ) ,optional :: do_capsuppress - real(kind=kind_phys), dimension( its:ite ) :: cap_suppress_j -#endif - ! - ! - ! - real(kind=kind_phys), dimension (its:ite,1:maxens3) :: xf_ens,pr_ens - ! outtem = output temp tendency (per s) - ! outq = output q tendency (per s) - ! outqc = output qc tendency (per s) - ! pre = output precip - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (inout ) :: & - cnvwt,outu,outv,outt,outq,outqc,cupclw - real(kind=kind_phys), dimension (its:ite) & - ,intent (inout ) :: & - pre,xmb_out - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - hfx,qfx,xmbm_in,xmbs_in - integer, dimension (its:ite) & - ,intent (inout ) :: & - kbcon,ktop - integer, dimension (its:ite) & - ,intent (in ) :: & - kpbl,tropics - ! - ! basic environmental input includes moisture convergence (mconv) - ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off - ! convection for this call only and at that particular gridpoint - ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - dhdt,rho,t,po,us,vs,tn - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (inout ) :: & - omeg - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (inout) :: & - q,qo,zuo,zdo,zdm - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - dx,ccn,z1,psur,xland - real(kind=kind_phys), dimension (its:ite) & - ,intent (inout ) :: & - mconv - - - real(kind=kind_phys) & - ,intent (in ) :: & - dtime - - -! -! local ensemble dependent variables in this routine -! - real(kind=kind_phys), dimension (its:ite,1) :: & - xaa0_ens - real(kind=kind_phys), dimension (its:ite,1) :: & - edtc - real(kind=kind_phys), dimension (its:ite,kts:kte,1) :: & - dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens -! -! -! -!***************** the following are your basic environmental -! variables. they carry a "_cup" if they are -! on model cloud levels (staggered). they carry -! an "o"-ending (z becomes zo), if they are the forced -! variables. they are preceded by x (z becomes xz) -! to indicate modification by some typ of cloud -! - ! z = heights of model levels - ! q = environmental mixing ratio - ! qes = environmental saturation mixing ratio - ! t = environmental temp - ! p = environmental pressure - ! he = environmental moist static energy - ! hes = environmental saturation moist static energy - ! z_cup = heights of model cloud levels - ! q_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! t_cup = temperature (kelvin) on model cloud levels - ! p_cup = environmental pressure - ! he_cup = moist static energy on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! gamma_cup = gamma on model cloud levels -! -! - ! hcd = moist static energy in downdraft - ! zd normalized downdraft mass flux - ! dby = buoancy term - ! entr = entrainment rate - ! zd = downdraft normalized mass flux - ! entr= entrainment rate - ! hcd = h in model cloud - ! bu = buoancy term - ! zd = normalized downdraft mass flux - ! gamma_cup = gamma on model cloud levels - ! qcd = cloud q (including liquid water) after entrainment - ! qrch = saturation q in cloud - ! pwd = evaporate at that level - ! pwev = total normalized integrated evaoprate (i2) - ! entr= entrainment rate - ! z1 = terrain elevation - ! entr = downdraft entrainment rate - ! jmin = downdraft originating level - ! kdet = level above ground where downdraft start detraining - ! psur = surface pressure - ! z1 = terrain elevation - ! pr_ens = precipitation ensemble - ! xf_ens = mass flux ensembles - ! omeg = omega from large scale model - ! mconv = moisture convergence from large scale model - ! zd = downdraft normalized mass flux - ! zu = updraft normalized mass flux - ! dir = "storm motion" - ! mbdt = arbitrary numerical parameter - ! dtime = dt over which forcing is applied - ! kbcon = lfc of parcel from k22 - ! k22 = updraft originating level - ! ichoice = flag if only want one closure (usually set to zero!) - ! dby = buoancy term - ! ktop = cloud top (output) - ! xmb = total base mass flux - ! hc = cloud moist static energy - ! hkb = moist static energy at originating level - - real(kind=kind_phys), dimension (its:ite,kts:kte) :: & - entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & - xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & - p_cup,gamma_cup,t_cup, qeso_cup,qo_cup,heo_cup,heso_cup, & - zo_cup,po_cup,gammao_cup,tn_cup, & - xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & - xt_cup, dby,hc,zu,clw_all, & - dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco, & - dbyt,xdby,xhc,xzu, & - - ! cd = detrainment function for updraft - ! cdd = detrainment function for downdraft - ! dellat = change of temperature per unit mass flux of cloud ensemble - ! dellaq = change of q per unit mass flux of cloud ensemble - ! dellaqc = change of qc per unit mass flux of cloud ensemble - - cd,cdd,dellah,dellaq,dellat,dellaqc, & - u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv - - ! aa0 cloud work function for downdraft - ! edt = epsilon - ! aa0 = cloud work function without forcing effects - ! aa1 = cloud work function with forcing effects - ! xaa0 = cloud work function with cloud effects (ensemble dependent) - ! edt = epsilon - - real(kind=kind_phys), dimension (its:ite) :: & - edt,edto,edtm,aa1,aa0,xaa0,hkb, & - hkbo,xhkb, & - xmb,pwavo, & - pwevo,bu,bud,cap_max, & - cap_max_increment,closure_n,psum,psumh,sig,sigd - real(kind=kind_phys), dimension (its:ite) :: & - axx,edtmax,edtmin,entr_rate - integer, dimension (its:ite) :: & - kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & - ktopdby,kbconx,ierr2,ierr3,kbmax - - integer, dimension (its:ite), intent(inout) :: ierr - integer, dimension (its:ite), intent(in) :: csum - integer :: & - iloop,nens3,ki,kk,i,k - real(kind=kind_phys) :: & - dz,dzo,mbdt,radius, & - zcutdown,depth_min,zkbmax,z_detr,zktop, & - dh,cap_maxs,trash,trash2,frh,sig_thresh - real(kind=kind_phys) entdo,dp,subin,detdo,entup, & - detup,subdown,entdoj,entupk,detupk,totmas - - real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec - - integer :: jprnt,jmini,start_k22 - logical :: keep_going,flg(its:ite) - - character*50 :: ierrc(its:ite) - character*4 :: cumulus - real(kind=kind_phys), dimension (its:ite,kts:kte) :: & - up_massentr,up_massdetr,c1d & - ,up_massentro,up_massdetro,dd_massentro,dd_massdetro - real(kind=kind_phys), dimension (its:ite,kts:kte) :: & - up_massentru,up_massdetru,dd_massentru,dd_massdetru - real(kind=kind_phys) c1_max,buo_flux,pgcon,pgc,blqe - - real(kind=kind_phys) :: xff_mid(its:ite,2) - integer :: iversion=1 - real(kind=kind_phys) :: denom,h_entr,umean,t_star,dq - integer, intent(in) :: dicycle - real(kind=kind_phys), dimension (its:ite) :: aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean - real(kind=kind_phys), dimension (its:ite,kts:kte) :: tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl & - ,qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl & - ,gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl - real(kind=kind_phys), dimension(its:ite) :: xf_dicycle - real(kind=kind_phys), intent(inout), dimension(its:ite,10) :: forcing - integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) - real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz - integer, dimension (its:ite,kts:kte) :: k_inv_layers - -! rainevap from sas - real(kind=kind_phys) zuh2(40) - real(kind=kind_phys), dimension (its:ite) :: rntot,delqev,delq2,qevap,rn,qcond - real(kind=kind_phys) :: rain,t1,q1,elocp,evef,el2orc,evfact,evfactl,g_rain,e_dn,c_up - real(kind=kind_phys) :: pgeoh,dts,fp,fpi,pmin,x_add,beta,beta_u - real(kind=kind_phys) :: cbeg,cmid,cend,const_a,const_b,const_c -!---meltglac------------------------------------------------- - - real(kind=kind_phys), dimension (its:ite,kts:kte) :: p_liq_ice,melting_layer,melting - -!---meltglac------------------------------------------------- - melting_layer(:,:)=0. - melting(:,:)=0. - flux_tun(:)=fluxtune -! if(imid.eq.1)flux_tun(:)=fluxtune+.5 - cumulus='deep' - if(imid.eq.1)cumulus='mid' - pmin=150. - if(imid.eq.1)pmin=75. - ktopdby(:)=0 - c1_max=c1 - elocp=xlv/cp - el2orc=xlv*xlv/(r_v*cp) - evfact=.2 - evfactl=.2 - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!proportionality constant to estimate pressure gradient of updraft (zhang and wu, 2003, jas -! -! ecmwf - pgcon=0. - lambau(:)=2.0 - if(imid.eq.1)lambau(:)=2.0 -! here random must be between -1 and 1 - if(nranflag == 1)then - lambau(:)=1.5+rand_mom(:) - endif -! sas -! lambau=0. -! pgcon=-.55 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ztexec(:) = 0. - zqexec(:) = 0. - zws(:) = 0. - - do i=its,itf - !- buoyancy flux (h+le) - buo_flux= (hfx(i)/cp+0.608*t(i,1)*qfx(i)/xlv)/rho(i,1) - pgeoh = zo(i,2)*g - !-convective-scale velocity w* - zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,2)*g/t(i,1)) - if(zws(i) > tiny(pgeoh)) then - !-convective-scale velocity w* - zws(i) = 1.2*zws(i)**.3333 - !- temperature excess - ztexec(i) = max(flux_tun(i)*hfx(i)/(rho(i,1)*zws(i)*cp),0.0) - !- moisture excess - zqexec(i) = max(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.) - endif - !- zws for shallow convection closure (grant 2001) - !- height of the pbl - zws(i) = max(0.,.001-flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i))) - zws(i) = 1.2*zws(i)**.3333 - zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct - enddo -! cap_maxs=225. -! if(imid.eq.1)cap_maxs=150. - cap_maxs=75. ! 150. -! if(imid.eq.1)cap_maxs=100. - do i=its,itf - edto(i)=0. - closure_n(i)=16. - xmb_out(i)=0. - cap_max(i)=cap_maxs - cap_max_increment(i)=20. -! if(imid.eq.1)cap_max_increment(i)=10. -! -! for water or ice -! - xland1(i)=int(xland(i)+.0001) ! 1. - if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then - xland1(i)=0 -! if(imid.eq.0)cap_max(i)=cap_maxs-25. -! if(imid.eq.1)cap_max(i)=cap_maxs-50. - cap_max_increment(i)=20. - else - if(ztexec(i).gt.0.)cap_max(i)=cap_max(i)+25. - if(ztexec(i).lt.0.)cap_max(i)=cap_max(i)-25. - endif - ierrc(i)=" " -! cap_max_increment(i)=1. - enddo - if(use_excess == 0 )then - ztexec(:)=0 - zqexec(:)=0 - endif -! -!--- initial entrainment rate (these may be changed later on in the -!--- program -! - start_level(:)=kte - do i=its,ite - c1d(i,:)= 0. !c1 ! 0. ! c1 ! max(.003,c1+float(csum(i))*.0001) - entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 - if(xland1(i) == 0)entr_rate(i)=7.e-5 - if(imid.eq.1)entr_rate(i)=3.e-4 -! if(imid.eq.1)c1d(i,:)=c1 ! comment to test warm bias 08/14/17 - radius=.2/entr_rate(i) - frh=min(1.,3.14*radius*radius/dx(i)/dx(i)) - if(frh > frh_thresh)then - frh=frh_thresh - radius=sqrt(frh*dx(i)*dx(i)/3.14) - entr_rate(i)=.2/radius - endif - sig(i)=(1.-frh)**2 - enddo - sig_thresh = (1.-frh_thresh)**2 - - -! -!--- entrainment of mass -! -! -!--- initial detrainmentrates -! - do k=kts,ktf - do i=its,itf - cnvwt(i,k)=0. - zuo(i,k)=0. - zdo(i,k)=0. - z(i,k)=zo(i,k) - xz(i,k)=zo(i,k) - cupclw(i,k)=0. - cd(i,k)=.1*entr_rate(i) !1.e-9 ! 1.*entr_rate - if(imid.eq.1)cd(i,k)=.5*entr_rate(i) - cdd(i,k)=1.e-9 - hcdo(i,k)=0. - qrcdo(i,k)=0. - dellaqc(i,k)=0. - enddo - enddo -! -!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft -! base mass flux -! - edtmax(:)=1. - if(imid.eq.1)edtmax(:)=.15 - edtmin(:)=.1 - if(imid.eq.1)edtmin(:)=.05 -! -!--- minimum depth (m), clouds must have -! - depth_min=1000. - if(imid.eq.1)depth_min=500. -! -!--- maximum depth (mb) of capping -!--- inversion (larger cap = no convection) -! - do i=its,itf -! if(imid.eq.0)then -! edtmax(i)=max(0.5,.8-float(csum(i))*.015) !.3) -! if(xland1(i) == 1 )edtmax(i)=max(0.7,1.-float(csum(i))*.015) !.3) -! endif - kbmax(i)=1 - aa0(i)=0. - aa1(i)=0. - edt(i)=0. - kstabm(i)=ktf-1 - ierr2(i)=0 - ierr3(i)=0 - x_add=0. - enddo -! do i=its,itf -! cap_max(i)=cap_maxs -! cap_max3(i)=25. - -! enddo -! -!--- max height(m) above ground where updraft air can originate -! - zkbmax=4000. - if(imid.eq.1)zkbmax=2000. -! -!--- height(m) above which no downdrafts are allowed to originate -! - zcutdown=4000. -! -!--- depth(m) over which downdraft detrains all its mass -! - z_detr=500. -! if(imid.eq.1)z_detr=800. -! - -! -!--- environmental conditions, first heights -! - do i=its,itf - do k=1,maxens3 - xf_ens(i,k)=0. - pr_ens(i,k)=0. - enddo - enddo - -! -!--- calculate moist static energy, heights, qes -! - call cup_env(z,qes,he,hes,t,q,po,z1, & - psur,ierr,tcrit,-1, & - itf,ktf, & - its,ite, kts,kte) - call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, & - psur,ierr,tcrit,-1, & - itf,ktf, & - its,ite, kts,kte) - -! -!--- environmental values on cloud levels -! - call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, & - hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & - ierr,z1, & - itf,ktf, & - its,ite, kts,kte) - call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, & - heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur, & - ierr,z1, & - itf,ktf, & - its,ite, kts,kte) -!---meltglac------------------------------------------------- -!--- partition between liq/ice cloud contents - call get_partition_liq_ice(ierr,tn,po_cup,p_liq_ice,melting_layer,& - itf,ktf,its,ite,kts,kte,cumulus) -!---meltglac------------------------------------------------- - do i=its,itf - if(ierr(i).eq.0)then - if(kpbl(i).gt.5 .and. imid.eq.1)cap_max(i)=po_cup(i,kpbl(i)) - u_cup(i,kts)=us(i,kts) - v_cup(i,kts)=vs(i,kts) - do k=kts+1,ktf - u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) - v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) - enddo - endif - enddo - do i=its,itf - if(ierr(i).eq.0)then - do k=kts,ktf - if(zo_cup(i,k).gt.zkbmax+z1(i))then - kbmax(i)=k - go to 25 - endif - enddo - 25 continue -! -!--- level where detrainment for downdraft starts -! - do k=kts,ktf - if(zo_cup(i,k).gt.z_detr+z1(i))then - kdet(i)=k - go to 26 - endif - enddo - 26 continue -! - endif - enddo -! -! -! -!------- determine level with highest moist static energy content - k22 -! - start_k22=2 - do 36 i=its,itf - if(ierr(i).eq.0)then - k22(i)=maxloc(heo_cup(i,start_k22:kbmax(i)+2),1)+start_k22-1 - if(k22(i).ge.kbmax(i))then - ierr(i)=2 - ierrc(i)="could not find k22" - ktop(i)=0 - k22(i)=0 - kbcon(i)=0 - endif - endif - 36 continue -! -!--- determine the level of convective cloud base - kbcon -! - - do i=its,itf - if(ierr(i).eq.0)then - x_add = xlv*zqexec(i)+cp*ztexec(i) - call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) - call get_cloud_bc(kte,heo_cup (i,1:kte),hkbo (i),k22(i),x_add) - endif ! ierr - enddo - jprnt=0 - iloop=1 - if(imid.eq.1)iloop=5 - call cup_kbcon(ierrc,cap_max_increment,iloop,k22,kbcon,heo_cup,heso_cup, & - hkbo,ierr,kbmax,po_cup,cap_max, & - ztexec,zqexec, & - jprnt,itf,ktf, & - its,ite, kts,kte, & - z_cup,entr_rate,heo,imid) -! -!--- increase detrainment in stable layers -! - call cup_minimi(heso_cup,kbcon,kstabm,kstabi,ierr, & - itf,ktf, & - its,ite, kts,kte) - do i=its,itf - if(ierr(i) == 0)then - frh = min(qo_cup(i,kbcon(i))/qeso_cup(i,kbcon(i)),1.) - if(frh >= rh_thresh .and. sig(i) <= sig_thresh )then - ierr(i)=231 - cycle - endif -! -! never go too low... -! -! if(imid.eq.0 .and. xland1(i).eq.0)x_add=150. - x_add=0. - do k=kbcon(i)+1,ktf - if(po(i,kbcon(i))-po(i,k) > pmin+x_add)then - pmin_lev(i)=k - exit - endif - enddo -! -! initial conditions for updraft -! - start_level(i)=k22(i) - x_add = xlv*zqexec(i)+cp*ztexec(i) - call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) - endif - enddo -! -!--- get inversion layers for mid level cloud tops -! - if(imid.eq.1)then - call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers, & - kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) - endif - do i=its,itf - if(kstabi(i).lt.kbcon(i))then - kbcon(i)=1 - ierr(i)=42 - endif - do k=kts,ktf - entr_rate_2d(i,k)=entr_rate(i) - enddo - if(ierr(i).eq.0)then -! if(imid.eq.0 .and. pmin_lev(i).lt.kbcon(i)+3)pmin_lev(i)=kbcon(i)+3 - kbcon(i)=max(2,kbcon(i)) - do k=kts+1,ktf - frh = min(qo_cup(i,k)/qeso_cup(i,k),1.) - entr_rate_2d(i,k)=entr_rate(i) *(1.3-frh) - enddo - if(imid.eq.1)then - if(k_inv_layers(i,2).gt.0 .and. & - (po_cup(i,k22(i))-po_cup(i,k_inv_layers(i,2))).lt.500.)then - - ktop(i)=min(kstabi(i),k_inv_layers(i,2)) - ktopdby(i)=ktop(i) - else - do k=kbcon(i)+1,ktf - if((po_cup(i,k22(i))-po_cup(i,k)).gt.500.)then - ktop(i)=k - ktopdby(i)=ktop(i) - exit - endif - enddo - endif ! k_inv_lay - endif - - endif - enddo -! -!-- get normalized mass flux, entrainment and detrainmentrates for updraft -! - i=0 - !- for mid level clouds we do not allow clouds taller than where stability - !- changes - if(imid.eq.1)then - call rates_up_pdf(rand_vmas,ipr,'mid',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & - xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev) - else - call rates_up_pdf(rand_vmas,ipr,'deep',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & - xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kbcon,ktopdby,csum,pmin_lev) - endif -! -! -! - do i=its,itf - if(ierr(i).eq.0)then - - if(k22(i).gt.1)then - do k=1,k22(i) -1 - zuo(i,k)=0. - zu (i,k)=0. - xzu(i,k)=0. - enddo - endif - do k=k22(i),ktop(i) - xzu(i,k)= zuo(i,k) - zu (i,k)= zuo(i,k) - enddo - do k=ktop(i)+1,kte - zuo(i,k)=0. - zu (i,k)=0. - xzu(i,k)=0. - enddo - endif - enddo -! -! calculate mass entrainment and detrainment -! - if(imid.eq.1)then - call get_lateral_massflux(itf,ktf, its,ite, kts,kte & - ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & - ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,'mid',kbcon,k22,up_massentru,up_massdetru,lambau) - else - call get_lateral_massflux(itf,ktf, its,ite, kts,kte & - ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & - ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,'deep',kbcon,k22,up_massentru,up_massdetru,lambau) - endif - - -! -! note: ktop here already includes overshooting, ktopdby is without -! overshooting -! - do k=kts,ktf - do i=its,itf - uc (i,k)=0. - vc (i,k)=0. - hc (i,k)=0. - dby (i,k)=0. - hco (i,k)=0. - dbyo(i,k)=0. - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - do k=1,start_level(i) - uc(i,k)=u_cup(i,k) - vc(i,k)=v_cup(i,k) - enddo - do k=1,start_level(i)-1 - hc (i,k)=he_cup(i,k) - hco(i,k)=heo_cup(i,k) - enddo - k=start_level(i) - hc (i,k)=hkb(i) - hco(i,k)=hkbo(i) - endif - enddo - -! -!---meltglac------------------------------------------------- - ! - !--- 1st guess for moist static energy and dbyo (not including ice phase) - ! - do i=its,itf - ktopkeep(i)=0 - dbyt(i,:)=0. - if(ierr(i) /= 0) cycle - ktopkeep(i)=ktop(i) - do k=start_level(i) +1,ktop(i) !mass cons option - - denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) - if(denom.lt.1.e-8)then - ierr(i)=51 - exit - endif - hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & - up_massentro(i,k-1)*heo(i,k-1)) / & - (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) - dbyo(i,k)=hco(i,k)-heso_cup(i,k) - enddo - ! for now no overshooting (only very little) - kk=maxloc(dbyt(i,:),1) - ki=maxloc(zuo(i,:),1) - do k=ktop(i)-1,kbcon(i),-1 - if(dbyo(i,k).gt.0.)then - ktopkeep(i)=k+1 - exit - endif - enddo - ktop(i)=ktopkeep(i) - if(ierr(i).eq.0)ktop(i)=ktopkeep(i) - enddo - do 37 i=its,itf - kzdown(i)=0 - if(ierr(i).eq.0)then - zktop=(zo_cup(i,ktop(i))-z1(i))*.6 - if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4 - zktop=min(zktop+z1(i),zcutdown+z1(i)) - do k=kts,ktf - if(zo_cup(i,k).gt.zktop)then - kzdown(i)=k - kzdown(i)=min(kzdown(i),kstabi(i)-1) ! - go to 37 - endif - enddo - endif - 37 continue -! -!--- downdraft originating level - jmin -! - call cup_minimi(heso_cup,k22,kzdown,jmin,ierr, & - itf,ktf, & - its,ite, kts,kte) - do 100 i=its,itf - if(ierr(i).eq.0)then -! -!-----srf-08aug2017-----begin -! if(imid .ne. 1 .and. melt_glac) jmin(i)=max(jmin(i),maxloc(melting_layer(i,:),1)) -!-----srf-08aug2017-----end - -!--- check whether it would have buoyancy, if there where -!--- no entrainment/detrainment -! - jmini = jmin(i) - keep_going = .true. - do while ( keep_going ) - keep_going = .false. - if ( jmini - 1 .lt. kdet(i) ) kdet(i) = jmini-1 - if ( jmini .ge. ktop(i)-1 ) jmini = ktop(i) - 2 - ki = jmini - hcdo(i,ki)=heso_cup(i,ki) - dz=zo_cup(i,ki+1)-zo_cup(i,ki) - dh=0. - do k=ki-1,1,-1 - hcdo(i,k)=heso_cup(i,jmini) - dz=zo_cup(i,k+1)-zo_cup(i,k) - dh=dh+dz*(hcdo(i,k)-heso_cup(i,k)) - if(dh.gt.0.)then - jmini=jmini-1 - if ( jmini .gt. 5 ) then - keep_going = .true. - else - ierr(i) = 9 - ierrc(i) = "could not find jmini9" - exit - endif - endif - enddo - enddo - jmin(i) = jmini - if ( jmini .le. 5 ) then - ierr(i)=4 - ierrc(i) = "could not find jmini4" - endif - endif -100 continue - do i=its,itf - if(ierr(i) /= 0) cycle - do k=ktop(i)+1,ktf - hco(i,k)=heso_cup(i,k) - dbyo(i,k)=0. - enddo - enddo - ! - !--- calculate moisture properties of updraft - ! - if(imid.eq.1)then - call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & - p_cup,kbcon,ktop,dbyo,clw_all,xland1, & - qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & - zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & - 1,itf,ktf, & - its,ite, kts,kte) - else - call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & - p_cup,kbcon,ktop,dbyo,clw_all,xland1, & - qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & - zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & - 1,itf,ktf, & - its,ite, kts,kte) - endif -! !--- get melting profile -! call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & -! ,pwo,edto,pwdo,melting & -! ,itf,ktf,its,ite, kts,kte, cumulus ) -!---meltglac------------------------------------------------- - - - do i=its,itf - - ktopkeep(i)=0 - dbyt(i,:)=0. - if(ierr(i) /= 0) cycle - ktopkeep(i)=ktop(i) - do k=start_level(i) +1,ktop(i) !mass cons option - - denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) - if(denom.lt.1.e-8)then - ierr(i)=51 - exit - endif - - hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & - up_massentr(i,k-1)*he(i,k-1)) / & - (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) - uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetru(i,k-1)*uc(i,k-1)+ & - up_massentru(i,k-1)*us(i,k-1) & - -pgcon*.5*(zu(i,k)+zu(i,k-1))*(u_cup(i,k)-u_cup(i,k-1))) / & - (zu(i,k-1)-.5*up_massdetru(i,k-1)+up_massentru(i,k-1)) - vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetru(i,k-1)*vc(i,k-1)+ & - up_massentru(i,k-1)*vs(i,k-1) & - -pgcon*.5*(zu(i,k)+zu(i,k-1))*(v_cup(i,k)-v_cup(i,k-1))) / & - (zu(i,k-1)-.5*up_massdetru(i,k-1)+up_massentru(i,k-1)) - dby(i,k)=hc(i,k)-hes_cup(i,k) - hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & - up_massentro(i,k-1)*heo(i,k-1)) / & - (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) -!---meltglac------------------------------------------------- - ! - !- include glaciation effects on hc,hco - ! ------ ice content -------- - hc (i,k)= hc (i,k)+(1.-p_liq_ice(i,k))*qrco(i,k)*xlf - hco(i,k)= hco(i,k)+(1.-p_liq_ice(i,k))*qrco(i,k)*xlf - - dby(i,k)=hc(i,k)-hes_cup(i,k) -!---meltglac------------------------------------------------- - dbyo(i,k)=hco(i,k)-heso_cup(i,k) - dz=zo_cup(i,k+1)-zo_cup(i,k) - dbyt(i,k)=dbyt(i,k-1)+dbyo(i,k)*dz - - enddo -! for now no overshooting (only very little) - kk=maxloc(dbyt(i,:),1) - ki=maxloc(zuo(i,:),1) -! if(ipr .eq.1)write(16,*)'cupgf2',kk,ki -! if(kk.lt.ki+3)then -! ierr(i)=423 -! endif -! - do k=ktop(i)-1,kbcon(i),-1 - if(dbyo(i,k).gt.0.)then - ktopkeep(i)=k+1 - exit - endif - enddo - ktop(i)=ktopkeep(i) - if(ierr(i).eq.0)ktop(i)=ktopkeep(i) - enddo -41 continue - do i=its,itf - if(ierr(i) /= 0) cycle - do k=ktop(i)+1,ktf - hc(i,k)=hes_cup(i,k) - uc(i,k)=u_cup(i,k) - vc(i,k)=v_cup(i,k) - hco(i,k)=heso_cup(i,k) - dby(i,k)=0. - dbyo(i,k)=0. - zu(i,k)=0. - zuo(i,k)=0. - cd(i,k)=0. - entr_rate_2d(i,k)=0. - up_massentr(i,k)=0. - up_massdetr(i,k)=0. - up_massentro(i,k)=0. - up_massdetro(i,k)=0. - enddo - enddo -! - do i=its,itf - if(ierr(i)/=0)cycle - if(ktop(i).lt.kbcon(i)+2)then - ierr(i)=5 - ierrc(i)='ktop too small deep' - ktop(i)=0 - endif - enddo -!! do 37 i=its,itf -! kzdown(i)=0 -! if(ierr(i).eq.0)then -! zktop=(zo_cup(i,ktop(i))-z1(i))*.6 -! if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4 -! zktop=min(zktop+z1(i),zcutdown+z1(i)) -! do k=kts,ktf -! if(zo_cup(i,k).gt.zktop)then -! kzdown(i)=k -! kzdown(i)=min(kzdown(i),kstabi(i)-1) ! -! go to 37 -! endif -! enddo -! endif -! 37 continue -!! -!!--- downdraft originating level - jmin -!! -! call cup_minimi(heso_cup,k22,kzdown,jmin,ierr, & -! itf,ktf, & -! its,ite, kts,kte) -! do 100 i=its,itf -! if(ierr(i).eq.0)then -!! -!!-----srf-08aug2017-----begin -!! if(imid .ne. 1 .and. melt_glac) jmin(i)=max(jmin(i),maxloc(melting_layer(i,:),1)) -!!-----srf-08aug2017-----end -! -!!--- check whether it would have buoyancy, if there where -!!--- no entrainment/detrainment -!! -! jmini = jmin(i) -! keep_going = .true. -! do while ( keep_going ) -! keep_going = .false. -! if ( jmini - 1 .lt. kdet(i) ) kdet(i) = jmini-1 -! if ( jmini .ge. ktop(i)-1 ) jmini = ktop(i) - 2 -! ki = jmini -! hcdo(i,ki)=heso_cup(i,ki) -! dz=zo_cup(i,ki+1)-zo_cup(i,ki) -! dh=0. -! do k=ki-1,1,-1 -! hcdo(i,k)=heso_cup(i,jmini) -! dz=zo_cup(i,k+1)-zo_cup(i,k) -! dh=dh+dz*(hcdo(i,k)-heso_cup(i,k)) -! if(dh.gt.0.)then -! jmini=jmini-1 -! if ( jmini .gt. 5 ) then -! keep_going = .true. -! else -! ierr(i) = 9 -! ierrc(i) = "could not find jmini9" -! exit -! endif -! endif -! enddo -! enddo -! jmin(i) = jmini -! if ( jmini .le. 5 ) then -! ierr(i)=4 -! ierrc(i) = "could not find jmini4" -! endif -! endif -!100 continue -!! -! - must have at least depth_min m between cloud convective base -! and cloud top. -! - do i=its,itf - if(ierr(i).eq.0)then - if ( jmin(i) - 1 .lt. kdet(i) ) kdet(i) = jmin(i)-1 - if(-zo_cup(i,kbcon(i))+zo_cup(i,ktop(i)).lt.depth_min)then - ierr(i)=6 - ierrc(i)="cloud depth very shallow" - endif - endif - enddo - -! -!--- normalized downdraft mass flux profile,also work on bottom detrainment -!--- in this routine -! - do k=kts,ktf - do i=its,itf - zdo(i,k)=0. - cdd(i,k)=0. - dd_massentro(i,k)=0. - dd_massdetro(i,k)=0. - dd_massentru(i,k)=0. - dd_massdetru(i,k)=0. - hcdo(i,k)=heso_cup(i,k) - ucd(i,k)=u_cup(i,k) - vcd(i,k)=v_cup(i,k) - dbydo(i,k)=0. - mentrd_rate_2d(i,k)=entr_rate(i) - enddo - enddo - do i=its,itf - if(ierr(i)/=0)cycle - beta=max(.025,.055-float(csum(i))*.0015) !.02 - if(imid.eq.0 .and. xland1(i) == 0)then - edtmax(i)=max(0.1,.4-float(csum(i))*.015) !.3) - endif - if(imid.eq.1)beta=.025 - bud(i)=0. - cdd(i,1:jmin(i))=.1*entr_rate(i) - cdd(i,jmin(i))=0. - dd_massdetro(i,:)=0. - dd_massentro(i,:)=0. - call get_zu_zd_pdf_fim(0,po_cup(i,:),rand_vmas(i),0.0_kind_phys,ipr,xland1(i),zuh2,"down",ierr(i),kdet(i),jmin(i)+1,zdo(i,:),kts,kte,ktf,beta,kpbl(i),csum(i),pmin_lev(i)) - if(zdo(i,jmin(i)) .lt.1.e-8)then - zdo(i,jmin(i))=0. - jmin(i)=jmin(i)-1 - cdd(i,jmin(i):ktf)=0. - zdo(i,jmin(i)+1:ktf)=0. - if(zdo(i,jmin(i)) .lt.1.e-8)then - ierr(i)=876 - cycle - endif - endif - - do ki=jmin(i) ,maxloc(zdo(i,:),1),-1 - !=> from jmin to maximum value zd -> change entrainment - dzo=zo_cup(i,ki+1)-zo_cup(i,ki) - dd_massdetro(i,ki)=cdd(i,ki)*dzo*zdo(i,ki+1) - dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1)+dd_massdetro(i,ki) - if(dd_massentro(i,ki).lt.0.)then - dd_massentro(i,ki)=0. - dd_massdetro(i,ki)=zdo(i,ki+1)-zdo(i,ki) - if(zdo(i,ki+1).gt.0.)cdd(i,ki)=dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) - endif - if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) - enddo - mentrd_rate_2d(i,1)=0. - do ki=maxloc(zdo(i,:),1)-1,1,-1 - !=> from maximum value zd to surface -> change detrainment - dzo=zo_cup(i,ki+1)-zo_cup(i,ki) - dd_massentro(i,ki)=mentrd_rate_2d(i,ki)*dzo*zdo(i,ki+1) - dd_massdetro(i,ki) = zdo(i,ki+1)+dd_massentro(i,ki)-zdo(i,ki) - if(dd_massdetro(i,ki).lt.0.)then - dd_massdetro(i,ki)=0. - dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1) - if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) - endif - if(zdo(i,ki+1).gt.0.)cdd(i,ki)= dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) - enddo -! cbeg=800. !po_cup(i,kbcon(i)) !850. -! cend=min(po_cup(i,ktop(i)),200.) -! cmid=.5*(cbeg+cend) !600. -! const_b=c1/((cmid*cmid-cbeg*cbeg)*(cbeg-cend)/(cend*cend-cbeg*cbeg)+cmid-cbeg) -! const_a=const_b*(cbeg-cend)/(cend*cend-cbeg*cbeg) -! const_c=-const_a*cbeg*cbeg-const_b*cbeg -! do k=kbcon(i)+1,ktop(i)-1 -! c1d(i,k)=const_a*po_cup(i,k)*po_cup(i,k)+const_b*po_cup(i,k)+const_c -! c1d(i,k)=max(0.,c1d(i,k)) -!! c1d(i,k)=c1 -! enddo -!! if(imid.eq.1)c1d(i,:)=0. -!! do k=1,jmin(i) -!! c1d(i,k)=0. -!! enddo -!! c1d(i,jmin(i)-2)=c1/40. -!! if(imid.eq.1)c1d(i,jmin(i)-2)=c1/20. -!! do k=jmin(i)-1,ktop(i) -!! dz=zo_cup(i,ktop(i))-zo_cup(i,jmin(i)) -!! c1d(i,k)=c1d(i,k-1)+c1*(zo_cup(i,k+1)-zo_cup(i,k))/dz -!! c1d(i,k)=max(0.,c1d(i,k)) -!! c1d(i,k)=min(.002,c1d(i,k)) -!! enddo -! -! -! downdraft moist static energy + moisture budget - do k=2,jmin(i)+1 - dd_massentru(i,k-1)=dd_massentro(i,k-1)+lambau(i)*dd_massdetro(i,k-1) - dd_massdetru(i,k-1)=dd_massdetro(i,k-1)+lambau(i)*dd_massdetro(i,k-1) - enddo - dbydo(i,jmin(i))=hcdo(i,jmin(i))-heso_cup(i,jmin(i)) - bud(i)=dbydo(i,jmin(i))*(zo_cup(i,jmin(i)+1)-zo_cup(i,jmin(i))) - ucd(i,jmin(i)+1)=.5*(uc(i,jmin(i)+1)+u_cup(i,jmin(i)+1)) - do ki=jmin(i) ,1,-1 - dzo=zo_cup(i,ki+1)-zo_cup(i,ki) - h_entr=.5*(heo(i,ki)+.5*(hco(i,ki)+hco(i,ki+1))) - ucd(i,ki)=(ucd(i,ki+1)*zdo(i,ki+1) & - -.5*dd_massdetru(i,ki)*ucd(i,ki+1)+ & - dd_massentru(i,ki)*us(i,ki) & - -pgcon*zdo(i,ki+1)*(us(i,ki+1)-us(i,ki))) / & - (zdo(i,ki+1)-.5*dd_massdetru(i,ki)+dd_massentru(i,ki)) - vcd(i,ki)=(vcd(i,ki+1)*zdo(i,ki+1) & - -.5*dd_massdetru(i,ki)*vcd(i,ki+1)+ & - dd_massentru(i,ki)*vs(i,ki) & - -pgcon*zdo(i,ki+1)*(vs(i,ki+1)-vs(i,ki))) / & - (zdo(i,ki+1)-.5*dd_massdetru(i,ki)+dd_massentru(i,ki)) - hcdo(i,ki)=(hcdo(i,ki+1)*zdo(i,ki+1) & - -.5*dd_massdetro(i,ki)*hcdo(i,ki+1)+ & - dd_massentro(i,ki)*h_entr) / & - (zdo(i,ki+1)-.5*dd_massdetro(i,ki)+dd_massentro(i,ki)) - dbydo(i,ki)=hcdo(i,ki)-heso_cup(i,ki) - bud(i)=bud(i)+dbydo(i,ki)*dzo - enddo - ! endif - - if(bud(i).gt.0)then - ierr(i)=7 - ierrc(i)='downdraft is not negatively buoyant ' - endif - enddo -! -!--- calculate moisture properties of downdraft -! - call cup_dd_moisture(ierrc,zdo,hcdo,heso_cup,qcdo,qeso_cup, & - pwdo,qo_cup,zo_cup,dd_massentro,dd_massdetro,jmin,ierr,gammao_cup, & - pwevo,bu,qrcdo,qo,heo,1, & - itf,ktf, & - its,ite, kts,kte) -! -!---meltglac------------------------------------------------- -!--- calculate moisture properties of updraft -! -! if(imid.eq.1)then -! call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & -! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & -! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & -! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & -! 1,itf,ktf, & -! its,ite, kts,kte) -! else -! call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & -! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & -! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & -! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & -! 1,itf,ktf, & -! its,ite, kts,kte) -! endif -!---meltglac------------------------------------------------- - do i=its,itf - if(ierr(i)/=0)cycle - do k=kts+1,ktop(i) - dp=100.*(po_cup(i,1)-po_cup(i,2)) - cupclw(i,k)=qrco(i,k) ! my mod - cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp - enddo - enddo -! -!--- calculate workfunctions for updrafts -! - call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & - kbcon,ktop,ierr, & - itf,ktf, & - its,ite, kts,kte) - call cup_up_aa0(aa1,zo,zuo,dbyo,gammao_cup,tn_cup, & - kbcon,ktop,ierr, & - itf,ktf, & - its,ite, kts,kte) - do i=its,itf - if(ierr(i)/=0)cycle - if(aa1(i).eq.0.)then - ierr(i)=17 - ierrc(i)="cloud work function zero" - endif - enddo -! -!--- diurnal cycle closure -! - !--- aa1 from boundary layer (bl) processes only - aa1_bl (:) = 0.0 - xf_dicycle (:) = 0.0 - tau_ecmwf (:) = 0. - !- way to calculate the fraction of cape consumed by shallow convection - iversion=1 ! ecmwf - !iversion=0 ! orig - ! - ! betchold et al 2008 time-scale of cape removal -! -! wmean is of no meaning over land.... -! still working on replacing it over water -! - do i=its,itf - if(ierr(i).eq.0)then - !- mean vertical velocity - wmean(i) = 3.0 ! m/s ! in the future change for wmean == integral( w dz) / cloud_depth - if(imid.eq.1)wmean(i) = 3.0 - !- time-scale cape removal from betchold et al. 2008 - tau_ecmwf(i)=( zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) ) / wmean(i) - tau_ecmwf(i)=max(tau_ecmwf(i),720.) - tau_ecmwf(i)= tau_ecmwf(i) * (1.0061 + 1.23e-2 * (dx(i)/1000.))! dx(i) must be in meters - endif - enddo - tau_bl(:) = 0. - ! - if(dicycle == 1) then - do i=its,itf - - if(ierr(i).eq.0)then - if(xland1(i) == 0 ) then - !- over water - umean= 2.0+sqrt(0.5*(us(i,1)**2+vs(i,1)**2+us(i,kbcon(i))**2+vs(i,kbcon(i))**2)) - tau_bl(i) = (zo_cup(i,kbcon(i))- z1(i)) /umean - else - !- over land - tau_bl(i) =( zo_cup(i,ktopdby(i))- zo_cup(i,kbcon(i)) ) / wmean(i) - tau_bl(i)=max(tau_bl(i),1500.) - endif - - endif - enddo - - if(iversion == 1) then - !-- version ecmwf - t_star=1. - - !-- calculate pcape from bl forcing only - call cup_up_aa1bl(aa1_bl,t,tn,q,qo,dtime, & - zo_cup,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & - kbcon,ktop,ierr, & - itf,ktf,its,ite, kts,kte) - - do i=its,itf - - if(ierr(i).eq.0)then - - !- only for convection rooting in the pbl - !if(zo_cup(i,kbcon(i))-z1(i) > zo(i,kpbl(i)+1)) then - ! aa1_bl(i) = 0.0 - !else - !- multiply aa1_bl the " time-scale" - tau_bl - ! aa1_bl(i) = max(0.,aa1_bl(i)/t_star* tau_bl(i)) - aa1_bl(i) = ( aa1_bl(i)/t_star)* tau_bl(i) - !endif - endif - enddo - - else - - !- version for real cloud-work function - - !-get the profiles modified only by bl tendencies - do i=its,itf - tn_bl(i,:)=0.;qo_bl(i,:)=0. - if ( ierr(i) == 0 )then - !below kbcon -> modify profiles - tn_bl(i,1:kbcon(i)) = tn(i,1:kbcon(i)) - qo_bl(i,1:kbcon(i)) = qo(i,1:kbcon(i)) - !above kbcon -> keep environment profiles - tn_bl(i,kbcon(i)+1:ktf) = t(i,kbcon(i)+1:ktf) - qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf) - endif - enddo - !--- calculate moist static energy, heights, qes, ... only by bl tendencies - call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1, & - psur,ierr,tcrit,-1, & - itf,ktf, its,ite, kts,kte) - !--- environmental values on cloud levels only by bl tendencies - call cup_env_clev(tn_bl,qeso_bl,qo_bl,heo_bl,heso_bl,zo,po,qeso_cup_bl,qo_cup_bl, & - heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur, & - ierr,z1, & - itf,ktf,its,ite, kts,kte) - do i=its,itf - if(ierr(i).eq.0)then - hkbo_bl(i)=heo_cup_bl(i,k22(i)) - endif ! ierr - enddo - do k=kts,ktf - do i=its,itf - hco_bl (i,k)=0. - dbyo_bl(i,k)=0. - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - do k=1,kbcon(i)-1 - hco_bl(i,k)=hkbo_bl(i) - enddo - k=kbcon(i) - hco_bl (i,k)=hkbo_bl(i) - dbyo_bl(i,k)=hkbo_bl(i) - heso_cup_bl(i,k) - endif - enddo -! -! - do i=its,itf - if(ierr(i).eq.0)then - do k=kbcon(i)+1,ktop(i) - hco_bl(i,k)=(hco_bl(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco_bl(i,k-1)+ & - up_massentro(i,k-1)*heo_bl(i,k-1)) / & - (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) - dbyo_bl(i,k)=hco_bl(i,k)-heso_cup_bl(i,k) - enddo - do k=ktop(i)+1,ktf - hco_bl (i,k)=heso_cup_bl(i,k) - dbyo_bl(i,k)=0.0 - enddo - endif - enddo - - !--- calculate workfunctions for updrafts - call cup_up_aa0(aa1_bl,zo,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & - kbcon,ktop,ierr, & - itf,ktf,its,ite, kts,kte) - - do i=its,itf - - if(ierr(i).eq.0)then - !- get the increment on aa0 due the bl processes - aa1_bl(i) = aa1_bl(i) - aa0(i) - !- only for convection rooting in the pbl - !if(zo_cup(i,kbcon(i))-z1(i) > 500.0) then !- instead 500 -> zo_cup(kpbl(i)) - ! aa1_bl(i) = 0.0 - !else - ! !- multiply aa1_bl the "normalized time-scale" - tau_bl/ model_timestep - aa1_bl(i) = aa1_bl(i)* tau_bl(i)/ dtime - !endif - print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) - endif - enddo - endif - endif ! version of implementation - - - axx(:)=aa1(:) - -! -!--- determine downdraft strength in terms of windshear -! - call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & - pwo,ccn,pwevo,edtmax,edtmin,edtc,psum,psumh, & - rho,aeroevap,itf,ktf, & - its,ite, kts,kte) - do i=its,itf - if(ierr(i)/=0)cycle - edto(i)=edtc(i,1) - enddo - !--- get melting profile - call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & - ,pwo,edto,pwdo,melting & - ,itf,ktf,its,ite, kts,kte, cumulus ) - do k=kts,ktf - do i=its,itf - dellat_ens (i,k,1)=0. - dellaq_ens (i,k,1)=0. - dellaqc_ens(i,k,1)=0. - pwo_ens (i,k,1)=0. - enddo - enddo -! -!--- change per unit mass that a model cloud would modify the environment -! -!--- 1. in bottom layer -! - do k=kts,kte - do i=its,itf - dellu (i,k)=0. - dellv (i,k)=0. - dellah (i,k)=0. - dellat (i,k)=0. - dellaq (i,k)=0. - dellaqc(i,k)=0. - enddo - enddo -! -!---------------------------------------------- cloud level ktop -! -!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1 -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! -!---------------------------------------------- cloud level k+2 -! -!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1 -! -!---------------------------------------------- cloud level k+1 -! -!- - - - - - - - - - - - - - - - - - - - - - - - model level k -! -!---------------------------------------------- cloud level k -! -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! -!---------------------------------------------- cloud level 3 -! -!- - - - - - - - - - - - - - - - - - - - - - - - model level 2 -! -!---------------------------------------------- cloud level 2 -! -!- - - - - - - - - - - - - - - - - - - - - - - - model level 1 - - do i=its,itf - if(ierr(i)/=0)cycle - dp=100.*(po_cup(i,1)-po_cup(i,2)) - dellu(i,1)=pgcd*(edto(i)*zdo(i,2)*ucd(i,2) & - -edto(i)*zdo(i,2)*u_cup(i,2))*g/dp & - -zuo(i,2)*(uc (i,2)-u_cup(i,2)) *g/dp - dellv(i,1)=pgcd*(edto(i)*zdo(i,2)*vcd(i,2) & - -edto(i)*zdo(i,2)*v_cup(i,2))*g/dp & - -zuo(i,2)*(vc (i,2)-v_cup(i,2)) *g/dp - - do k=kts+1,ktop(i) - ! these three are only used at or near mass detrainment and/or entrainment levels - pgc=pgcon - entupk=0. - if(k == k22(i)-1) entupk=zuo(i,k+1) - detupk=0. - entdoj=0. - ! detrainment and entrainment for fowndrafts - detdo=edto(i)*dd_massdetro(i,k) - entdo=edto(i)*dd_massentro(i,k) - ! entrainment/detrainment for updraft - entup=up_massentro(i,k) - detup=up_massdetro(i,k) - ! subsidence by downdrafts only - subin=-zdo(i,k+1)*edto(i) - subdown=-zdo(i,k)*edto(i) - ! special levels - if(k.eq.ktop(i))then - detupk=zuo(i,ktop(i)) - subin=0. - subdown=0. - detdo=0. - entdo=0. - entup=0. - detup=0. - endif - totmas=subin-subdown+detup-entup-entdo+ & - detdo-entupk-entdoj+detupk+zuo(i,k+1)-zuo(i,k) - if(abs(totmas).gt.1.e-6)then - write(0,123)'totmas=',k22(i),kbcon(i),k,entup,detup,edto(i),zdo(i,k+1),dd_massdetro(i,k),dd_massentro(i,k) -123 format(a7,1x,3i3,2e12.4,1(1x,f5.2),3e12.4) - endif - dp=100.*(po_cup(i,k)-po_cup(i,k+1)) - pgc=pgcon - if(k.ge.ktop(i))pgc=0. - - dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) - & - zuo(i,k )*(uc (i,k )-u_cup(i,k ) ) )*g/dp & - +(zdo(i,k+1)*(ucd(i,k+1)-u_cup(i,k+1) ) - & - zdo(i,k )*(ucd(i,k )-u_cup(i,k ) ) )*g/dp*edto(i)*pgcd - dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) - & - zuo(i,k )*(vc (i,k )-v_cup(i,k ) ) )*g/dp & - +(zdo(i,k+1)*(vcd(i,k+1)-v_cup(i,k+1) ) - & - zdo(i,k )*(vcd(i,k )-v_cup(i,k ) ) )*g/dp*edto(i)*pgcd - - enddo ! k - - enddo - - - do i=its,itf - !trash = 0.0 - !trash2 = 0.0 - if(ierr(i).eq.0)then - - dp=100.*(po_cup(i,1)-po_cup(i,2)) - - dellah(i,1)=(edto(i)*zdo(i,2)*hcdo(i,2) & - -edto(i)*zdo(i,2)*heo_cup(i,2))*g/dp & - -zuo(i,2)*(hco(i,2)-heo_cup(i,2))*g/dp - - dellaq (i,1)=(edto(i)*zdo(i,2)*qcdo(i,2) & - -edto(i)*zdo(i,2)*qo_cup(i,2))*g/dp & - -zuo(i,2)*(qco(i,2)-qo_cup(i,2))*g/dp - - g_rain= 0.5*(pwo (i,1)+pwo (i,2))*g/dp - e_dn = -0.5*(pwdo(i,1)+pwdo(i,2))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 - dellaq(i,1) = dellaq(i,1)+ e_dn-g_rain - - !--- conservation check - !- water mass balance - !trash = trash + (dellaq(i,1)+dellaqc(i,1)+g_rain-e_dn)*dp/g - !- h budget - !trash2 = trash2+ (dellah(i,1))*dp/g - - - do k=kts+1,ktop(i) - dp=100.*(po_cup(i,k)-po_cup(i,k+1)) - ! these three are only used at or near mass detrainment and/or entrainment levels - - dellah(i,k) =-(zuo(i,k+1)*(hco (i,k+1)-heo_cup(i,k+1) ) - & - zuo(i,k )*(hco (i,k )-heo_cup(i,k ) ) )*g/dp & - +(zdo(i,k+1)*(hcdo(i,k+1)-heo_cup(i,k+1) ) - & - zdo(i,k )*(hcdo(i,k )-heo_cup(i,k ) ) )*g/dp*edto(i) - -!---meltglac------------------------------------------------- - - dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))*0.5*(qrco(i,k+1)+qrco(i,k)) & - - melting(i,k))*g/dp - -!---meltglac------------------------------------------------- - - !- check h conservation - ! trash2 = trash2+ (dellah(i,k))*dp/g - - - !-- take out cloud liquid water for detrainment - detup=up_massdetro(i,k) - dz=zo_cup(i,k)-zo_cup(i,k-1) -!! if(k.lt.ktop(i) .and. k.ge.jmin(i)) then -!! if(k.lt.ktop(i) .and. c1d(i,k).gt.0) then - if(k.lt.ktop(i)) then - dellaqc(i,k) = zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g - else - dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp - endif -!! if(imid.eq.1) dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp -! if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp -! !--- - g_rain= 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp - e_dn = -0.5*(pwdo(i,k)+pwdo(i,k+1))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 - !-- condensation source term = detrained + flux divergence of - !-- cloud liquid water (qrco) + converted to rain - - c_up = dellaqc(i,k)+(zuo(i,k+1)* qrco(i,k+1) - & - zuo(i,k )* qrco(i,k ) )*g/dp + g_rain -! c_up = dellaqc(i,k)+ g_rain - !-- water vapor budget - !-- = flux divergence z*(q_c - q_env)_up_and_down & - !-- - condensation term + evaporation - dellaq(i,k) =-(zuo(i,k+1)*(qco (i,k+1)-qo_cup(i,k+1) ) - & - zuo(i,k )*(qco (i,k )-qo_cup(i,k ) ) )*g/dp & - +(zdo(i,k+1)*(qcdo(i,k+1)-qo_cup(i,k+1) ) - & - zdo(i,k )*(qcdo(i,k )-qo_cup(i,k ) ) )*g/dp*edto(i) & - - c_up + e_dn - !- check water conservation liq+condensed (including rainfall) - ! trash= trash+ (dellaq(i,k)+dellaqc(i,k)+ g_rain-e_dn)*dp/g - - enddo ! k - endif - - enddo -444 format(1x,i2,1x,7e12.4) !,1x,f7.2,2x,e13.5) -! -!--- using dellas, calculate changed environmental profiles -! - mbdt=.1 - do i=its,itf - xaa0_ens(i,1)=0. - enddo - - do i=its,itf - if(ierr(i).eq.0)then - do k=kts,ktf - xhe(i,k)=dellah(i,k)*mbdt+heo(i,k) -! xq(i,k)=max(1.e-16,(dellaqc(i,k)+dellaq(i,k))*mbdt+qo(i,k)) - xq(i,k)=max(1.e-16,dellaq(i,k)*mbdt+qo(i,k)) - dellat(i,k)=(1./cp)*(dellah(i,k)-xlv*dellaq(i,k)) -! xt(i,k)= (dellat(i,k)-xlv/cp*dellaqc(i,k))*mbdt+tn(i,k) - xt(i,k)= dellat(i,k)*mbdt+tn(i,k) - xt(i,k)=max(190.,xt(i,k)) - enddo - endif - enddo - do i=its,itf - if(ierr(i).eq.0)then - xhe(i,ktf)=heo(i,ktf) - xq(i,ktf)=qo(i,ktf) - xt(i,ktf)=tn(i,ktf) - endif - enddo -! -!--- calculate moist static energy, heights, qes -! - call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, & - psur,ierr,tcrit,-1, & - itf,ktf, & - its,ite, kts,kte) -! -!--- environmental values on cloud levels -! - call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, & - xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur, & - ierr,z1, & - itf,ktf, & - its,ite, kts,kte) -! -! -!**************************** static control -! -!--- moist static energy inside cloud -! - do k=kts,ktf - do i=its,itf - xhc(i,k)=0. - xdby(i,k)=0. - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - x_add = xlv*zqexec(i)+cp*ztexec(i) - call get_cloud_bc(kte,xhe_cup (i,1:kte),xhkb (i),k22(i),x_add) - do k=1,start_level(i)-1 - xhc(i,k)=xhe_cup(i,k) - enddo - k=start_level(i) - xhc(i,k)=xhkb(i) - endif !ierr - enddo -! -! - do i=its,itf - if(ierr(i).eq.0)then - do k=start_level(i) +1,ktop(i) - xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1) + & - up_massentro(i,k-1)*xhe(i,k-1)) / & - (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) - - -!---meltglac------------------------------------------------- - ! - !- include glaciation effects on xhc - ! ------ ice content -------- - xhc (i,k)= xhc (i,k)+ xlf*(1.-p_liq_ice(i,k))*qrco(i,k) -!---meltglac------------------------------------------------- - - xdby(i,k)=xhc(i,k)-xhes_cup(i,k) - enddo - do k=ktop(i)+1,ktf - xhc (i,k)=xhes_cup(i,k) - xdby(i,k)=0. - enddo - endif - enddo - -! -!--- workfunctions for updraft -! - call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & - kbcon,ktop,ierr, & - itf,ktf, & - its,ite, kts,kte) - do i=its,itf - if(ierr(i).eq.0)then - xaa0_ens(i,1)=xaa0(i) - do k=kts,ktop(i) - do nens3=1,maxens3 - if(nens3.eq.7)then -!--- b=0 - pr_ens(i,nens3)=pr_ens(i,nens3) & - +pwo(i,k)+edto(i)*pwdo(i,k) -!--- b=beta - else if(nens3.eq.8)then - pr_ens(i,nens3)=pr_ens(i,nens3)+ & - pwo(i,k)+edto(i)*pwdo(i,k) -!--- b=beta/2 - else if(nens3.eq.9)then - pr_ens(i,nens3)=pr_ens(i,nens3) & - + pwo(i,k)+edto(i)*pwdo(i,k) - else - pr_ens(i,nens3)=pr_ens(i,nens3)+ & - pwo(i,k) +edto(i)*pwdo(i,k) - endif - enddo - enddo - if(pr_ens(i,7).lt.1.e-6)then - ierr(i)=18 - ierrc(i)="total normalized condensate too small" - do nens3=1,maxens3 - pr_ens(i,nens3)=0. - enddo - endif - do nens3=1,maxens3 - if(pr_ens(i,nens3).lt.1.e-5)then - pr_ens(i,nens3)=0. - endif - enddo - endif - enddo - 200 continue -! -!--- large scale forcing -! -! -!------- check wether aa0 should have been zero, assuming this -! ensemble is chosen -! -! - do i=its,itf - ierr2(i)=ierr(i) - ierr3(i)=ierr(i) - k22x(i)=k22(i) - enddo - call cup_maximi(heo_cup,2,kbmax,k22x,ierr, & - itf,ktf, & - its,ite, kts,kte) - iloop=2 - call cup_kbcon(ierrc,cap_max_increment,iloop,k22x,kbconx,heo_cup, & - heso_cup,hkbo,ierr2,kbmax,po_cup,cap_max, & - ztexec,zqexec, & - 0,itf,ktf, & - its,ite, kts,kte, & - z_cup,entr_rate,heo,imid) - iloop=3 - call cup_kbcon(ierrc,cap_max_increment,iloop,k22x,kbconx,heo_cup, & - heso_cup,hkbo,ierr3,kbmax,po_cup,cap_max, & - ztexec,zqexec, & - 0,itf,ktf, & - its,ite, kts,kte, & - z_cup,entr_rate,heo,imid) -! -!--- calculate cloud base mass flux -! - - do i = its,itf - mconv(i) = 0 - if(ierr(i)/=0)cycle - do k=1,ktop(i) - dq=(qo_cup(i,k+1)-qo_cup(i,k)) - mconv(i)=mconv(i)+omeg(i,k)*dq/g - enddo - enddo - call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt,dtime, & - ierr,ierr2,ierr3,xf_ens,axx,forcing, & - maxens3,mconv,rand_clos, & - po_cup,ktop,omeg,zdo,zdm,k22,zuo,pr_ens,edto,edtm,kbcon, & - ichoice, & - imid,ipr,itf,ktf, & - its,ite, kts,kte, & - dicycle,tau_ecmwf,aa1_bl,xf_dicycle) -! - do k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then - dellat_ens (i,k,1)=dellat(i,k) - dellaq_ens (i,k,1)=dellaq(i,k) - dellaqc_ens(i,k,1)=dellaqc(i,k) - pwo_ens (i,k,1)=pwo(i,k) +edto(i)*pwdo(i,k) - else - dellat_ens (i,k,1)=0. - dellaq_ens (i,k,1)=0. - dellaqc_ens(i,k,1)=0. - pwo_ens (i,k,1)=0. - endif - enddo - enddo - 250 continue -! -!--- feedback -! - if(imid.eq.1 .and. ichoice .le.2)then - do i=its,itf - !-boundary layer qe - xff_mid(i,1)=0. - xff_mid(i,2)=0. - if(ierr(i).eq.0)then - blqe=0. - trash=0. - if(k22(i).lt.kpbl(i)+1)then - do k=1,kpbl(i) - blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g - enddo - trash=max((hco(i,kbcon(i))-heo_cup(i,kbcon(i))),1.e1) - xff_mid(i,1)=max(0.,blqe/trash) - xff_mid(i,1)=min(0.1,xff_mid(i,1)) - endif - xff_mid(i,2)=min(0.1,.03*zws(i)) - endif - enddo - endif - call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, & - dellaqc_ens,outt, & - outq,outqc,zuo,pre,pwo_ens,xmb,ktop, & - edto,pwdo,'deep',ierr2,ierr3, & - po_cup,pr_ens,maxens3, & - sig,closure_n,xland1,xmbm_in,xmbs_in, & - ichoice,imid,ipr,itf,ktf, & - its,ite, kts,kte, & - dicycle,xf_dicycle ) - k=1 - do i=its,itf - if(ierr(i).eq.0 .and.pre(i).gt.0.) then - pre(i)=max(pre(i),0.) - xmb_out(i)=xmb(i) - outu(i,1)=dellu(i,1)*xmb(i) - outv(i,1)=dellv(i,1)*xmb(i) - do k=kts+1,ktop(i) - outu(i,k)=.25*(dellu(i,k-1)+2.*dellu(i,k)+dellu(i,k+1))*xmb(i) - outv(i,k)=.25*(dellv(i,k-1)+2.*dellv(i,k)+dellv(i,k+1))*xmb(i) - enddo - elseif(ierr(i).ne.0 .or. pre(i).eq.0.)then - ktop(i)=0 - do k=kts,kte - outt(i,k)=0. - outq(i,k)=0. - outqc(i,k)=0. - outu(i,k)=0. - outv(i,k)=0. - enddo - endif - enddo -! rain evaporation as in sas -! - if(irainevap.eq.1)then - do i = its,itf - rntot(i) = 0. - delqev(i) = 0. - delq2(i) = 0. - rn(i) = 0. - rntot(i) = 0. - rain=0. - if(ierr(i).eq.0)then - do k = ktop(i), 1, -1 - rain = pwo(i,k) + edto(i) * pwdo(i,k) - rntot(i) = rntot(i) + rain * xmb(i)* .001 * dtime - enddo - endif - enddo - do i = its,itf - qevap(i) = 0. - flg(i) = .true. - if(ierr(i).eq.0)then - evef = edt(i) * evfact - if(xland(i).gt.0.5 .and. xland(i).lt.1.5) evef=edt(i) * evfactl - do k = ktop(i), 1, -1 - rain = pwo(i,k) + edto(i) * pwdo(i,k) - rn(i) = rn(i) + rain * xmb(i) * .001 * dtime - !if(po(i,k).gt.700.)then - if(flg(i))then - q1=qo(i,k)+(outq(i,k))*dtime - t1=tn(i,k)+(outt(i,k))*dtime - qcond(i) = evef * (q1 - qeso(i,k)) & - & / (1. + el2orc * qeso(i,k) / t1**2) - dp = -100.*(p_cup(i,k+1)-p_cup(i,k)) - if(rn(i).gt.0. .and. qcond(i).lt.0.) then - qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dtime*rn(i)))) - qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) - delq2(i) = delqev(i) + .001 * qevap(i) * dp / g - endif - if(rn(i).gt.0..and.qcond(i).lt.0..and. & - & delq2(i).gt.rntot(i)) then - qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp - flg(i) = .false. - endif - if(rn(i).gt.0..and.qevap(i).gt.0.) then - outq(i,k) = outq(i,k) + qevap(i)/dtime - outt(i,k) = outt(i,k) - elocp * qevap(i)/dtime - rn(i) = max(0.,rn(i) - .001 * qevap(i) * dp / g) - pre(i) = pre(i) - qevap(i) * dp /g/dtime - pre(i)=max(pre(i),0.) - delqev(i) = delqev(i) + .001*dp*qevap(i)/g - endif - !endif ! 700mb - endif - enddo -! pre(i)=1000.*rn(i)/dtime - endif - enddo - endif -! -! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) -! - do i=its,itf - if(ierr(i).eq.0) then - dts=0. - fpi=0. - do k=kts,ktop(i) - dp=(po_cup(i,k)-po_cup(i,k+1))*100. -!total ke dissiptaion estimate - dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g -! fpi needed for calcualtion of conversion to pot. energyintegrated - fpi = fpi +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp - enddo - if(fpi.gt.0.)then - do k=kts,ktop(i) - fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi - outt(i,k)=outt(i,k)+fp*dts*g/cp - enddo - endif - endif - enddo - - -! -!---------------------------done------------------------------ -! - - end subroutine cu_gf_deep_run - - - subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & - pw,ccn,pwev,edtmax,edtmin,edtc,psum2,psumh, & - rho,aeroevap,itf,ktf, & - its,ite, kts,kte ) - - implicit none - - integer & - ,intent (in ) :: & - aeroevap,itf,ktf, & - its,ite, kts,kte - ! - ! ierr error value, maybe modified in this routine - ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - rho,us,vs,z,p,pw - real(kind=kind_phys), dimension (its:ite,1) & - ,intent (out ) :: & - edtc - real(kind=kind_phys), dimension (its:ite) & - ,intent (out ) :: & - edt - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - pwav,pwev,ccn,psum2,psumh,edtmax,edtmin - integer, dimension (its:ite) & - ,intent (in ) :: & - ktop,kbcon - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer i,k,kk - real(kind=kind_phys) einc,pef,pefb,prezk,zkbc - real(kind=kind_phys), dimension (its:ite) :: & - vshear,sdp,vws - real(kind=kind_phys) :: prop_c,pefc,aeroadd,alpha3,beta3 - prop_c=8. !10.386 - alpha3 = 1.9 - beta3 = -1.13 - pefc=0. - -! -!--- determine downdraft strength in terms of windshear -! -! */ calculate an average wind shear over the depth of the cloud -! - do i=its,itf - edt(i)=0. - vws(i)=0. - sdp(i)=0. - vshear(i)=0. - enddo - do i=its,itf - edtc(i,1)=0. - enddo - do kk = kts,ktf-1 - do 62 i=its,itf - if(ierr(i).ne.0)go to 62 - if (kk .le. min0(ktop(i),ktf) .and. kk .ge. kbcon(i)) then - vws(i) = vws(i)+ & - (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk))) & - + abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) * & - (p(i,kk) - p(i,kk+1)) - sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1) - endif - if (kk .eq. ktf-1)vshear(i) = 1.e3 * vws(i) / sdp(i) - 62 continue - end do - do i=its,itf - if(ierr(i).eq.0)then - pef=(1.591-.639*vshear(i)+.0953*(vshear(i)**2) & - -.00496*(vshear(i)**3)) - if(pef.gt.0.9)pef=0.9 - if(pef.lt.0.1)pef=0.1 -! -!--- cloud base precip efficiency -! - zkbc=z(i,kbcon(i))*3.281e-3 - prezk=.02 - if(zkbc.gt.3.)then - prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc & - *(- 1.2569798e-2+zkbc*(4.2772e-4-zkbc*5.44e-6)))) - endif - if(zkbc.gt.25)then - prezk=2.4 - endif - pefb=1./(1.+prezk) - if(pefb.gt.0.9)pefb=0.9 - if(pefb.lt.0.1)pefb=0.1 - edt(i)=1.-.5*(pefb+pef) - if(aeroevap.gt.1)then - aeroadd=(ccnclean**beta3)*((psumh(i))**(alpha3-1)) !*1.e6 -! prop_c=.9/aeroadd - prop_c=.5*(pefb+pef)/aeroadd - aeroadd=(ccn(i)**beta3)*((psum2(i))**(alpha3-1)) !*1.e6 - aeroadd=prop_c*aeroadd - pefc=aeroadd - if(pefc.gt.0.9)pefc=0.9 - if(pefc.lt.0.1)pefc=0.1 - edt(i)=1.-pefc - if(aeroevap.eq.2)edt(i)=1.-.25*(pefb+pef+2.*pefc) - endif - - -!--- edt here is 1-precipeff! - einc=.2*edt(i) - edtc(i,1)=edt(i)-einc - endif - enddo - do i=its,itf - if(ierr(i).eq.0)then - edtc(i,1)=-edtc(i,1)*pwav(i)/pwev(i) - if(edtc(i,1).gt.edtmax(i))edtc(i,1)=edtmax(i) - if(edtc(i,1).lt.edtmin(i))edtc(i,1)=edtmin(i) - endif - enddo - - end subroutine cup_dd_edt - - - subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & - pwd,q_cup,z_cup,dd_massentr,dd_massdetr,jmin,ierr, & - gamma_cup,pwev,bu,qrcd, & - q,he,iloop, & - itf,ktf, & - its,ite, kts,kte ) - - implicit none - - integer & - ,intent (in ) :: & - itf,ktf, & - its,ite, kts,kte - ! cdd= detrainment function - ! q = environmental q on model levels - ! q_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! hes_cup = saturation h on model cloud levels - ! hcd = h in model cloud - ! bu = buoancy term - ! zd = normalized downdraft mass flux - ! gamma_cup = gamma on model cloud levels - ! mentr_rate = entrainment rate - ! qcd = cloud q (including liquid water) after entrainment - ! qrch = saturation q in cloud - ! pwd = evaporate at that level - ! pwev = total normalized integrated evaoprate (i2) - ! entr= entrainment rate - ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - zd,hes_cup,hcd,qes_cup,q_cup,z_cup, & - dd_massentr,dd_massdetr,gamma_cup,q,he - integer & - ,intent (in ) :: & - iloop - integer, dimension (its:ite) & - ,intent (in ) :: & - jmin - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - real(kind=kind_phys), dimension (its:ite,kts:kte)& - ,intent (out ) :: & - qcd,qrcd,pwd - real(kind=kind_phys), dimension (its:ite)& - ,intent (out ) :: & - pwev,bu - character*50 :: ierrc(its:ite) -! -! local variables in this routine -! - - integer :: & - i,k,ki - real(kind=kind_phys) :: & - denom,dh,dz,dqeva - - do i=its,itf - bu(i)=0. - pwev(i)=0. - enddo - do k=kts,ktf - do i=its,itf - qcd(i,k)=0. - qrcd(i,k)=0. - pwd(i,k)=0. - enddo - enddo -! -! -! - do 100 i=its,itf - if(ierr(i).eq.0)then - k=jmin(i) - dz=z_cup(i,k+1)-z_cup(i,k) - qcd(i,k)=q_cup(i,k) - dh=hcd(i,k)-hes_cup(i,k) - if(dh.lt.0)then - qrcd(i,k)=(qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & - /(1.+gamma_cup(i,k)))*dh) - else - qrcd(i,k)=qes_cup(i,k) - endif - pwd(i,jmin(i))=zd(i,jmin(i))*min(0.,qcd(i,k)-qrcd(i,k)) - qcd(i,k)=qrcd(i,k) - pwev(i)=pwev(i)+pwd(i,jmin(i)) ! *dz -! - bu(i)=dz*dh - do ki=jmin(i)-1,1,-1 - dz=z_cup(i,ki+1)-z_cup(i,ki) -! qcd(i,ki)=(qcd(i,ki+1)*(1.-.5*cdd(i,ki+1)*dz) & -! +entr*dz*q(i,ki) & -! )/(1.+entr*dz-.5*cdd(i,ki+1)*dz) -! dz=qcd(i,ki) -!print*,"i=",i," k=",ki," qcd(i,ki+1)=",qcd(i,ki+1) -!print*,"zd=",zd(i,ki+1)," dd_ma=",dd_massdetr(i,ki)," q=",q(i,ki) -!joe-added check for non-zero denominator: - denom=zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki) - if(denom.lt.1.e-16)then - ierr(i)=51 - exit - endif - qcd(i,ki)=(qcd(i,ki+1)*zd(i,ki+1) & - -.5*dd_massdetr(i,ki)*qcd(i,ki+1)+ & - dd_massentr(i,ki)*q(i,ki)) / & - (zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki)) -! -!--- to be negatively buoyant, hcd should be smaller than hes! -!--- ideally, dh should be negative till dd hits ground, but that is not always -!--- the case -! - dh=hcd(i,ki)-hes_cup(i,ki) - bu(i)=bu(i)+dz*dh - qrcd(i,ki)=qes_cup(i,ki)+(1./xlv)*(gamma_cup(i,ki) & - /(1.+gamma_cup(i,ki)))*dh - dqeva=qcd(i,ki)-qrcd(i,ki) - if(dqeva.gt.0.)then - dqeva=0. - qrcd(i,ki)=qcd(i,ki) - endif - pwd(i,ki)=zd(i,ki)*dqeva - qcd(i,ki)=qrcd(i,ki) - pwev(i)=pwev(i)+pwd(i,ki) ! *dz -! if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then -! print *,'in cup_dd_moi ', hcd(i,ki),hes_cup(i,ki),dh,dqeva -! endif - enddo -! -!--- end loop over i - if( (pwev(i).eq.0.) .and. (iloop.eq.1))then -! print *,'problem with buoy in cup_dd_moisture',i - ierr(i)=7 - ierrc(i)="problem with buoy in cup_dd_moisture" - endif - if(bu(i).ge.0.and.iloop.eq.1)then -! print *,'problem with buoy in cup_dd_moisture',i - ierr(i)=7 - ierrc(i)="problem2 with buoy in cup_dd_moisture" - endif - endif -100 continue - - end subroutine cup_dd_moisture - - subroutine cup_env(z,qes,he,hes,t,q,p,z1, & - psur,ierr,tcrit,itest, & - itf,ktf, & - its,ite, kts,kte ) - - implicit none - - integer & - ,intent (in ) :: & - itf,ktf, & - its,ite, kts,kte - ! - ! ierr error value, maybe modified in this routine - ! q = environmental mixing ratio - ! qes = environmental saturation mixing ratio - ! t = environmental temp - ! tv = environmental virtual temp - ! p = environmental pressure - ! z = environmental heights - ! he = environmental moist static energy - ! hes = environmental saturation moist static energy - ! psur = surface pressure - ! z1 = terrain elevation - ! - ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - p,t,q - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (out ) :: & - he,hes,qes - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (inout) :: & - z - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - psur,z1 - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - integer & - ,intent (in ) :: & - itest -! -! local variables in this routine -! - - integer :: & - i,k -! real(kind=kind_phys), dimension (1:2) :: ae,be,ht - real(kind=kind_phys), dimension (its:ite,kts:kte) :: tv - real(kind=kind_phys) :: tcrit,e,tvbar -! real(kind=kind_phys), external :: satvap -! real(kind=kind_phys) :: satvap - - -! ht(1)=xlv/cp -! ht(2)=2.834e6/cp -! be(1)=.622*ht(1)/.286 -! ae(1)=be(1)/273.+alog(610.71) -! be(2)=.622*ht(2)/.286 -! ae(2)=be(2)/273.+alog(610.71) - do k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then -!csgb - iph is for phase, dependent on tcrit (water or ice) -! iph=1 -! if(t(i,k).le.tcrit)iph=2 -! print *, 'ae(iph),be(iph) = ',ae(iph),be(iph),ae(iph)-be(iph),t(i,k),i,k -! e=exp(ae(iph)-be(iph)/t(i,k)) -! print *, 'p, e = ', p(i,k), e -! qes(i,k)=.622*e/(100.*p(i,k)-e) - e=satvap(t(i,k)) - qes(i,k)=0.622*e/max(1.e-8,(p(i,k)-e)) - if(qes(i,k).le.1.e-16)qes(i,k)=1.e-16 - if(qes(i,k).lt.q(i,k))qes(i,k)=q(i,k) -! if(q(i,k).gt.qes(i,k))q(i,k)=qes(i,k) - tv(i,k)=t(i,k)+.608*q(i,k)*t(i,k) - endif - enddo - enddo -! -!--- z's are calculated with changed h's and q's and t's -!--- if itest=2 -! - if(itest.eq.1 .or. itest.eq.0)then - do i=its,itf - if(ierr(i).eq.0)then - z(i,1)=max(0.,z1(i))-(log(p(i,1))- & - log(psur(i)))*287.*tv(i,1)/9.81 - endif - enddo - -! --- calculate heights - do k=kts+1,ktf - do i=its,itf - if(ierr(i).eq.0)then - tvbar=.5*tv(i,k)+.5*tv(i,k-1) - z(i,k)=z(i,k-1)-(log(p(i,k))- & - log(p(i,k-1)))*287.*tvbar/9.81 - endif - enddo - enddo - else if(itest.eq.2)then - do k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then - z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81 - z(i,k)=max(1.e-3,z(i,k)) - endif - enddo - enddo - else if(itest.eq.-1)then - endif -! -!--- calculate moist static energy - he -! saturated moist static energy - hes -! - do k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then - if(itest.le.0)he(i,k)=9.81*z(i,k)+1004.*t(i,k)+2.5e06*q(i,k) - hes(i,k)=9.81*z(i,k)+1004.*t(i,k)+2.5e06*qes(i,k) - if(he(i,k).ge.hes(i,k))he(i,k)=hes(i,k) - endif - enddo - enddo - - end subroutine cup_env - - - subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & - he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & - ierr,z1, & - itf,ktf, & - its,ite, kts,kte ) - - implicit none - - integer & - ,intent (in ) :: & - itf,ktf, & - its,ite, kts,kte - ! - ! ierr error value, maybe modified in this routine - ! q = environmental mixing ratio - ! q_cup = environmental mixing ratio on cloud levels - ! qes = environmental saturation mixing ratio - ! qes_cup = environmental saturation mixing ratio on cloud levels - ! t = environmental temp - ! t_cup = environmental temp on cloud levels - ! p = environmental pressure - ! p_cup = environmental pressure on cloud levels - ! z = environmental heights - ! z_cup = environmental heights on cloud levels - ! he = environmental moist static energy - ! he_cup = environmental moist static energy on cloud levels - ! hes = environmental saturation moist static energy - ! hes_cup = environmental saturation moist static energy on cloud levels - ! gamma_cup = gamma on cloud levels - ! psur = surface pressure - ! z1 = terrain elevation - ! - ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - qes,q,he,hes,z,p,t - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (out ) :: & - qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - psur,z1 - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer :: & - i,k - - - do k=kts,ktf - do i=its,itf - qes_cup(i,k)=0. - q_cup(i,k)=0. - hes_cup(i,k)=0. - he_cup(i,k)=0. - z_cup(i,k)=0. - p_cup(i,k)=0. - t_cup(i,k)=0. - gamma_cup(i,k)=0. - enddo - enddo - do k=kts+1,ktf - do i=its,itf - if(ierr(i).eq.0)then - qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k)) - q_cup(i,k)=.5*(q(i,k-1)+q(i,k)) - hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k)) - he_cup(i,k)=.5*(he(i,k-1)+he(i,k)) - if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k) - z_cup(i,k)=.5*(z(i,k-1)+z(i,k)) - p_cup(i,k)=.5*(p(i,k-1)+p(i,k)) - t_cup(i,k)=.5*(t(i,k-1)+t(i,k)) - gamma_cup(i,k)=(xlv/cp)*(xlv/(r_v*t_cup(i,k) & - *t_cup(i,k)))*qes_cup(i,k) - endif - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - qes_cup(i,1)=qes(i,1) - q_cup(i,1)=q(i,1) -! hes_cup(i,1)=hes(i,1) -! he_cup(i,1)=he(i,1) - hes_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*qes(i,1) - he_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*q(i,1) - z_cup(i,1)=.5*(z(i,1)+z1(i)) - p_cup(i,1)=.5*(p(i,1)+psur(i)) - z_cup(i,1)=z1(i) - p_cup(i,1)=psur(i) - t_cup(i,1)=t(i,1) - gamma_cup(i,1)=xlv/cp*(xlv/(r_v*t_cup(i,1) & - *t_cup(i,1)))*qes_cup(i,1) - endif - enddo - - end subroutine cup_env_clev - - subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,& - xf_ens,axx,forcing,maxens3,mconv,rand_clos, & - p_cup,ktop,omeg,zd,zdm,k22,zu,pr_ens,edt,edtm,kbcon, & - ichoice, & - imid,ipr,itf,ktf, & - its,ite, kts,kte, & - dicycle,tau_ecmwf,aa1_bl,xf_dicycle ) - - implicit none - - integer & - ,intent (in ) :: & - imid,ipr,itf,ktf, & - its,ite, kts,kte - integer, intent (in ) :: & - maxens3 - ! - ! ierr error value, maybe modified in this routine - ! pr_ens = precipitation ensemble - ! xf_ens = mass flux ensembles - ! massfln = downdraft mass flux ensembles used in next timestep - ! omeg = omega from large scale model - ! mconv = moisture convergence from large scale model - ! zd = downdraft normalized mass flux - ! zu = updraft normalized mass flux - ! aa0 = cloud work function without forcing effects - ! aa1 = cloud work function with forcing effects - ! xaa0 = cloud work function with cloud effects (ensemble dependent) - ! edt = epsilon - ! dir = "storm motion" - ! mbdt = arbitrary numerical parameter - ! dtime = dt over which forcing is applied - ! iact_gr_old = flag to tell where convection was active - ! kbcon = lfc of parcel from k22 - ! k22 = updraft originating level - ! ichoice = flag if only want one closure (usually set to zero!) - ! - real(kind=kind_phys), dimension (its:ite,1:maxens3) & - ,intent (inout) :: & - pr_ens - real(kind=kind_phys), dimension (its:ite,1:maxens3) & - ,intent (inout ) :: & - xf_ens - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - zd,zu,p_cup,zdm - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - omeg - real(kind=kind_phys), dimension (its:ite,1) & - ,intent (in ) :: & - xaa0 - real(kind=kind_phys), dimension (its:ite,4) & - ,intent (in ) :: & - rand_clos - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - aa1,edt,edtm - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - mconv,axx - real(kind=kind_phys), dimension (its:ite) & - ,intent (inout) :: & - aa0,closure_n - real(kind=kind_phys) & - ,intent (in ) :: & - mbdt - real(kind=kind_phys) & - ,intent (in ) :: & - dtime - integer, dimension (its:ite) & - ,intent (inout ) :: & - k22,kbcon,ktop - integer, dimension (its:ite) & - ,intent (in ) :: & - xland - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr,ierr2,ierr3 - integer & - ,intent (in ) :: & - ichoice - integer, intent(in) :: dicycle - real(kind=kind_phys), intent(in) , dimension (its:ite) :: aa1_bl,tau_ecmwf - real(kind=kind_phys), intent(inout), dimension (its:ite) :: xf_dicycle - real(kind=kind_phys), intent(inout), dimension (its:ite,10) :: forcing - !- local var - real(kind=kind_phys) :: xff_dicycle -! -! local variables in this routine -! - - real(kind=kind_phys), dimension (1:maxens3) :: & - xff_ens3 - real(kind=kind_phys), dimension (1) :: & - xk - integer :: & - kk,i,k,n,ne -! integer, parameter :: mkxcrt=15 -! real(kind=kind_phys), dimension(1:mkxcrt) :: & -! pcrit,acrit,acritt - integer, dimension (its:ite) :: kloc - real(kind=kind_phys) :: & - a1,a_ave,xff0,xomg!,aclim1,aclim2,aclim3,aclim4 - - real(kind=kind_phys), dimension (its:ite) :: ens_adj - - - -! - ens_adj(:)=1. - xff_dicycle = 0. - -!--- large scale forcing -! - do 100 i=its,itf - kloc(i)=1 - if(ierr(i).eq.0)then -! kloc(i)=maxloc(zu(i,:),1) - kloc(i)=kbcon(i) - ens_adj(i)=1. -!ss --- comment out adjustment over ocean -!ss if(ierr2(i).gt.0.and.ierr3(i).eq.0)ens_adj(i)=0.666 ! 2./3. -!ss if(ierr2(i).gt.0.and.ierr3(i).gt.0)ens_adj(i)=0.333 -! - a_ave=0. - a_ave=axx(i) - a_ave=max(0.,a_ave) - a_ave=min(a_ave,aa1(i)) - a_ave=max(0.,a_ave) - xff_ens3(:)=0. - xff0= (aa1(i)-aa0(i))/dtime - xff_ens3(1)=max(0.,(aa1(i)-aa0(i))/dtime) - xff_ens3(2)=max(0.,(aa1(i)-aa0(i))/dtime) - xff_ens3(3)=max(0.,(aa1(i)-aa0(i))/dtime) - xff_ens3(16)=max(0.,(aa1(i)-aa0(i))/dtime) - forcing(i,1)=xff_ens3(2) -! -!--- omeg is in bar/s, mconv done with omeg in pa/s -! more like brown (1979), or frank-cohen (199?) -! -! average aaround kbcon -! - xomg=0. - kk=0 - xff_ens3(4)=0. - xff_ens3(5)=0. - xff_ens3(6)=0. - do k=kbcon(i)-1,kbcon(i)+1 - if(zu(i,k).gt.0.)then - xomg=xomg-omeg(i,k)/9.81/max(0.3,(1.-(edt(i)*zd(i,k)-edtm(i)*zdm(i,k))/zu(i,k))) - kk=kk+1 - endif - enddo - if(kk.gt.0)xff_ens3(4)=xomg/float(kk) - -! -! max below kbcon -! xff_ens3(6)=-omeg(i,k22(i))/9.81 -! do k=k22(i),kbcon(i) -! xomg=-omeg(i,k)/9.81 -! if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg -! enddo -! -! if(zu(i,kbcon(i)) > 0)xff_ens3(6)=betajb*xff_ens3(6)/zu(i,kbcon(i)) - xff_ens3(4)=betajb*xff_ens3(4) - xff_ens3(5)=xff_ens3(4) - xff_ens3(6)=xff_ens3(4) - if(xff_ens3(4).lt.0.)xff_ens3(4)=0. - if(xff_ens3(5).lt.0.)xff_ens3(5)=0. - if(xff_ens3(6).lt.0.)xff_ens3(6)=0. - xff_ens3(14)=xff_ens3(4) - forcing(i,2)=xff_ens3(4) -! -!--- more like krishnamurti et al.; pick max and average values -! - xff_ens3(7)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) - xff_ens3(8)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) - xff_ens3(9)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) - xff_ens3(15)=mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) - forcing(i,3)=xff_ens3(8) -! -!--- more like fritsch chappel or kain fritsch (plus triggers) -! - xff_ens3(10)=aa1(i)/tau_ecmwf(i) - xff_ens3(11)=aa1(i)/tau_ecmwf(i) - xff_ens3(12)=aa1(i)/tau_ecmwf(i) - xff_ens3(13)=(aa1(i))/tau_ecmwf(i) !(60.*15.) !tau_ecmwf(i) -! forcing(i,4)=xff_ens3(10) - -!!- more like bechtold et al. (jas 2014) -!! if(dicycle == 1) xff_dicycle = max(0.,aa1_bl(i)/tau_ecmwf(i)) !(60.*30.) !tau_ecmwf(i) -!gtest - if(ichoice.eq.0)then - if(xff0.lt.0.)then - xff_ens3(1)=0. - xff_ens3(2)=0. - xff_ens3(3)=0. - xff_ens3(10)=0. - xff_ens3(11)=0. - xff_ens3(12)=0. - xff_ens3(13)= 0. - xff_ens3(16)= 0. -! closure_n(i)=12. -! hli 05/01/2018 closure_n(i)=12. -! xff_dicycle = 0. - endif !xff0 - endif ! ichoice - - xk(1)=(xaa0(i,1)-aa1(i))/mbdt - forcing(i,4)=aa0(i) - forcing(i,5)=aa1(i) - forcing(i,6)=xaa0(i,1) - forcing(i,7)=xk(1) - if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) & - xk(1)=-.01*mbdt - if(xk(1).gt.0.and.xk(1).lt.1.e-2) & - xk(1)=1.e-2 - ! enddo -! -!--- add up all ensembles -! -! -! over water, enfor!e small cap for some of the closures -! - if(xland(i).lt.0.1)then - if(ierr2(i).gt.0.or.ierr3(i).gt.0)then - xff_ens3(1) =ens_adj(i)*xff_ens3(1) - xff_ens3(2) =ens_adj(i)*xff_ens3(2) - xff_ens3(3) =ens_adj(i)*xff_ens3(3) - xff_ens3(4) =ens_adj(i)*xff_ens3(4) - xff_ens3(5) =ens_adj(i)*xff_ens3(5) - xff_ens3(6) =ens_adj(i)*xff_ens3(6) - xff_ens3(7) =ens_adj(i)*xff_ens3(7) - xff_ens3(8) =ens_adj(i)*xff_ens3(8) - xff_ens3(9) =ens_adj(i)*xff_ens3(9) - xff_ens3(10) =ens_adj(i)*xff_ens3(10) - xff_ens3(11) =ens_adj(i)*xff_ens3(11) - xff_ens3(12) =ens_adj(i)*xff_ens3(12) - xff_ens3(13) =ens_adj(i)*xff_ens3(13) - xff_ens3(14) =ens_adj(i)*xff_ens3(14) - xff_ens3(15) =ens_adj(i)*xff_ens3(15) - xff_ens3(16) =ens_adj(i)*xff_ens3(16) -!! !srf -!! xff_dicycle = ens_adj(i)*xff_dicycle -!! !srf end -! xff_ens3(7) =0. -! xff_ens3(8) =0. -! xff_ens3(9) =0. - endif ! ierr2 - endif ! xland -! -! end water treatment -! -! - -! -!--- special treatment for stability closures -! - if(xk(1).lt.0.)then - if(xff_ens3(1).gt.0)xf_ens(i,1)=max(0.,-xff_ens3(1)/xk(1)) - if(xff_ens3(2).gt.0)xf_ens(i,2)=max(0.,-xff_ens3(2)/xk(1)) - if(xff_ens3(3).gt.0)xf_ens(i,3)=max(0.,-xff_ens3(3)/xk(1)) - if(xff_ens3(16).gt.0)xf_ens(i,16)=max(0.,-xff_ens3(16)/xk(1)) - xf_ens(i,1)= xf_ens(i,1)+xf_ens(i,1)*rand_clos(i,1) - xf_ens(i,2)= xf_ens(i,2)+xf_ens(i,2)*rand_clos(i,1) - xf_ens(i,3)= xf_ens(i,3)+xf_ens(i,3)*rand_clos(i,1) - xf_ens(i,16)=xf_ens(i,16)+xf_ens(i,16)*rand_clos(i,1) - else - xff_ens3(1)= 0 - xff_ens3(2)= 0 - xff_ens3(3)= 0 - xff_ens3(16)=0 - endif -! -!--- if iresult.eq.1, following independent of xff0 -! - xf_ens(i,4)=max(0.,xff_ens3(4)) - xf_ens(i,5)=max(0.,xff_ens3(5)) - xf_ens(i,6)=max(0.,xff_ens3(6)) - xf_ens(i,14)=max(0.,xff_ens3(14)) - a1=max(1.e-5,pr_ens(i,7)) - xf_ens(i,7)=max(0.,xff_ens3(7)/a1) - a1=max(1.e-5,pr_ens(i,8)) - xf_ens(i,8)=max(0.,xff_ens3(8)/a1) -! forcing(i,7)=xf_ens(i,8) - a1=max(1.e-5,pr_ens(i,9)) - xf_ens(i,9)=max(0.,xff_ens3(9)/a1) - a1=max(1.e-3,pr_ens(i,15)) - xf_ens(i,15)=max(0.,xff_ens3(15)/a1) - xf_ens(i,4)=xf_ens(i,4)+xf_ens(i,4)*rand_clos(i,2) - xf_ens(i,5)=xf_ens(i,5)+xf_ens(i,5)*rand_clos(i,2) - xf_ens(i,6)=xf_ens(i,6)+xf_ens(i,6)*rand_clos(i,2) - xf_ens(i,14)=xf_ens(i,14)+xf_ens(i,14)*rand_clos(i,2) - xf_ens(i,7)=xf_ens(i,7)+xf_ens(i,7)*rand_clos(i,3) - xf_ens(i,8)=xf_ens(i,8)+xf_ens(i,8)*rand_clos(i,3) - xf_ens(i,9)=xf_ens(i,9)+xf_ens(i,9)*rand_clos(i,3) - xf_ens(i,15)=xf_ens(i,15)+xf_ens(i,15)*rand_clos(i,3) - if(xk(1).lt.0.)then - xf_ens(i,10)=max(0.,-xff_ens3(10)/xk(1)) - xf_ens(i,11)=max(0.,-xff_ens3(11)/xk(1)) - xf_ens(i,12)=max(0.,-xff_ens3(12)/xk(1)) - xf_ens(i,13)=max(0.,-xff_ens3(13)/xk(1)) - xf_ens(i,10)=xf_ens(i,10)+xf_ens(i,10)*rand_clos(i,4) - xf_ens(i,11)=xf_ens(i,11)+xf_ens(i,11)*rand_clos(i,4) - xf_ens(i,12)=xf_ens(i,12)+xf_ens(i,12)*rand_clos(i,4) - xf_ens(i,13)=xf_ens(i,13)+xf_ens(i,13)*rand_clos(i,4) - forcing(i,8)=xf_ens(i,11) - else - xf_ens(i,10)=0. - xf_ens(i,11)=0. - xf_ens(i,12)=0. - xf_ens(i,13)=0. - forcing(i,8)=0. - endif -!srf-begin -!! if(xk(1).lt.0.)then -!! xf_dicycle(i) = max(0.,-xff_dicycle /xk(1)) -!! forcing(i,9)=xf_dicycle(i) -!! else -!! xf_dicycle(i) = 0. -!! endif -!srf-end -!- -!- diurnal cycle mass flux -!- - if(dicycle == 1 )then - do i=its,itf - xf_dicycle(i) = 0. - if(ierr(i) /= 0)cycle - xk(1)=(xaa0(i,1)-aa1(i))/mbdt - if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) xk(1)=-.01*mbdt - if(xk(1).gt.0.and.xk(1).lt.1.e-2) xk(1)=1.e-2 - - xff_dicycle = (aa1(i)-aa1_bl(i))/tau_ecmwf(i) - if(xk(1).lt.0) xf_dicycle(i)= max(0.,-xff_dicycle/xk(1)) - xf_dicycle(i)= xf_ens(i,10)-xf_dicycle(i) - enddo - else - xf_dicycle(:) = 0. - endif -!--------- - if(ichoice.ge.1)then -! closure_n(i)=0. - xf_ens(i,1)=xf_ens(i,ichoice) - xf_ens(i,2)=xf_ens(i,ichoice) - xf_ens(i,3)=xf_ens(i,ichoice) - xf_ens(i,4)=xf_ens(i,ichoice) - xf_ens(i,5)=xf_ens(i,ichoice) - xf_ens(i,6)=xf_ens(i,ichoice) - xf_ens(i,7)=xf_ens(i,ichoice) - xf_ens(i,8)=xf_ens(i,ichoice) - xf_ens(i,9)=xf_ens(i,ichoice) - xf_ens(i,10)=xf_ens(i,ichoice) - xf_ens(i,11)=xf_ens(i,ichoice) - xf_ens(i,12)=xf_ens(i,ichoice) - xf_ens(i,13)=xf_ens(i,ichoice) - xf_ens(i,14)=xf_ens(i,ichoice) - xf_ens(i,15)=xf_ens(i,ichoice) - xf_ens(i,16)=xf_ens(i,ichoice) - endif - elseif(ierr(i).ne.20.and.ierr(i).ne.0)then - do n=1,maxens3 - xf_ens(i,n)=0. -!! -!! xf_dicycle(i) = 0. -!! - enddo - endif ! ierror - 100 continue - - end subroutine cup_forcing_ens_3d - - subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & - hkb,ierr,kbmax,p_cup,cap_max, & - ztexec,zqexec, & - jprnt,itf,ktf, & - its,ite, kts,kte, & - z_cup,entr_rate,heo,imid ) - - implicit none -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - jprnt,itf,ktf,imid, & - its,ite, kts,kte - ! - ! - ! - ! ierr error value, maybe modified in this routine - ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - he_cup,hes_cup,p_cup - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - entr_rate,ztexec,zqexec,cap_inc,cap_max - real(kind=kind_phys), dimension (its:ite) & - ,intent (inout ) :: & - hkb !,cap_max - integer, dimension (its:ite) & - ,intent (in ) :: & - kbmax - integer, dimension (its:ite) & - ,intent (inout) :: & - kbcon,k22,ierr - integer & - ,intent (in ) :: & - iloop_in - character*50 :: ierrc(its:ite) - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: z_cup,heo - integer, dimension (its:ite) :: iloop,start_level -! -! local variables in this routine -! - - integer :: & - i,k - real(kind=kind_phys) :: & - x_add,pbcdif,plus,hetest,dz - real(kind=kind_phys), dimension (its:ite,kts:kte) ::hcot -! -!--- determine the level of convective cloud base - kbcon -! - iloop(:)=iloop_in - do 27 i=its,itf - kbcon(i)=1 -! -! reset iloop for mid level convection - if(cap_max(i).gt.200 .and. imid.eq.1)iloop(i)=5 -! - if(ierr(i).ne.0)go to 27 - start_level(i)=k22(i) - kbcon(i)=k22(i)+1 - if(iloop(i).eq.5)kbcon(i)=k22(i) -! if(iloop_in.eq.5)start_level(i)=kbcon(i) - !== including entrainment for hetest - hcot(i,1:start_level(i)) = hkb(i) - do k=start_level(i)+1,kbmax(i)+3 - dz=z_cup(i,k)-z_cup(i,k-1) - hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1) & - + entr_rate(i)*dz*heo(i,k-1) )/ & - (1.+0.5*entr_rate(i)*dz) - enddo - !== - - go to 32 - 31 continue - kbcon(i)=kbcon(i)+1 - if(kbcon(i).gt.kbmax(i)+2)then - if(iloop(i).ne.4)then - ierr(i)=3 - ierrc(i)="could not find reasonable kbcon in cup_kbcon" - endif - go to 27 - endif - 32 continue - hetest=hcot(i,kbcon(i)) !hkb(i) ! he_cup(i,k22(i)) - if(hetest.lt.hes_cup(i,kbcon(i)))then - go to 31 - endif - -! cloud base pressure and max moist static energy pressure -! i.e., the depth (in mb) of the layer of negative buoyancy - if(kbcon(i)-k22(i).eq.1)go to 27 - if(iloop(i).eq.5 .and. (kbcon(i)-k22(i)).le.2)go to 27 - pbcdif=-p_cup(i,kbcon(i))+p_cup(i,k22(i)) - plus=max(25.,cap_max(i)-float(iloop(i)-1)*cap_inc(i)) - if(iloop(i).eq.4)plus=cap_max(i) -! -! for shallow convection, if cap_max is greater than 25, it is the pressure at pbltop - if(iloop(i).eq.5)plus=150. - if(iloop(i).eq.5.and.cap_max(i).gt.200)pbcdif=-p_cup(i,kbcon(i))+cap_max(i) - if(pbcdif.le.plus)then - go to 27 - elseif(pbcdif.gt.plus)then - k22(i)=k22(i)+1 - kbcon(i)=k22(i)+1 -!== since k22 has be changed, hkb has to be re-calculated - x_add = xlv*zqexec(i)+cp*ztexec(i) - call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) - - start_level(i)=k22(i) -! if(iloop_in.eq.5)start_level(i)=kbcon(i) - hcot(i,1:start_level(i)) = hkb(i) - do k=start_level(i)+1,kbmax(i)+3 - dz=z_cup(i,k)-z_cup(i,k-1) - - hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1) & - + entr_rate(i)*dz*heo(i,k-1) )/ & - (1.+0.5*entr_rate(i)*dz) - enddo - !== - - if(iloop(i).eq.5)kbcon(i)=k22(i) - if(kbcon(i).gt.kbmax(i)+2)then - if(iloop(i).ne.4)then - ierr(i)=3 - ierrc(i)="could not find reasonable kbcon in cup_kbcon" - endif - go to 27 - endif - go to 32 - endif - 27 continue - - end subroutine cup_kbcon - - - subroutine cup_maximi(array,ks,ke,maxx,ierr, & - itf,ktf, & - its,ite, kts,kte ) - - implicit none -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,ktf, & - its,ite, kts,kte - ! array input array - ! x output array with return values - ! kt output array of levels - ! ks,kend check-range - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - array - integer, dimension (its:ite) & - ,intent (in ) :: & - ierr,ke - integer & - ,intent (in ) :: & - ks - integer, dimension (its:ite) & - ,intent (out ) :: & - maxx - real(kind=kind_phys), dimension (its:ite) :: & - x - real(kind=kind_phys) :: & - xar - integer :: & - i,k - - do 200 i=its,itf - maxx(i)=ks - if(ierr(i).eq.0)then - x(i)=array(i,ks) -! - do 100 k=ks,ke(i) - xar=array(i,k) - if(xar.ge.x(i)) then - x(i)=xar - maxx(i)=k - endif - 100 continue - endif - 200 continue - - end subroutine cup_maximi - - - subroutine cup_minimi(array,ks,kend,kt,ierr, & - itf,ktf, & - its,ite, kts,kte ) - - implicit none -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,ktf, & - its,ite, kts,kte - ! array input array - ! x output array with return values - ! kt output array of levels - ! ks,kend check-range - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - array - integer, dimension (its:ite) & - ,intent (in ) :: & - ierr,ks,kend - integer, dimension (its:ite) & - ,intent (out ) :: & - kt - real(kind=kind_phys), dimension (its:ite) :: & - x - integer :: & - i,k,kstop - - do 200 i=its,itf - kt(i)=ks(i) - if(ierr(i).eq.0)then - x(i)=array(i,ks(i)) - kstop=max(ks(i)+1,kend(i)) -! - do 100 k=ks(i)+1,kstop - if(array(i,k).lt.x(i)) then - x(i)=array(i,k) - kt(i)=k - endif - 100 continue - endif - 200 continue - - end subroutine cup_minimi - - - subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & - kbcon,ktop,ierr, & - itf,ktf, & - its,ite, kts,kte ) - - implicit none -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,ktf, & - its,ite, kts,kte - ! aa0 cloud work function - ! gamma_cup = gamma on model cloud levels - ! t_cup = temperature (kelvin) on model cloud levels - ! dby = buoancy term - ! zu= normalized updraft mass flux - ! z = heights of model levels - ! ierr error value, maybe modified in this routine - ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z,zu,gamma_cup,t_cup,dby - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop -! -! input and output -! - - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - real(kind=kind_phys), dimension (its:ite) & - ,intent (out ) :: & - aa0 -! -! local variables in this routine -! - - integer :: & - i,k - real(kind=kind_phys) :: & - dz,da -! - do i=its,itf - aa0(i)=0. - enddo - do 100 k=kts+1,ktf - do 100 i=its,itf - if(ierr(i).ne.0)go to 100 - if(k.lt.kbcon(i))go to 100 - if(k.gt.ktop(i))go to 100 - dz=z(i,k)-z(i,k-1) - da=zu(i,k)*dz*(9.81/(1004.*( & - (t_cup(i,k)))))*dby(i,k-1)/ & - (1.+gamma_cup(i,k)) -! if(k.eq.ktop(i).and.da.le.0.)go to 100 - aa0(i)=aa0(i)+max(0.,da) - if(aa0(i).lt.0.)aa0(i)=0. -100 continue - - end subroutine cup_up_aa0 - -!==================================================================== - subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & - outqc,pret,its,ite,kts,kte,itf,ktf,ktop) - - integer, intent(in ) :: j,its,ite,kts,kte,itf,ktf - integer, dimension (its:ite ), intent(in ) :: ktop - - real(kind=kind_phys), dimension (its:ite,kts:kte ) , & - intent(inout ) :: & - outq,outt,outqc,outu,outv - real(kind=kind_phys), dimension (its:ite,kts:kte ) , & - intent(inout ) :: & - q - real(kind=kind_phys), dimension (its:ite ) , & - intent(inout ) :: & - pret - character *(*), intent (in) :: & - name - real(kind=kind_phys) & - ,intent (in ) :: & - dt - real(kind=kind_phys) :: names,scalef,thresh,qmem,qmemf,qmem2,qtest,qmem1 - integer :: icheck -! -! first do check on vertical heating rate -! - thresh=300.01 -! thresh=200.01 !ss -! thresh=250.01 - names=1. - if(name == 'shallow' .or. name == 'mid')then - thresh=148.01 - names=1. - endif - scalef=86400. - do i=its,itf - if(ktop(i) <= 2)cycle - icheck=0 - qmemf=1. - qmem=0. - do k=kts,ktop(i) - qmem=(outt(i,k))*86400. - if(qmem.gt.thresh)then - qmem2=thresh/qmem - qmemf=min(qmemf,qmem2) - icheck=1 -! -! -! print *,'1',' adjusted massflux by factor ',i,j,k,qmem,qmem2,qmemf,dt - endif - if(qmem.lt.-.5*thresh*names)then - qmem2=-.5*names*thresh/qmem - qmemf=min(qmemf,qmem2) - icheck=2 -! -! - endif - enddo - do k=kts,ktop(i) - outq(i,k)=outq(i,k)*qmemf - outt(i,k)=outt(i,k)*qmemf - outu(i,k)=outu(i,k)*qmemf - outv(i,k)=outv(i,k)*qmemf - outqc(i,k)=outqc(i,k)*qmemf - enddo - pret(i)=pret(i)*qmemf - enddo -! return -! -! check whether routine produces negative q's. this can happen, since -! tendencies are calculated based on forced q's. this should have no -! influence on conservation properties, it scales linear through all -! tendencies -! -! return -! write(14,*)'return' - thresh=1.e-32 - do i=its,itf - if(ktop(i) <= 2)cycle - qmemf=1. - do k=kts,ktop(i) - qmem=outq(i,k) - if(abs(qmem).gt.0. .and. q(i,k).gt.1.e-6)then - qtest=q(i,k)+(outq(i,k))*dt - if(qtest.lt.thresh)then -! -! qmem2 would be the maximum allowable tendency -! - qmem1=abs(outq(i,k)) - qmem2=abs((thresh-q(i,k))/dt) - qmemf=min(qmemf,qmem2/qmem1) - qmemf=max(0.,qmemf) - endif - endif - enddo - do k=kts,ktop(i) - outq(i,k)=outq(i,k)*qmemf - outt(i,k)=outt(i,k)*qmemf - outu(i,k)=outu(i,k)*qmemf - outv(i,k)=outv(i,k)*qmemf - outqc(i,k)=outqc(i,k)*qmemf - enddo - pret(i)=pret(i)*qmemf - enddo - - end subroutine neg_check - - - subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & - outtem,outq,outqc, & - zu,pre,pw,xmb,ktop, & - edt,pwd,name,ierr2,ierr3,p_cup,pr_ens, & - maxens3, & - sig,closure_n,xland1,xmbm_in,xmbs_in, & - ichoice,imid,ipr,itf,ktf, & - its,ite, kts,kte, & - dicycle,xf_dicycle ) - - implicit none -! -! on input -! - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ichoice,imid,ipr,itf,ktf, & - its,ite, kts,kte - integer, intent (in ) :: & - maxens3 - ! xf_ens = ensemble mass fluxes - ! pr_ens = precipitation ensembles - ! dellat = change of temperature per unit mass flux of cloud ensemble - ! dellaq = change of q per unit mass flux of cloud ensemble - ! dellaqc = change of qc per unit mass flux of cloud ensemble - ! outtem = output temp tendency (per s) - ! outq = output q tendency (per s) - ! outqc = output qc tendency (per s) - ! pre = output precip - ! xmb = total base mass flux - ! xfac1 = correction factor - ! pw = pw -epsilon*pd (ensemble dependent) - ! ierr error value, maybe modified in this routine - ! - real(kind=kind_phys), dimension (its:ite,1:maxens3) & - ,intent (inout) :: & - xf_ens,pr_ens - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (inout ) :: & - outtem,outq,outqc - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - zu,pwd,p_cup - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - sig,xmbm_in,xmbs_in,edt - real(kind=kind_phys), dimension (its:ite,2) & - ,intent (in ) :: & - xff_mid - real(kind=kind_phys), dimension (its:ite) & - ,intent (inout ) :: & - pre,xmb - real(kind=kind_phys), dimension (its:ite) & - ,intent (inout ) :: & - closure_n - real(kind=kind_phys), dimension (its:ite,kts:kte,1) & - ,intent (in ) :: & - dellat,dellaqc,dellaq,pw - integer, dimension (its:ite) & - ,intent (in ) :: & - ktop,xland1 - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr,ierr2,ierr3 - integer, intent(in) :: dicycle - real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle -! -! local variables in this routine -! - - integer :: & - i,k,n - real(kind=kind_phys) :: & - clos_wei,dtt,dp,dtq,dtqc,dtpw,dtpwd - real(kind=kind_phys), dimension (its:ite) :: & - pre2,xmb_ave,pwtot -! - character *(*), intent (in) :: & - name - -! - do k=kts,kte - do i=its,ite - outtem (i,k)=0. - outq (i,k)=0. - outqc (i,k)=0. - enddo - enddo - do i=its,itf - pre(i)=0. - xmb(i)=0. - enddo - do i=its,itf - if(ierr(i).eq.0)then - do n=1,maxens3 - if(pr_ens(i,n).le.0.)then - xf_ens(i,n)=0. - endif - enddo - endif - enddo -! -!--- calculate ensemble average mass fluxes -! - -! -!-- now do feedback -! -!!!!! deep convection !!!!!!!!!! - if(imid.eq.0)then - do i=its,itf - if(ierr(i).eq.0)then - k=0 - xmb_ave(i)=0. - do n=1,maxens3 - k=k+1 - xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) - - enddo - !print *,'xf_ens',xf_ens - xmb_ave(i)=xmb_ave(i)/float(k) - !print *,'k,xmb_ave',k,xmb_ave - !srf begin - if(dicycle == 2 )then - xmb_ave(i)=xmb_ave(i)-max(0.,xmbs_in(i)) - xmb_ave(i)=max(0.,xmb_ave(i)) - else if (dicycle == 1) then -! xmb_ave(i)=min(xmb_ave(i),xmb_ave(i) - xf_dicycle(i)) - xmb_ave(i)=xmb_ave(i) - xf_dicycle(i) - xmb_ave(i)=max(0.,xmb_ave(i)) - endif - !print *,"2 xmb_ave,xf_dicycle",xmb_ave,xf_dicycle -! --- now use proper count of how many closures were actually -! used in cup_forcing_ens (including screening of some -! closures over water) to properly normalize xmb - clos_wei=16./max(1.,closure_n(i)) - xmb_ave(i)=min(xmb_ave(i),100.) - xmb(i)=clos_wei*sig(i)*xmb_ave(i) - - if(xmb(i) < 1.e-16)then - ierr(i)=19 - endif -! xfac1(i)=xmb(i) -! xfac2(i)=xmb(i) - - endif - enddo -!!!!! not so deep convection !!!!!!!!!! - else ! imid == 1 - do i=its,itf - xmb_ave(i)=0. - if(ierr(i).eq.0)then -! ! first get xmb_ves, depend on ichoicee -! - if(ichoice.eq.1 .or. ichoice.eq.2)then - xmb_ave(i)=sig(i)*xff_mid(i,ichoice) - else if(ichoice.gt.2)then - k=0 - do n=1,maxens3 - k=k+1 - xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) - enddo - xmb_ave(i)=xmb_ave(i)/float(k) - else if(ichoice == 0)then - xmb_ave(i)=.5*sig(i)*(xff_mid(i,1)+xff_mid(i,2)) - endif ! ichoice gt.2 -! which dicycle method - if(dicycle == 2 )then - xmb(i)=max(0.,xmb_ave(i)-xmbs_in(i)) - else if (dicycle == 1) then -! xmb(i)=min(xmb_ave(i),xmb_ave(i) - xf_dicycle(i)) - xmb(i)=xmb_ave(i) - xf_dicycle(i) - xmb(i)=max(0.,xmb_ave(i)) - else if (dicycle == 0) then - xmb(i)=max(0.,xmb_ave(i)) - endif ! dicycle=1,2 - endif ! ierr >0 - enddo ! i - endif ! imid=1 - - do i=its,itf - if(ierr(i).eq.0)then - dtpw=0. - do k=kts,ktop(i) - dtpw=dtpw+pw(i,k,1) - outtem(i,k)= xmb(i)* dellat (i,k,1) - outq (i,k)= xmb(i)* dellaq (i,k,1) - outqc (i,k)= xmb(i)* dellaqc(i,k,1) - enddo - PRE(I)=PRE(I)+XMB(I)*dtpw - endif - enddo - return - - do i=its,itf - pwtot(i)=0. - pre2(i)=0. - if(ierr(i).eq.0)then - do k=kts,ktop(i) - pwtot(i)=pwtot(i)+pw(i,k,1) - enddo - do k=kts,ktop(i) - dp=100.*(p_cup(i,k)-p_cup(i,k+1))/g - dtt =dellat (i,k,1) - dtq =dellaq (i,k,1) -! necessary to drive downdraft - dtpwd=-pwd(i,k)*edt(i) -! take from dellaqc first - dtqc=dellaqc (i,k,1)*dp - dtpwd -! if this is negative, use dellaqc first, rest needs to come from rain - if(dtqc < 0.)then - dtpwd=dtpwd-dellaqc(i,k,1)*dp - dtqc=0. -! if this is positive, can come from clw detrainment - else - dtqc=dtqc/dp - dtpwd=0. - endif - outtem(i,k)= xmb(i)* dtt - outq (i,k)= xmb(i)* dtq - outqc (i,k)= xmb(i)* dtqc - xf_ens(i,:)=sig(i)*xf_ens(i,:) -! what is evaporated - pre(i)=pre(i)-xmb(i)*dtpwd - pre2(i)=pre2(i)+xmb(i)*(pw(i,k,1)+edt(i)*pwd(i,k)) -! write(15,124)k,dellaqc(i,k,1),dtqc,-pwd(i,k)*edt(i),dtpwd - enddo - pre(i)=-pre(i)+xmb(i)*pwtot(i) - endif -124 format(1x,i3,4e13.4) -125 format(1x,2e13.4) - enddo - - - end subroutine cup_output_ens_3d -!------------------------------------------------------- - subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & - p_cup,kbcon,ktop,dby,clw_all,xland1, & - q,gamma_cup,zu,qes_cup,k22,qe_cup, & - zqexec,ccn,rho,c1d,t, & - up_massentr,up_massdetr,psum,psumh, & - itest,itf,ktf, & - its,ite, kts,kte ) - - implicit none - real(kind=kind_phys), parameter :: bdispm = 0.366 !berry--size dispersion (martime) - real(kind=kind_phys), parameter :: bdispc = 0.146 !berry--size dispersion (continental) -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itest,itf,ktf, & - its,ite, kts,kte - ! cd= detrainment function - ! q = environmental q on model levels - ! qe_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! dby = buoancy term - ! cd= detrainment function - ! zu = normalized updraft mass flux - ! gamma_cup = gamma on model cloud levels - ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - p_cup,rho,q,zu,gamma_cup,qe_cup, & - up_massentr,up_massdetr,dby,qes_cup,z_cup - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - zqexec - ! entr= entrainment rate - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop,k22,xland1 -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - character *(*), intent (in) :: & - name - ! qc = cloud q (including liquid water) after entrainment - ! qrch = saturation q in cloud - ! qrc = liquid water content in cloud after rainout - ! pw = condensate that will fall out at that level - ! pwav = totan normalized integrated condensate (i1) - ! c0 = conversion rate (cloud to rain) - - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (out ) :: & - qc,qrc,pw,clw_all - real(kind=kind_phys), dimension (its:ite,kts:kte) :: & - qch,qrcb,pwh,clw_allh,c1d,t - real(kind=kind_phys), dimension (its:ite) :: & - pwavh - real(kind=kind_phys), dimension (its:ite) & - ,intent (out ) :: & - pwav,psum,psumh - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - ccn -! -! local variables in this routine -! - - integer :: & - iprop,iall,i,k - integer :: start_level(its:ite) - real(kind=kind_phys) :: & - prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & - c0,dz,berryc0,q1,berryc - real(kind=kind_phys) :: & - denom, c0t - real(kind=kind_phys), dimension (kts:kte) :: & - prop_b -! - prop_b(kts:kte)=0 - iall=0 - c0=.002 - clwdet=100. - bdsp=bdispm -! -!--- no precip for small clouds -! -! if(name.eq.'shallow')then -! c0=0.002 -! endif - do i=its,itf - pwav(i)=0. - pwavh(i)=0. - psum(i)=0. - psumh(i)=0. - enddo - do k=kts,ktf - do i=its,itf - pw(i,k)=0. - pwh(i,k)=0. - qc(i,k)=0. - if(ierr(i).eq.0)qc(i,k)=qe_cup(i,k) - if(ierr(i).eq.0)qch(i,k)=qe_cup(i,k) - clw_all(i,k)=0. - clw_allh(i,k)=0. - qrc(i,k)=0. - qrcb(i,k)=0. - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - start_level=k22(i) - call get_cloud_bc(kte,qe_cup (i,1:kte),qaver,k22(i)) - qaver = qaver - k=start_level(i) - qc (i,k)= qaver - qch (i,k)= qaver - do k=1,start_level(i)-1 - qc (i,k)= qe_cup(i,k) - qch (i,k)= qe_cup(i,k) - enddo -! -! initialize below originating air -! - endif - enddo - - do 100 i=its,itf - c0=.004 - if(ierr(i).eq.0)then - -! below lfc, but maybe above lcl -! -! if(name == "deep" )then - do k=k22(i)+1,kbcon(i) - if(t(i,k) > 273.16) then - c0t = c0 - else - c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) - endif - qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & - up_massentr(i,k-1)*q(i,k-1)) / & - (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) -! qrch=qes_cup(i,k) - qrch=qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & - /(1.+gamma_cup(i,k)))*dby(i,k) - if(k.lt.kbcon(i))qrch=qc(i,k) - if(qc(i,k).gt.qrch)then - dz=z_cup(i,k)-z_cup(i,k-1) - qrc(i,k)=(qc(i,k)-qrch)/(1.+c0t*dz) - pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) - qc(i,k)=qrch+qrc(i,k) - clw_all(i,k)=qrc(i,k) - endif - enddo - ! endif -! -!now do the rest -! - do k=kbcon(i)+1,ktop(i) - c0=.004 - if(t(i,k).lt.270.)c0=.002 - if(t(i,k) > 273.16) then - c0t = c0 - else - c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) - endif - denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) - if(denom.lt.1.e-16)then - ierr(i)=51 - exit - endif - - - rhoc=.5*(rho(i,k)+rho(i,k-1)) - dz=z_cup(i,k)-z_cup(i,k-1) - dp=p_cup(i,k)-p_cup(i,k-1) -! -!--- saturation in cloud, this is what is allowed to be in it -! - qrch=qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & - /(1.+gamma_cup(i,k)))*dby(i,k) -! -!------ 1. steady state plume equation, for what could -!------ be in cloud without condensation -! -! - qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & - up_massentr(i,k-1)*q(i,k-1)) / & - (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) - qch(i,k)= (qch(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*qch(i,k-1)+ & - up_massentr(i,k-1)*q(i,k-1)) / & - (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) - - if(qc(i,k).le.qrch)then - qc(i,k)=qrch - endif - if(qch(i,k).le.qrch)then - qch(i,k)=qrch - endif -! -!------- total condensed water before rainout -! - clw_all(i,k)=max(0.,qc(i,k)-qrch) - qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) - clw_allh(i,k)=max(0.,qch(i,k)-qrch) - qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) - if(autoconv.eq.2) then - - -! -! normalized berry -! -! first calculate for average conditions, used in cup_dd_edt! -! this will also determine proportionality constant prop_b, which, if applied, -! would give the same results as c0 under these conditions -! - q1=1.e3*rhoc*qrcb(i,k) ! g/m^3 ! g[h2o]/cm^3 - berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccnclean/ & - ( q1 * bdsp) ) ) !/( - qrcb_h=((qch(i,k)-qrch)*zu(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ & - (zu(i,k)+.5*up_massdetr(i,k-1)+c0t*dz*zu(i,k)) - prop_b(k)=c0t*qrcb_h*zu(i,k)/(1.e-3*berryc0) - pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) ! 2. - berryc=qrcb(i,k) - qrcb(i,k)=((qch(i,k)-qrch)*zu(i,k)-pwh(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ & - (zu(i,k)+.5*up_massdetr(i,k-1)) - if(qrcb(i,k).lt.0.)then - berryc0=(qrcb(i,k-1)*(.5*up_massdetr(i,k-1))-(qch(i,k)-qrch)*zu(i,k))/zu(i,k)*1.e-3*dz*prop_b(k) - pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) - qrcb(i,k)=0. - endif - qch(i,k)=qrcb(i,k)+qrch - pwavh(i)=pwavh(i)+pwh(i,k) - psumh(i)=psumh(i)+clw_allh(i,k)*zu(i,k) *dz - ! -! then the real berry -! - q1=1.e3*rhoc*qrc(i,k) ! g/m^3 ! g[h2o]/cm^3 - berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccn(i)/ & - ( q1 * bdsp) ) ) !/( - berryc0=1.e-3*berryc0*dz*prop_b(k) ! 2. - berryc=qrc(i,k) - qrc(i,k)=((qc(i,k)-qrch)*zu(i,k)-zu(i,k)*berryc0-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/ & - (zu(i,k)+.5*up_massdetr(i,k-1)) - if(qrc(i,k).lt.0.)then - berryc0=((qc(i,k)-qrch)*zu(i,k)-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/zu(i,k) - qrc(i,k)=0. - endif - pw(i,k)=berryc0*zu(i,k) - qc(i,k)=qrc(i,k)+qrch -! -! if not running with berry at all, do the following -! - else !c0=.002 - if(iall.eq.1)then - qrc(i,k)=0. - pw(i,k)=(qc(i,k)-qrch)*zu(i,k) - if(pw(i,k).lt.0.)pw(i,k)=0. - else -! create clw detrainment profile that depends on mass detrainment and -! in-cloud clw/ice -! - c1d(i,k)=clwdet*up_massdetr(i,k-1)*qrc(i,k-1) - qrc(i,k)=(qc(i,k)-qrch)/(1.+(c1d(i,k)+c0t)*dz) - pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) -!-----srf-08aug2017-----begin -! pw(i,k)=(c1d(i,k)+c0)*dz*max(0.,qrc(i,k) -qrc_crit)! units kg[rain]/kg[air] -!-----srf-08aug2017-----end - if(qrc(i,k).lt.0)then - qrc(i,k)=0. - pw(i,k)=0. - endif - endif - qc(i,k)=qrc(i,k)+qrch - endif !autoconv - pwav(i)=pwav(i)+pw(i,k) - psum(i)=psum(i)+clw_all(i,k)*zu(i,k) *dz - enddo ! k=kbcon,ktop -! do not include liquid/ice in qc - do k=k22(i)+1,ktop(i) - qc(i,k)=qc(i,k)-qrc(i,k) - enddo - endif ! ierr -! -!--- integrated normalized ondensate -! - 100 continue - prop_ave=0. - iprop=0 - do k=kts,kte - prop_ave=prop_ave+prop_b(k) - if(prop_b(k).gt.0)iprop=iprop+1 - enddo - iprop=max(iprop,1) - - end subroutine cup_up_moisture - -!-------------------------------------------------------------------- - - real function satvap(temp2) - implicit none - real(kind=kind_phys) :: temp2, temp, toot, toto, eilog, tsot, & - & ewlog, ewlog2, ewlog3, ewlog4 - temp = temp2-273.155 - if (temp.lt.-20.) then !!!! ice saturation - toot = 273.16 / temp2 - toto = 1 / toot - eilog = -9.09718 * (toot - 1) - 3.56654 * (log(toot) / & - & log(10.)) + .876793 * (1 - toto) + (log(6.1071) / log(10.)) - satvap = 10 ** eilog - else - tsot = 373.16 / temp2 - ewlog = -7.90298 * (tsot - 1) + 5.02808 * & - & (log(tsot) / log(10.)) - ewlog2 = ewlog - 1.3816e-07 * & - & (10 ** (11.344 * (1 - (1 / tsot))) - 1) - ewlog3 = ewlog2 + .0081328 * & - & (10 ** (-3.49149 * (tsot - 1)) - 1) - ewlog4 = ewlog3 + (log(1013.246) / log(10.)) - satvap = 10 ** ewlog4 - end if - end function -!-------------------------------------------------------------------- - subroutine get_cloud_bc(mzp,array,x_aver,k22,add) - implicit none - integer, intent(in) :: mzp,k22 - real(kind=kind_phys) , intent(in) :: array(mzp) - real(kind=kind_phys) , optional , intent(in) :: add - real(kind=kind_phys) , intent(out) :: x_aver - integer :: i,local_order_aver,order_aver - - !-- dimension of the average - !-- a) to pick the value at k22 level, instead of a average between - !-- k22-order_aver, ..., k22-1, k22 set order_aver=1) - !-- b) to average between 1 and k22 => set order_aver = k22 - order_aver = 3 !=> average between k22, k22-1 and k22-2 - - local_order_aver=min(k22,order_aver) - - x_aver=0. - do i = 1,local_order_aver - x_aver = x_aver + array(k22-i+1) - enddo - x_aver = x_aver/float(local_order_aver) - if(present(add)) x_aver = x_aver + add - - end subroutine get_cloud_bc - !======================================================================================== - - - subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, & - xland,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev) - implicit none - character *(*), intent (in) :: name - integer, intent(in) :: ipr,its,ite,itf,kts,kte,ktf - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup - real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo,rand_vmas - integer, dimension (its:ite),intent (in) :: kstabi,k22,kpbl,csum,xland,pmin_lev - integer, dimension (its:ite),intent (inout) :: kbcon,ierr,ktop,ktopdby - !-local vars - real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot - real(kind=kind_phys) :: entr_init,beta_u,dz,dbythresh,dzh2,zustart,zubeg,massent,massdetr - real(kind=kind_phys) :: dby(kts:kte),dbm(kts:kte),zux(kts:kte) - real(kind=kind_phys) zuh2(40),zh2(40) - integer :: kklev,i,kk,kbegin,k,kfinalzu - integer, dimension (its:ite) :: start_level - ! - zustart=.1 - dbythresh= 0.8 !.0.95 ! 0.85, 0.6 - if(name == 'shallow' .or. name == 'mid') dbythresh=1. - dby(:)=0. - - do i=its,itf - if(ierr(i) > 0 )cycle - zux(:)=0. - beta_u=max(.1,.2-float(csum(i))*.01) - zuo(i,:)=0. - dby(:)=0. - dbm(:)=0. - kbcon(i)=max(kbcon(i),2) - start_level(i)=k22(i) - zuo(i,start_level(i))=zustart - zux(start_level(i))=zustart - entr_init=entr_rate_2d(i,kts) - do k=start_level(i)+1,kbcon(i) - dz=z_cup(i,k)-z_cup(i,k-1) - massent=dz*entr_rate_2d(i,k-1)*zuo(i,k-1) -! massdetr=dz*1.e-9*zuo(i,k-1) - massdetr=dz*.1*entr_init*zuo(i,k-1) - zuo(i,k)=zuo(i,k-1)+massent-massdetr - zux(k)=zuo(i,k) - enddo - zubeg=zustart !zuo(i,kbcon(i)) - if(name .eq. 'deep')then - ktop(i)=0 - hcot(i,start_level(i))=hkbo(i) - dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1) - do k=start_level(i)+1,ktf-2 - dz=z_cup(i,k)-z_cup(i,k-1) - - hcot(i,k)=( (1.-0.5*entr_rate_2d(i,k-1)*dz)*hcot(i,k-1) & - + entr_rate_2d(i,k-1)*dz*heo(i,k-1))/ & - (1.+0.5*entr_rate_2d(i,k-1)*dz) - if(k >= kbcon(i)) dby(k)=dby(k-1)+(hcot(i,k)-heso_cup(i,k))*dz - if(k >= kbcon(i)) dbm(k)=hcot(i,k)-heso_cup(i,k) - enddo - ktopdby(i)=maxloc(dby(:),1) - kklev=maxloc(dbm(:),1) - do k=maxloc(dby(:),1)+1,ktf-2 - if(dby(k).lt.dbythresh*maxval(dby))then - kfinalzu=k - 1 - ktop(i)=kfinalzu - go to 412 - endif - enddo - kfinalzu=ktf-2 - ktop(i)=kfinalzu -412 continue - kklev=min(kklev+3,ktop(i)-2) -! -! at least overshoot by one level -! -! kfinalzu=min(max(kfinalzu,ktopdby(i)+1),ktopdby(i)+2) -! ktop(i)=kfinalzu - if(kfinalzu.le.kbcon(i)+2)then - ierr(i)=41 - ktop(i)= 0 - else -! call get_zu_zd_pdf_fim(ipr,xland(i),zuh2,"up",ierr(i),start_level(i), & -! call get_zu_zd_pdf_fim(rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),kbcon(i), & -! kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i)) - call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),k22(i), & - kfinalzu+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) - endif - endif ! end deep - if ( name == 'mid' ) then - if(ktop(i) <= kbcon(i)+2)then - ierr(i)=41 - ktop(i)= 0 - else - kfinalzu=ktop(i) - ktopdby(i)=ktop(i)+1 - call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"mid",ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) - endif - endif ! mid - if ( name == 'shallow' ) then - if(ktop(i) <= kbcon(i)+2)then - ierr(i)=41 - ktop(i)= 0 - else - kfinalzu=ktop(i) - ktopdby(i)=ktop(i)+1 - call get_zu_zd_pdf_fim(kbcon(i),p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"sh2",ierr(i),k22(i), & - ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) - - endif - endif ! shal - enddo - - end subroutine rates_up_pdf -!------------------------------------------------------------------------- - - subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,kb,kt,zu,kts,kte,ktf,max_mass,kpbli,csum,pmin_lev) - - implicit none -! real(kind=kind_phys), parameter :: beta_deep=1.3,g_beta_deep=0.8974707 -! real(kind=kind_phys), parameter :: beta_deep=1.2,g_beta_deep=0.8974707 -! real(kind=kind_phys), parameter :: beta_sh=2.5,g_beta_sh=1.329340 - real(kind=kind_phys), parameter :: beta_sh=2.2,g_beta_sh=0.8974707 - real(kind=kind_phys), parameter :: beta_mid=1.3,g_beta_mid=0.8974707 -! real(kind=kind_phys), parameter :: beta_mid=1.8,g_beta_mid=0.8974707 - real(kind=kind_phys), parameter :: beta_dd=4.0,g_beta_dd=6. - integer, intent(in) ::ipr,xland,kb,kklev,kt,kts,kte,ktf,kpbli,csum,pmin_lev - real(kind=kind_phys), intent(in) ::max_mass,zubeg - real(kind=kind_phys), intent(inout) :: zu(kts:kte) - real(kind=kind_phys), intent(in) :: p(kts:kte) - real(kind=kind_phys) :: trash,beta_deep,zuh(kts:kte),zuh2(1:40) - integer, intent(inout) :: ierr - character*(*), intent(in) ::draft - - !- local var - integer :: k1,kk,k,kb_adj,kpbli_adj,kmax - real(kind=kind_phys) :: maxlim,krmax,kratio,tunning,fzu,rand_vmas,lev_start - real(kind=kind_phys) :: a,b,x1,y1,g_a,g_b,alpha2,g_alpha2 -! -! very simple lookup tables -! - real(kind=kind_phys), dimension(30) :: alpha,g_alpha - data (alpha(k),k=4,27)/3.699999, & - 3.024999,2.559999,2.249999,2.028571,1.862500, & - 1.733333,1.630000,1.545454,1.475000,1.415385, & - 1.364286,1.320000,1.281250,1.247059,1.216667, & - 1.189474,1.165000,1.142857,1.122727,1.104348, & - 1.087500,1.075000,1.075000/ - data (g_alpha(k),k=4,27)/4.170645, & - 2.046925 , 1.387837, 1.133003, 1.012418,0.9494680, & - 0.9153771,0.8972442,0.8885444,0.8856795,0.8865333, & - 0.8897996,0.8946404,0.9005030,0.9070138,0.9139161, & - 0.9210315,0.9282347,0.9354376,0.9425780,0.9496124, & - 0.9565111,0.9619183,0.9619183/ - alpha(1:3)=alpha(4) - g_alpha(1:3)=g_alpha(4) - alpha(28:30)=alpha(27) - g_alpha(28:30)=g_alpha(27) - - !- kb cannot be at 1st level - - !-- fill zu with zeros - zu(:)=0.0 - zuh(:)=0.0 - kb_adj=max(kb,2) - if(draft == "up") then - lev_start=min(.9,.1+csum*.013) - kb_adj=max(kb,2) - tunning=max(p(kklev+1),.5*(p(kpbli)+p(kt))) - tunning=p(kklev) -! tunning=p(kklev+1) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start -! tunning=.5*(p(kb_adj)+p(kt)) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start - trash=-p(kt)+p(kb_adj) - beta_deep=1.3 +(1.-trash/1200.) - tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 - tunning =max(0.02, tunning) - alpha2= (tunning*(beta_deep -2.)+1.)/(1.-tunning) - do k=27,3,-1 - if(alpha(k) >= alpha2)exit - enddo - k1=k+1 - if(alpha(k1) .ne. alpha(k1-1))then -! write(0,*)'k1 = ',k1 - a=alpha(k1)-alpha(k1-1) - b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) - x1= (alpha2-b)/a - y1=a*x1+b -! write(0,*)'x1,y1,a,b ',x1,y1,a,b - g_a=g_alpha(k1)-g_alpha(k1-1) - g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) - g_alpha2=g_a*x1+g_b -! write(0,*)'g_a,g_b,g_alpha2 ',g_a,g_b,g_alpha2 - else - g_alpha2=g_alpha(k1) - endif - -! fzu = gamma(alpha2 + beta_deep)/(g_alpha2*g_beta_deep) - fzu = gamma(alpha2 + beta_deep)/(gamma(alpha2)*gamma(beta_deep)) - zu(kb_adj)=zubeg - do k=kb_adj+1,min(kte,kt-1) - kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) - zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_deep-1.0) - enddo - - if(zu(kpbli).gt.0.) & - zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=maxloc(zu(:),1),1,-1 - if(zu(k).lt.1.e-6)then - kb_adj=k+1 - exit - endif - enddo - kb_adj=max(2,kb_adj) - do k=kts,kb_adj-1 - zu(k)=0. - enddo - maxlim=1.2 - a=maxval(zu)-zu(kb_adj) - do k=kb_adj,kt - trash=zu(k) - if(a.gt.maxlim)then - zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) -! if(p(kt).gt.400.)write(32,122)k,p(k),zu(k),trash - endif - enddo -122 format(1x,i4,1x,f8.1,1x,f6.2,1x,f6.2) - - elseif(draft == "sh2") then - k=kklev - if(kpbli.gt.5)k=kpbli -!new nov18 - tunning=p(kklev) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start -!end new - tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 - tunning =max(0.02, tunning) - alpha2= (tunning*(beta_sh -2.)+1.)/(1.-tunning) - do k=27,3,-1 - if(alpha(k) >= alpha2)exit - enddo - k1=k+1 - if(alpha(k1) .ne. alpha(k1-1))then - a=alpha(k1)-alpha(k1-1) - b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) - x1= (alpha2-b)/a - y1=a*x1+b - g_a=g_alpha(k1)-g_alpha(k1-1) - g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) - g_alpha2=g_a*x1+g_b - else - g_alpha2=g_alpha(k1) - endif - - fzu = gamma(alpha2 + beta_sh)/(g_alpha2*g_beta_sh) - zu(kb_adj) = zubeg - do k=kb_adj+1,min(kte,kt-1) - kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) - zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_sh-1.0) - enddo - -! beta = 2.5 !2.5 ! max(2.5,2./tunning) -! if(maxval(zu(kts:min(ktf,kt+1))).gt.0.) & -! zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1))) - if(zu(kpbli).gt.0.) & - zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=maxloc(zu(:),1),1,-1 - if(zu(k).lt.1.e-6)then - kb_adj=k+1 - exit - endif - enddo - maxlim=1. - a=maxval(zu)-zu(kb_adj) - do k=kts,kt - if(a.gt.maxlim)zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) -! write(32,122)k,p(k),zu(k) - enddo - - elseif(draft == "mid") then - kb_adj=max(kb,2) - tunning=.5*(p(kt)+p(kpbli)) !p(kt)+(p(kb_adj)-p(kt))*.9 !*.33 -!new nov18 -! tunning=p(kpbli) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start -!end new - tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 - tunning =max(0.02, tunning) - alpha2= (tunning*(beta_mid -2.)+1.)/(1.-tunning) - do k=27,3,-1 - if(alpha(k) >= alpha2)exit - enddo - k1=k+1 - if(alpha(k1) .ne. alpha(k1-1))then - a=alpha(k1)-alpha(k1-1) - b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) - x1= (alpha2-b)/a - y1=a*x1+b - g_a=g_alpha(k1)-g_alpha(k1-1) - g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) - g_alpha2=g_a*x1+g_b - else - g_alpha2=g_alpha(k1) - endif - -! fzu = gamma(alpha2 + beta_deep)/(g_alpha2*g_beta_deep) - fzu = gamma(alpha2 + beta_mid)/(gamma(alpha2)*gamma(beta_mid)) -! fzu = gamma(alpha2 + beta_mid)/(g_alpha2*g_beta_mid) - zu(kb_adj) = zubeg - do k=kb_adj+1,min(kte,kt-1) - kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) - zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_mid-1.0) - enddo - - if(zu(kpbli).gt.0.) & - zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=maxloc(zu(:),1),1,-1 - if(zu(k).lt.1.e-6)then - kb_adj=k+1 - exit - endif - enddo - kb_adj=max(2,kb_adj) - do k=kts,kb_adj-1 - zu(k)=0. - enddo - maxlim=1.5 - a=maxval(zu)-zu(kb_adj) - do k=kts,kt - if(a.gt.maxlim)zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) -! write(33,122)k,p(k),zu(k) - enddo - - elseif(draft == "down" .or. draft == "downm") then - - tunning=p(kb) - tunning =min(0.95, (tunning-p(1))/(p(kt)-p(1))) !=.6 - tunning =max(0.02, tunning) - alpha2= (tunning*(beta_dd -2.)+1.)/(1.-tunning) - do k=27,3,-1 - if(alpha(k) >= alpha2)exit - enddo - k1=k+1 - if(alpha(k1) .ne. alpha(k1-1))then - a=alpha(k1)-alpha(k1-1) - b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) - x1= (alpha2-b)/a - y1=a*x1+b - g_a=g_alpha(k1)-g_alpha(k1-1) - g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) - g_alpha2=g_a*x1+g_b - else - g_alpha2=g_alpha(k1) - endif - - fzu = gamma(alpha2 + beta_dd)/(g_alpha2*g_beta_dd) -! fzu = gamma(alpha2 + beta_dd)/(gamma(alpha2)*gamma(beta_dd)) - zu(:)=0. - do k=2,min(kte,kt-1) - kratio= (p(k)-p(1))/(p(kt)-p(1)) !float(k)/float(kt+1) - zu(k) = fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_dd-1.0) - enddo - - fzu=maxval(zu(kts:min(ktf,kt-1))) - if(fzu.gt.0.) & - zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/fzu - zu(1)=0. - do k=1,kb-2 !kb,2,-1 - zu(kb-k)=zu(kb-k+1)-zu(kb)*(p(kb-k)-p(kb-k+1))/(p(1)-p(kb)) - enddo - zu(1)=0. - endif - end subroutine get_zu_zd_pdf_fim - -!------------------------------------------------------------------------- - subroutine cup_up_aa1bl(aa0,t,tn,q,qo,dtime, & - z_cup,zu,dby,gamma_cup,t_cup, & - kbcon,ktop,ierr, & - itf,ktf, & - its,ite, kts,kte ) - - implicit none -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,ktf, & - its,ite, kts,kte - ! aa0 cloud work function - ! gamma_cup = gamma on model cloud levels - ! t_cup = temperature (kelvin) on model cloud levels - ! dby = buoancy term - ! zu= normalized updraft mass flux - ! z = heights of model levels - ! ierr error value, maybe modified in this routine - ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,zu,gamma_cup,t_cup,dby,t,tn,q,qo - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop - real(kind=kind_phys), intent(in) :: dtime -! -! input and output -! - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - real(kind=kind_phys), dimension (its:ite) & - ,intent (out ) :: & - aa0 -! -! local variables in this routine -! - integer :: & - i,k - real(kind=kind_phys) :: & - dz,da -! - do i=its,itf - aa0(i)=0. - enddo - do 100 i=its,itf - do 100 k=kts,kbcon(i) - if(ierr(i).ne.0 )go to 100 -! if(k.gt.kbcon(i))go to 100 - - dz = (z_cup (i,k+1)-z_cup (i,k))*g - da = dz*(tn(i,k)*(1.+0.608*qo(i,k))-t(i,k)*(1.+0.608*q(i,k)))/dtime - - aa0(i)=aa0(i)+da -100 continue - - end subroutine cup_up_aa1bl -!---------------------------------------------------------------------- - subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_layers,& - kstart,kend,dtempdz,itf,ktf,its,ite, kts,kte) - - implicit none - integer ,intent (in ) :: itf,ktf,its,ite,kts,kte - integer, dimension (its:ite) ,intent (in ) :: ierr,kstart,kend - integer, dimension (its:ite) :: kend_p3 - - real(kind=kind_phys), dimension (its:ite,kts:kte), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup - real(kind=kind_phys), dimension (its:ite,kts:kte), intent (out) :: dtempdz - integer, dimension (its:ite,kts:kte), intent (out) :: k_inv_layers - !-local vars - real(kind=kind_phys) :: dp,l_mid,l_shal,first_deriv(kts:kte),sec_deriv(kts:kte) - integer:: ken,kadd,kj,i,k,ilev,kk,ix,k800,k550,mid,shal - ! - !-initialize k_inv_layers as undef - l_mid=300. - l_shal=100. - k_inv_layers(:,:) = 1 - do i = its,itf - if(ierr(i) == 0)then - sec_deriv(:)=0. - kend_p3(i)=kend(i)+3 - do k = kts+1,kend_p3(i)+4 - !- get the 1st der - first_deriv(k)= (t_cup(i,k+1)-t_cup(i,k-1))/(z_cup(i,k+1)-z_cup(i,k-1)) - dtempdz(i,k)=first_deriv(k) - enddo - do k = kts+2,kend_p3(i)+3 - ! get the 2nd der - sec_deriv(k)= (first_deriv(k+1)-first_deriv(k-1))/(z_cup(i,k+1)-z_cup(i,k-1)) - sec_deriv(k)= abs(sec_deriv(k)) - enddo - - ilev=max(kts+3,kstart(i)+1) - ix=1 - k=ilev - do while (ilev < kend_p3(i)) !(z_cup(i,ilev)<15000.) - do kk=k,kend_p3(i)+2 !k,ktf-2 - - if(sec_deriv(kk) < sec_deriv(kk+1) .and. & - sec_deriv(kk) < sec_deriv(kk-1) ) then - k_inv_layers(i,ix)=kk - ix=min(5,ix+1) - ilev=kk+1 - exit - endif - ilev=kk+1 - enddo - k=ilev - enddo - !- 2nd criteria - kadd=0 - ken=maxloc(k_inv_layers(i,:),1) - do k=1,ken - kk=k_inv_layers(i,k+kadd) - if(kk.eq.1)exit - - if( dtempdz(i,kk) < dtempdz(i,kk-1) .and. & - dtempdz(i,kk) < dtempdz(i,kk+1) ) then ! the layer is not a local maximum - kadd=kadd+1 - do kj = k,ken - if(k_inv_layers(i,kj+kadd).gt.1)k_inv_layers(i,kj) = k_inv_layers(i,kj+kadd) - if(k_inv_layers(i,kj+kadd).eq.1)k_inv_layers(i,kj) = 1 - enddo - endif - enddo - endif - enddo -100 format(1x,16i3) - !- find the locations of inversions around 800 and 550 hpa - do i = its,itf - if(ierr(i) /= 0) cycle - - !- now find the closest layers of 800 and 550 hpa. - sec_deriv(:)=1.e9 - do k=1,maxloc(k_inv_layers(i,:),1) !kts,kte !kstart(i),kend(i) !kts,kte - dp=p_cup(i,k_inv_layers(i,k))-p_cup(i,kstart(i)) - sec_deriv(k)=abs(dp)-l_shal - enddo - k800=minloc(abs(sec_deriv),1) - sec_deriv(:)=1.e9 - - do k=1,maxloc(k_inv_layers(i,:),1) !kts,kte !kstart(i),kend(i) !kts,kte - dp=p_cup(i,k_inv_layers(i,k))-p_cup(i,kstart(i)) - sec_deriv(k)=abs(dp)-l_mid - enddo - k550=minloc(abs(sec_deriv),1) - !-save k800 and k550 in k_inv_layers array - shal=1 - mid=2 - k_inv_layers(i,shal)=k_inv_layers(i,k800) ! this is for shallow convection - k_inv_layers(i,mid )=k_inv_layers(i,k550) ! this is for mid/congestus convection - k_inv_layers(i,mid+1:kte)=-1 - enddo - - - end subroutine get_inversion_layers -!----------------------------------------------------------------------------------- - function deriv3(xx, xi, yi, ni, m) - !============================================================================*/ - ! evaluate first- or second-order derivatives - ! using three-point lagrange interpolation - ! written by: alex godunov (october 2009) - ! input ... - ! xx - the abscissa at which the interpolation is to be evaluated - ! xi() - the arrays of data abscissas - ! yi() - the arrays of data ordinates - ! ni - size of the arrays xi() and yi() - ! m - order of a derivative (1 or 2) - ! output ... - ! deriv3 - interpolated value - !============================================================================*/ - - implicit none - integer, parameter :: n=3 - integer ni, m,i, j, k, ix - real(kind=kind_phys):: deriv3, xx - real(kind=kind_phys):: xi(ni), yi(ni), x(n), f(n) - - ! exit if too high-order derivative was needed, - if (m > 2) then - deriv3 = 0.0 - return - end if - - ! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0 - if (xx < xi(1) .or. xx > xi(ni)) then - deriv3 = 0.0 - stop "problems with finding the 2nd derivative" - end if - - ! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i) - i = 1 - j = ni - do while (j > i+1) - k = (i+j)/2 - if (xx < xi(k)) then - j = k - else - i = k - end if - end do - - ! shift i that will correspond to n-th order of interpolation - ! the search point will be in the middle in x_i, x_i+1, x_i+2 ... - i = i + 1 - n/2 - - ! check boundaries: if i is ouside of the range [1, ... n] -> shift i - if (i < 1) i=1 - if (i + n > ni) i=ni-n+1 - - ! old output to test i - ! write(*,100) xx, i - ! 100 format (f10.5, i5) - - ! just wanted to use index i - ix = i - ! initialization of f(n) and x(n) - do i=1,n - f(i) = yi(ix+i-1) - x(i) = xi(ix+i-1) - end do - - ! calculate the first-order derivative using lagrange interpolation - if (m == 1) then - deriv3 = (2.0*xx - (x(2)+x(3)))*f(1)/((x(1)-x(2))*(x(1)-x(3))) - deriv3 = deriv3 + (2.0*xx - (x(1)+x(3)))*f(2)/((x(2)-x(1))*(x(2)-x(3))) - deriv3 = deriv3 + (2.0*xx - (x(1)+x(2)))*f(3)/((x(3)-x(1))*(x(3)-x(2))) - ! calculate the second-order derivative using lagrange interpolation - else - deriv3 = 2.0*f(1)/((x(1)-x(2))*(x(1)-x(3))) - deriv3 = deriv3 + 2.0*f(2)/((x(2)-x(1))*(x(2)-x(3))) - deriv3 = deriv3 + 2.0*f(3)/((x(3)-x(1))*(x(3)-x(2))) - end if - end function deriv3 -!============================================================================================= - subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte & - ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & - ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,draft,kbcon,k22,up_massentru,up_massdetru,lambau) - - implicit none - character *(*), intent (in) :: draft - integer, intent(in):: itf,ktf, its,ite, kts,kte - integer, intent(in) , dimension(its:ite) :: ierr,ktop,kbcon,k22 - !real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau - real(kind=kind_phys), intent(inout), optional , dimension(its:ite):: lambau - real(kind=kind_phys), intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo - real(kind=kind_phys), intent(inout), dimension(its:ite,kts:kte) :: cd,entr_rate_2d - real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte) :: up_massentro, up_massdetro & - ,up_massentr, up_massdetr - real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte), optional :: & - up_massentru,up_massdetru - !-- local vars - integer :: i,k, incr1,incr2,turn - real(kind=kind_phys) :: dz,trash,trash2 - - do k=kts,kte - do i=its,ite - up_massentro(i,k)=0. - up_massdetro(i,k)=0. - up_massentr (i,k)=0. - up_massdetr (i,k)=0. - enddo - enddo - if(present(up_massentru) .and. present(up_massdetru))then - do k=kts,kte - do i=its,ite - up_massentru(i,k)=0. - up_massdetru(i,k)=0. - enddo - enddo - endif - do i=its,itf - if(ierr(i).eq.0)then - - do k=max(2,k22(i)+1),maxloc(zuo(i,:),1) - !=> below maximum value zu -> change entrainment - dz=zo_cup(i,k)-zo_cup(i,k-1) - - up_massdetro(i,k-1)=cd(i,k-1)*dz*zuo(i,k-1) - up_massentro(i,k-1)=zuo(i,k)-zuo(i,k-1)+up_massdetro(i,k-1) - if(up_massentro(i,k-1).lt.0.)then - up_massentro(i,k-1)=0. - up_massdetro(i,k-1)=zuo(i,k-1)-zuo(i,k) - if(zuo(i,k-1).gt.0.)cd(i,k-1)=up_massdetro(i,k-1)/(dz*zuo(i,k-1)) - endif - if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1)) - enddo - do k=maxloc(zuo(i,:),1)+1,ktop(i) - !=> above maximum value zu -> change detrainment - dz=zo_cup(i,k)-zo_cup(i,k-1) - up_massentro(i,k-1)=entr_rate_2d(i,k-1)*dz*zuo(i,k-1) - up_massdetro(i,k-1)=zuo(i,k-1)+up_massentro(i,k-1)-zuo(i,k) - if(up_massdetro(i,k-1).lt.0.)then - up_massdetro(i,k-1)=0. - up_massentro(i,k-1)=zuo(i,k)-zuo(i,k-1) - if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1)) - endif - - if(zuo(i,k-1).gt.0.)cd(i,k-1)=up_massdetro(i,k-1)/(dz*zuo(i,k-1)) - enddo - up_massdetro(i,ktop(i))=zuo(i,ktop(i)) - up_massentro(i,ktop(i))=0. - do k=ktop(i)+1,ktf - cd(i,k)=0. - entr_rate_2d(i,k)=0. - up_massentro(i,k)=0. - up_massdetro(i,k)=0. - enddo - do k=2,ktf-1 - up_massentr (i,k-1)=up_massentro(i,k-1) - up_massdetr (i,k-1)=up_massdetro(i,k-1) - enddo - if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'deep')then - !turn=maxloc(zuo(i,:),1) - !do k=2,turn - ! up_massentru(i,k-1)=up_massentro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) - ! up_massdetru(i,k-1)=up_massdetro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) - !enddo - !do k=turn+1,ktf-1 - do k=2,ktf-1 - up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) - up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) - enddo - else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'shallow')then - do k=2,ktf-1 - up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) - up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) - enddo - else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'mid')then - lambau(i)=0. - do k=2,ktf-1 - up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) - up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) - enddo - endif - - trash=0. - trash2=0. - do k=k22(i)+1,ktop(i) - trash2=trash2+entr_rate_2d(i,k) - enddo - do k=k22(i)+1,kbcon(i) - trash=trash+entr_rate_2d(i,k) - enddo - - endif - enddo - end subroutine get_lateral_massflux -!---meltglac------------------------------------------------- -!------------------------------------------------------------------------------------ - subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer & - ,itf,ktf,its,ite, kts,kte, cumulus ) - implicit none - character *(*), intent (in) :: cumulus - integer ,intent (in ) :: itf,ktf, its,ite, kts,kte - real(kind=kind_phys), intent (in ), dimension(its:ite,kts:kte) :: tn,po_cup - real(kind=kind_phys), intent (inout), dimension(its:ite,kts:kte) :: p_liq_ice,melting_layer - integer , intent (in ), dimension(its:ite) :: ierr - integer :: i,k - real(kind=kind_phys) :: dp - real(kind=kind_phys), dimension(its:ite) :: norm - real(kind=kind_phys), parameter :: t1=276.16 - - ! hli initialize at the very beginning - p_liq_ice (:,:) = 1. - melting_layer(:,:) = 0. - !-- get function of t for partition of total condensate into liq and ice phases. - if(melt_glac .and. cumulus == 'deep') then - do i=its,itf - if(ierr(i).eq.0)then - do k=kts,ktf - - if (tn(i,k) <= t_ice) then - - p_liq_ice(i,k) = 0. - elseif( tn(i,k) > t_ice .and. tn(i,k) < t_0) then - - p_liq_ice(i,k) = ((tn(i,k)-t_ice)/(t_0-t_ice))**2 - else - p_liq_ice(i,k) = 1. - endif - - !melting_layer(i,k) = p_liq_ice(i,k) * (1.-p_liq_ice(i,k)) - enddo - endif - enddo - !go to 655 - !-- define the melting layer (the layer will be between t_0+1 < temp < t_1 - do i=its,itf - if(ierr(i).eq.0)then - do k=kts,ktf - if (tn(i,k) <= t_0+1) then - melting_layer(i,k) = 0. - - elseif( tn(i,k) > t_0+1 .and. tn(i,k) < t1) then - melting_layer(i,k) = ((tn(i,k)-t_0+1)/(t1-t_0+1))**2 - - else - melting_layer(i,k) = 1. - endif - melting_layer(i,k) = melting_layer(i,k)*(1-melting_layer(i,k)) - enddo - endif - enddo - 655 continue - !-normalize vertical integral of melting_layer to 1 - norm(:)=0. - !do k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then - do k=kts,ktf-1 - dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) - norm(i) = norm(i) + melting_layer(i,k)*dp/g - enddo - endif - enddo - do i=its,itf - if(ierr(i).eq.0)then - !print*,"i1=",i,maxval(melting_layer(i,:)),minval(melting_layer(i,:)),norm(i) - melting_layer(i,:)=melting_layer(i,:)/(norm(i)+1.e-6)*(100*(po_cup(i,kts)-po_cup(i,ktf))/g) - endif - !print*,"i2=",i,maxval(melting_layer(i,:)),minval(melting_layer(i,:)),norm(i) - enddo - !--check -! norm(:)=0. -! do k=kts,ktf-1 -! do i=its,itf -! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) -! norm(i) = norm(i) + melting_layer(i,k)*dp/g/(100*(po_cup(i,kts)-po_cup(i,ktf))/g) -! !print*,"n=",i,k,norm(i) -! enddo -! enddo - - else - p_liq_ice (:,:) = 1. - melting_layer(:,:) = 0. - endif - end subroutine get_partition_liq_ice - -!------------------------------------------------------------------------------------ - subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & - ,pwo,edto,pwdo,melting & - ,itf,ktf,its,ite, kts,kte, cumulus ) - implicit none - character *(*), intent (in) :: cumulus - integer ,intent (in ) :: itf,ktf, its,ite, kts,kte - integer ,intent (in ), dimension(its:ite) :: ierr - real(kind=kind_phys) ,intent (in ), dimension(its:ite) :: edto - real(kind=kind_phys) ,intent (in ), dimension(its:ite,kts:kte) :: tn_cup,po_cup,qrco,pwo & - ,pwdo,p_liq_ice,melting_layer - real(kind=kind_phys) ,intent (inout), dimension(its:ite,kts:kte) :: melting - integer :: i,k - real(kind=kind_phys) :: dp - real(kind=kind_phys), dimension(its:ite) :: norm,total_pwo_solid_phase - real(kind=kind_phys), dimension(its:ite,kts:kte) :: pwo_solid_phase,pwo_eff - - if(melt_glac .and. cumulus == 'deep') then - - !-- set melting mixing ratio to zero for columns that do not have deep convection - do i=its,itf - if(ierr(i) > 0) melting(i,:) = 0. - enddo - - !-- now, get it for columns where deep convection is activated - total_pwo_solid_phase(:)=0. - - !do k=kts,ktf - do k=kts,ktf-1 - do i=its,itf - if(ierr(i) /= 0) cycle - dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) - - !-- effective precip (after evaporation by downdraft) - pwo_eff(i,k) = 0.5*(pwo(i,k)+pwo(i,k+1) + edto(i)*(pwdo(i,k)+pwdo(i,k+1))) - - !-- precipitation at solid phase(ice/snow) - pwo_solid_phase(i,k) = (1.-p_liq_ice(i,k))*pwo_eff(i,k) - - !-- integrated precip at solid phase(ice/snow) - total_pwo_solid_phase(i) = total_pwo_solid_phase(i)+pwo_solid_phase(i,k)*dp/g - enddo - enddo - - do k=kts,ktf - do i=its,itf - if(ierr(i) /= 0) cycle - !-- melting profile (kg/kg) - melting(i,k) = melting_layer(i,k)*(total_pwo_solid_phase(i)/(100*(po_cup(i,kts)-po_cup(i,ktf))/g)) - !print*,"mel=",k,melting(i,k),pwo_solid_phase(i,k),po_cup(i,k) - enddo - enddo - -!-- check conservation of total solid phase precip -! norm(:)=0. -! do k=kts,ktf-1 -! do i=its,itf -! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) -! norm(i) = norm(i) + melting(i,k)*dp/g -! enddo -! enddo -! -! do i=its,itf -! print*,"cons=",i,norm(i),total_pwo_solid_phase(i) -! enddo -!-- - - else - !-- no melting allowed in this run - melting (:,:) = 0. - endif - end subroutine get_melting_profile -!---meltglac------------------------------------------------- -!-----srf-08aug2017-----begin - subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, & - kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,klcl,hcot) - implicit none - integer, intent(in) :: its,ite,itf,kts,kte,ktf - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup - real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo - integer, dimension (its:ite),intent (in) :: kstabi,k22,kbcon,kpbl,klcl - integer, dimension (its:ite),intent (inout) :: ierr,ktop - real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot - character *(*), intent (in) :: name - real(kind=kind_phys) :: dz,dh, dbythresh - real(kind=kind_phys) :: dby(kts:kte) - integer :: i,k,ipr,kdefi,kstart,kbegzu,kfinalzu - integer, dimension (its:ite) :: start_level - integer,parameter :: find_ktop_option = 1 !0=original, 1=new - - dbythresh=0.8 !0.95 ! the range of this parameter is 0-1, higher => lower - ! overshoting (cheque aa0 calculation) - ! rainfall is too sensible this parameter - ! for now, keep =1. - if(name == 'shallow'.or. name == 'mid')then - dbythresh=1.0 - endif - ! print*,"================================cumulus=",name; call flush(6) - do i=its,itf - kfinalzu=ktf-2 - ktop(i)=kfinalzu - if(ierr(i).eq.0)then - dby (kts:kte)=0.0 - - start_level(i)=kbcon(i) - !-- hcot below kbcon - hcot(i,kts:start_level(i))=hkbo(i) - - dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1) - dby(start_level(i))=(hcot(i,start_level(i))-heso_cup(i,start_level(i)))*dz - - !print*,'hco1=',start_level(i),kbcon(i),hcot(i,start_level(i))/heso_cup(i,start_level(i)) - - do k=start_level(i)+1,ktf-2 - dz=z_cup(i,k)-z_cup(i,k-1) - - hcot(i,k)=( (1.-0.5*entr_rate_2d(i,k-1)*dz)*hcot(i,k-1) & - +entr_rate_2d(i,k-1)*dz *heo (i,k-1) )/ & - (1.+0.5*entr_rate_2d(i,k-1)*dz) - dby(k)=dby(k-1)+(hcot(i,k)-heso_cup(i,k))*dz - !print*,'hco2=',k,hcot(i,k)/heso_cup(i,k),dby(k),entr_rate_2d(i,k-1) - - enddo - if(find_ktop_option==0) then - do k=maxloc(dby(:),1),ktf-2 - !~ print*,'hco30=',k,dby(k),dbythresh*maxval(dby) - - if(dby(k).lt.dbythresh*maxval(dby))then - kfinalzu = k - 1 - ktop(i) = kfinalzu - !print*,'hco4=',k,kfinalzu,ktop(i),kbcon(i)+1;call flush(6) - go to 412 - endif - enddo - 412 continue - else - do k=start_level(i)+1,ktf-2 - !~ print*,'hco31=',k,dby(k),dbythresh*maxval(dby) - - if(hcot(i,k) < heso_cup(i,k) )then - kfinalzu = k - 1 - ktop(i) = kfinalzu - !print*,'hco40=',k,kfinalzu,ktop(i),kbcon(i)+1;call flush(6) - exit - endif - enddo - endif - if(kfinalzu.le.kbcon(i)+1) ierr(i)=41 - !~ print*,'hco5=',k,kfinalzu,ktop(i),kbcon(i)+1,ierr(i);call flush(6) - ! - endif - enddo - end subroutine get_cloud_top -!------------------------------------------------------------------------------------ - - -end module cu_gf_deep diff --git a/cu_gf_driver.F90 b/cu_gf_driver.F90 deleted file mode 100644 index 88575c53a..000000000 --- a/cu_gf_driver.F90 +++ /dev/null @@ -1,836 +0,0 @@ -! -module cu_gf_driver - - ! DH* TODO: replace constants with arguments to cu_gf_driver_run - use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv - use machine , only: kind_phys - use cu_gf_deep, only: cu_gf_deep_run,neg_check,autoconv,aeroevap - use cu_gf_sh , only: cu_gf_sh_run - - implicit none - - private - - public :: cu_gf_driver_init, cu_gf_driver_run, cu_gf_driver_finalize - -contains - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_cu_gf_driver_init Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------------|--------------------|------------------------------------------|-------|------|-----------|-----------|--------|----------| -!! | mpirank | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | -!! | mpiroot | mpi_root | master MPI-rank | index | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine cu_gf_driver_init(mpirank, mpiroot, errmsg, errflg) - - implicit none - - integer, intent(in) :: mpirank - integer, intent(in) :: mpiroot - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! DH* temporary - if (mpirank==mpiroot) then - write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' - write(0,*) ' --- WARNING --- the CCPP Grell Freitas convection scheme is currently under development, use at your own risk --- WARNING ---' - write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' - end if - ! *DH temporary - - end subroutine cu_gf_driver_init - - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_cu_gf_driver_finalize Argument Table -!! - subroutine cu_gf_driver_finalize() - end subroutine cu_gf_driver_finalize -! -! t2di is temp after advection, but before physics -! t = current temp (t2di + physics up to now) -!=================== -! -!! -!! \section arg_table_cu_gf_driver_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-----------------------------------------------------------|-----------------------------------------------------|---------------|------|-----------|-----------|--------|----------| -!! | tottracer | number_of_total_tracers | number of total tracers | count | 0 | integer | | in | F | -!! | ntrac | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | -!! | garea | cell_area | grid cell area | m2 | 1 | real | kind_phys | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | -!! | cactiv | conv_activity_counter | convective activity memory | none | 1 | integer | | inout | F | -!! | forcet | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | in | F | -!! | forceqv_spechum| moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | in | F | -!! | phil | geopotential | layer geopotential | m2 s-2 | 2 | real | kind_phys | in | F | -!! | raincv | lwe_thickness_of_deep_convective_precipitation_amount | deep convective rainfall amount on physics timestep | m | 1 | real | kind_phys | out | F | -!! | qv_spechum | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | t | air_temperature_updated_by_physics | updated temperature | K | 2 | real | kind_phys | inout | F | -!! | cld1d | cloud_work_function | cloud work function | m2 s-2 | 1 | real | kind_phys | out | F | -!! | us | x_wind_updated_by_physics | updated x-direction wind | m s-1 | 2 | real | kind_phys | inout | F | -!! | vs | y_wind_updated_by_physics | updated y-direction wind | m s-1 | 2 | real | kind_phys | inout | F | -!! | t2di | air_temperature | mid-layer temperature | K | 2 | real | kind_phys | in | F | -!! | w | omega | layer mean vertical velocity | Pa s-1 | 2 | real | kind_phys | in | F | -!! | qv2di_spechum | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!! | p2di | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | psuri | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | -!! | hbot | vertical_index_at_cloud_base | index for cloud base | index | 1 | integer | | out | F | -!! | htop | vertical_index_at_cloud_top | index for cloud top | index | 1 | integer | | out | F | -!! | kcnv | flag_deep_convection | deep convection: 0=no, 1=yes | flag | 1 | integer | | out | F | -!! | xland | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | -!! | hfx2 | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | -!! | qfx2 | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | -!! | clw | convective_transportable_tracers | cloud water and other convective trans. tracers | kg kg-1 | 3 | real | kind_phys | inout | F | -!! | pbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | in | F | -!! | ud_mf | instantaneous_atmosphere_updraft_convective_mass_flux | (updraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | -!! | dd_mf | instantaneous_atmosphere_downdraft_convective_mass_flux | (downdraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | -!! | dt_mf | instantaneous_atmosphere_detrainment_convective_mass_flux | (detrainment mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | -!! | cnvw_moist | convective_cloud_water_mixing_ratio | moist convective cloud water mixing ratio | kg kg-1 | 2 | real | kind_phys | out | F | -!! | cnvc | convective_cloud_cover | convective cloud cover | frac | 2 | real | kind_phys | out | F | -!! | imfshalcnv | flag_for_mass_flux_shallow_convection_scheme | flag for mass-flux shallow convection scheme | flag | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & - forcet,forceqv_spechum,phil,raincv,qv_spechum,t,cld1d, & - us,vs,t2di,w,qv2di_spechum,p2di,psuri, & - hbot,htop,kcnv,xland,hfx2,qfx2,clw, & - pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv,errmsg,errflg) -!------------------------------------------------------------- - implicit none - integer, parameter :: maxiens=1 - integer, parameter :: maxens=1 - integer, parameter :: maxens2=1 - integer, parameter :: maxens3=16 - integer, parameter :: ensdim=16 - integer, parameter :: imid_gf=1 ! testgf2 turn on middle gf conv. - integer, parameter :: ideep=1 - integer, parameter :: ichoice=0 ! 0 2 5 13 8 - !integer, parameter :: ichoicem=5 ! 0 2 5 13 - integer, parameter :: ichoicem=13 ! 0 2 5 13 - integer, parameter :: ichoice_s=3 ! 0 1 2 3 - real(kind=kind_phys), parameter :: aodccn=0.1 - real(kind=kind_phys) :: dts,fpi,fp - integer, parameter :: dicycle=0 ! diurnal cycle flag - integer, parameter :: dicycle_m=0 !- diurnal cycle flag - integer :: ishallow_g3 ! depend on imfshalcnv -!------------------------------------------------------------- - integer :: its,ite, jts,jte, kts,kte - integer, intent(in ) :: im,ix,km,ntrac,tottracer - - real(kind=kind_phys), dimension( ix , km ), intent(in ) :: forcet,forceqv_spechum,w,phil - real(kind=kind_phys), dimension( ix , km ), intent(inout ) :: t,us,vs - real(kind=kind_phys), dimension( ix ) :: rand_mom,rand_vmas - real(kind=kind_phys), dimension( ix,4 ) :: rand_clos - real(kind=kind_phys), dimension( ix , km, 11 ) :: gdc,gdc2 - real(kind=kind_phys), dimension( ix , km ), intent(out ) :: cnvw_moist,cnvc - real(kind=kind_phys), dimension( ix , km,tottracer+2 ), intent(inout ) :: clw - - integer, dimension (im), intent(inout) :: hbot,htop,kcnv - integer, dimension (im), intent(in) :: xland - real(kind=kind_phys), dimension (im), intent(in) :: pbl - integer, dimension (ix) :: tropics -! ruc variable - real(kind=kind_phys), dimension (im) :: hfx2,qfx2,psuri - real(kind=kind_phys), dimension (im,km) :: ud_mf,dd_mf,dt_mf - real(kind=kind_phys), dimension (im), intent(inout) :: raincv,cld1d - real(kind=kind_phys), dimension (ix,km) :: t2di,p2di - ! Specific humidity from FV3 - real(kind=kind_phys), dimension (ix,km), intent(in) :: qv2di_spechum - real(kind=kind_phys), dimension (ix,km), intent(inout) :: qv_spechum - ! Local water vapor mixing ratios and cloud water mixing ratios - real(kind=kind_phys), dimension (ix,km) :: qv2di, qv, forceqv, cnvw - ! - real(kind=kind_phys), dimension( im ),intent(in) :: garea - real(kind=kind_phys), intent(in ) :: dt - integer, intent(in ) :: imfshalcnv - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer, dimension(im),intent(inout) :: cactiv - integer, dimension(im) :: k22_shallow,kbcon_shallow,ktop_shallow - real(kind=kind_phys), dimension(im) :: ht - real(kind=kind_phys), dimension(im) :: dx - - real(kind=kind_phys), dimension (im,km) :: outt,outq,outqc,phh,subm,cupclw,cupclws - real(kind=kind_phys), dimension (im,km) :: dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm - real(kind=kind_phys), dimension (im,km) :: outts,outqs,outqcs,outu,outv,outus,outvs - real(kind=kind_phys), dimension (im,km) :: outtm,outqm,outqcm,submm,cupclwm - real(kind=kind_phys), dimension (im,km) :: cnvwt,cnvwts,cnvwtm - real(kind=kind_phys), dimension (im,km) :: hco,hcdo,zdo,zdd,hcom,hcdom,zdom - real(kind=kind_phys), dimension (km) :: zh - real(kind=kind_phys), dimension (im) :: tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi - real(kind=kind_phys), dimension (im) :: pret,prets,pretm,hexec - real(kind=kind_phys), dimension (im,10) :: forcing,forcing2 - - integer, dimension (im) :: kbcon, ktop,ierr,ierrs,ierrm,kpbli - integer, dimension (im) :: k22s,kbcons,ktops,k22,jmin,jminm - integer, dimension (im) :: kbconm,ktopm,k22m - - integer :: iens,ibeg,iend,jbeg,jend,n - integer :: ibegh,iendh,jbegh,jendh - integer :: ibegc,iendc,jbegc,jendc,kstop - real(kind=kind_phys) :: rho_dryar,temp - real(kind=kind_phys) :: pten,pqen,paph,zrho,pahfs,pqhfl,zkhvfl,pgeoh - - integer, parameter :: ipn = 0 - -! -! basic environmental input includes moisture convergence (mconv) -! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off -! convection for this call only and at that particular gridpoint -! - real(kind=kind_phys), dimension (im,km) :: qcheck,zo,t2d,q2d,po,p2d,rhoi - real(kind=kind_phys), dimension (im,km) :: tn,qo,tshall,qshall,dz8w,omeg - real(kind=kind_phys), dimension (im) :: ccn,z1,psur,cuten,cutens,cutenm - real(kind=kind_phys), dimension (im) :: umean,vmean,pmean - real(kind=kind_phys), dimension (im) :: xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv - - integer :: i,j,k,icldck,ipr,jpr,jpr_deep,ipr_deep - integer :: itf,jtf,ktf,iss,jss,nbegin,nend - integer :: high_resolution - real(kind=kind_phys) :: clwtot,clwtot1,excess,tcrit,tscl_kf,dp,dq,sub_spread,subcenter - real(kind=kind_phys) :: dsubclw,dsubclws,dsubclwm,ztm,ztq,hfm,qfm,rkbcon,rktop !-lxz - real(kind=kind_phys), dimension (im) :: flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep - character*50 :: ierrc(im),ierrcm(im) - character*50 :: ierrcs(im) -! ruc variable -! hfx2 -- sensible heat flux (k m/s), positive upward from sfc -! qfx2 -- latent heat flux (kg/kg m/s), positive upward from sfc -! gf needs them in w/m2. define hfx and qfx after simple unit conversion - real(kind=kind_phys), dimension (im) :: hfx,qfx - real(kind=kind_phys) tem,tem1,tf,tcr,tcrf - - parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) - !parameter (tf=263.16, tcr=273.16, tcrf=1.0/(tcr-tf)) - !parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) - !parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) ! as fim - ! initialize ccpp error handling variables - errmsg = '' - errflg = 0 -! -! Scale specific humidity to dry mixing ratio -! - ! state in before physics - qv2di = qv2di_spechum/(1.0_kind_phys-qv2di_spechum) - ! forcing by dynamics, based on state in - forceqv = forceqv_spechum/(1.0_kind_phys-qv2di_spechum) - ! current state (updated by preceeding physics) - qv = qv_spechum/(1.0_kind_phys-qv_spechum) -! -! -! these should be coming in from outside -! - rand_mom(:) = 0. - rand_vmas(:) = 0. - rand_clos(:,:) = 0. - its=1 - ite=im - jts=1 - jte=1 - kts=1 - kte=km - ktf=kte-1 -! - tropics(:)=0 -! -!> tuning constants for radiation coupling -! - tun_rad_shall(:)=.02 - tun_rad_mid(:)=.15 - tun_rad_deep(:)=.13 - edt(:)=0. - edtm(:)=0. - edtd(:)=0. - zdd(:,:)=0. - flux_tun(:)=5. - ccn(its:ite)=150. - ! - if (imfshalcnv == 3) then - ishallow_g3 = 1 - else - ishallow_g3 = 0 - end if - high_resolution=0 - subcenter=0. - iens=1 -! -! these can be set for debugging -! - ipr=0 - jpr=0 - ipr_deep=0 - jpr_deep= 0 !53322 ! 528196 !0 ! 1136 !0 !421755 !3536 -! -! - ibeg=its - iend=ite - tcrit=258. - - itf=ite - ktf=kte-1 - jtf=jte - ztm=0. - ztq=0. - hfm=0. - qfm=0. - ud_mf =0. - dd_mf =0. - dt_mf =0. - tau_ecmwf(:)=0. -! - j=1 - ht(:)=phil(:,1)/g - do i=its,ite - cld1d(i)=0. - zo(i,:)=phil(i,:)/g - dz8w(i,1)=zo(i,2)-zo(i,1) - zh(1)=0. - kpbli(i)=2 - do k=kts+1,ktf - dz8w(i,k)=zo(i,k+1)-zo(i,k) - enddo - do k=kts+1,ktf - zh(k)=zh(k-1)+dz8w(i,k-1) - if(zh(k).gt.pbl(i))then - kpbli(i)=max(2,k) - exit - endif - enddo - enddo - - do i= its,itf - forcing(i,:)=0. - forcing2(i,:)=0. - ccn(i)=100. - hbot(i) =kte - htop(i) =kts - raincv(i)=0. - xlandi(i)=real(xland(i)) -! if(abs(xlandi(i)-1.).le.1.e-3) tun_rad_shall(i)=.15 -! if(abs(xlandi(i)-1.).le.1.e-3) flux_tun(i)=1.5 - enddo - do i= its,itf - mconv(i)=0. - enddo - do k=kts,kte - do i= its,itf - omeg(i,k)=0. - zu(i,k)=0. - zum(i,k)=0. - zus(i,k)=0. - zd(i,k)=0. - zdm(i,k)=0. - enddo - enddo - - psur(:)=0.01*psuri(:) - do i=its,itf - ter11(i)=max(0.,ht(i)) - enddo - do k=kts,kte - do i=its,ite - cnvw(i,k)=0. - cnvc(i,k)=0. - gdc(i,k,1)=0. - gdc(i,k,2)=0. - gdc(i,k,3)=0. - gdc(i,k,4)=0. - gdc(i,k,7)=0. - gdc(i,k,8)=0. - gdc(i,k,9)=0. - gdc(i,k,10)=0. - gdc2(i,k,1)=0. - enddo - enddo - ierr(:)=0 - ierrm(:)=0 - ierrs(:)=0 - cuten(:)=0. - cutenm(:)=0. - cutens(:)=0. - ierrc(:)=" " - - kbcon(:)=0 - kbcons(:)=0 - kbconm(:)=0 - - ktop(:)=0 - ktops(:)=0 - ktopm(:)=0 - - xmb(:)=0. - xmb_dumm(:)=0. - xmbm(:)=0. - xmbs(:)=0. - xmbs2(:)=0. - - k22s(:)=0 - k22m(:)=0 - k22(:)=0 - - jmin(:)=0 - jminm(:)=0 - - pret(:)=0. - prets(:)=0. - pretm(:)=0. - - umean(:)=0. - vmean(:)=0. - pmean(:)=0. - - cupclw(:,:)=0. - cupclwm(:,:)=0. - cupclws(:,:)=0. - - cnvwt(:,:)=0. - cnvwts(:,:)=0. - - hco(:,:)=0. - hcom(:,:)=0. - hcdo(:,:)=0. - hcdom(:,:)=0. - - outt(:,:)=0. - outts(:,:)=0. - outtm(:,:)=0. - - outu(:,:)=0. - outus(:,:)=0. - outum(:,:)=0. - - outv(:,:)=0. - outvs(:,:)=0. - outvm(:,:)=0. - - outq(:,:)=0. - outqs(:,:)=0. - outqm(:,:)=0. - - outqc(:,:)=0. - outqcs(:,:)=0. - outqcm(:,:)=0. - - subm(:,:)=0. - dhdt(:,:)=0. - - do k=kts,ktf - do i=its,itf - p2d(i,k)=0.01*p2di(i,k) - po(i,k)=p2d(i,k) !*.01 - rhoi(i,k) = 100.*p2d(i,k)/(287.04*(t2di(i,k)*(1.+0.608*qv2di(i,k)))) - qcheck(i,k)=qv(i,k) - tn(i,k)=t(i,k)!+forcet(i,k)*dt - qo(i,k)=max(1.e-16,qv(i,k))!+forceqv(i,k)*dt - t2d(i,k)=t2di(i,k)-forcet(i,k)*dt - q2d(i,k)=max(1.e-16,qv2di(i,k)-forceqv(i,k)*dt) - if(qo(i,k).lt.1.e-16)qo(i,k)=1.e-16 - tshall(i,k)=t2d(i,k) - qshall(i,k)=q2d(i,k) - enddo - enddo -123 format(1x,i2,1x,2(1x,f8.0),1x,2(1x,f8.3),3(1x,e13.5)) - do i=its,itf - do k=kts,kpbli(i) - tshall(i,k)=t(i,k) - qshall(i,k)=max(1.e-16,qv(i,k)) - enddo - enddo -! -! converting hfx2 and qfx2 to w/m2 -! hfx=cp*rho*hfx2 -! qfx=xlv*qfx2 - do i=its,itf - hfx(i)=hfx2(i)*cp*rhoi(i,1) - qfx(i)=qfx2(i)*xlv*rhoi(i,1) - dx(i) = sqrt(garea(i)) - enddo -! - do i=its,itf - do k=kts,kpbli(i) - tn(i,k)=t(i,k) - qo(i,k)=max(1.e-16,qv(i,k)) - enddo - enddo - nbegin=0 - nend=0 - do i=its,itf - do k=kts,kpbli(i) - dhdt(i,k)=cp*(forcet(i,k)+(t(i,k)-t2di(i,k))/dt) + & - xlv*(forceqv(i,k)+(qv(i,k)-qv2di(i,k))/dt) -! tshall(i,k)=t(i,k) -! qshall(i,k)=qv(i,k) - enddo - enddo - - do k= kts+1,ktf-1 - do i = its,itf - if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then - dp=-.5*(p2d(i,k+1)-p2d(i,k-1)) - umean(i)=umean(i)+us(i,k)*dp - vmean(i)=vmean(i)+vs(i,k)*dp - pmean(i)=pmean(i)+dp - endif - enddo - enddo - do k=kts,ktf-1 - do i = its,itf - omeg(i,k)= w(i,k) !-g*rhoi(i,k)*w(i,k) -! dq=(q2d(i,k+1)-q2d(i,k)) -! mconv(i)=mconv(i)+omeg(i,k)*dq/g - enddo - enddo - do i = its,itf - if(mconv(i).lt.0.)mconv(i)=0. - enddo -! -!---- call cumulus parameterization -! - if(ishallow_g3.eq.1)then -! - do i=its,ite - ierrs(i)=0 - ierrm(i)=0 - enddo -! -!> if ishallow_g3=1, call shallow: cup_gf_sh() -! - call cu_gf_sh_run (us,vs, & -! input variables, must be supplied - zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli, & - rhoi,hfx,qfx,xlandi,ichoice_s,tcrit,dt, & -! input variables. ierr should be initialized to zero or larger than zero for -! turning off shallow convection for grid points - zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & -! output tendencies - outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & -! dimesnional variables - itf,ktf,its,ite, kts,kte,ipr,tropics) - - - do i=its,itf - if(xmbs(i).gt.0.)cutens(i)=1. - enddo - call neg_check('shallow',ipn,dt,qcheck,outqs,outts,outus,outvs, & - outqcs,prets,its,ite,kts,kte,itf,ktf,ktops) - endif - - ipr=0 - jpr_deep=0 !340765 -!> if imid_gf=1, call cup_gf() - if(imid_gf == 1)then - call cu_gf_deep_run( & - itf,ktf,its,ite, kts,kte & - ,dicycle_m & - ,ichoicem & - ,ipr & - ,ccn & - ,dt & - ,imid_gf & - ,kpbli & - ,dhdt & - ,xlandi & - - ,zo & - ,forcing2 & - ,t2d & - ,q2d & - ,ter11 & - ,tshall & - ,qshall & - ,p2d & - ,psur & - ,us & - ,vs & - ,rhoi & - ,hfx & - ,qfx & - ,dx & ! dx(im) - ,mconv & - ,omeg & - - ,cactiv & - ,cnvwtm & - ,zum & - ,zdm & ! hli - ,zdd & - ,edtm & - ,edtd & ! hli - ,xmbm & - ,xmb_dumm & - ,xmbs & - ,pretm & - ,outum & - ,outvm & - ,outtm & - ,outqm & - ,outqcm & - ,kbconm & - ,ktopm & - ,cupclwm & - ,ierrm & - ,ierrcm & -! the following should be set to zero if not available - ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist - ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist - ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist - ,0 & ! flag to what you want perturbed - ! 1 = momentum transport - ! 2 = normalized vertical mass flux profile - ! 3 = closures - ! more is possible, talk to developer or - ! implement yourself. pattern is expected to be - ! betwee -1 and +1 -#if ( wrf_dfi_radar == 1 ) - ,do_capsuppress,cap_suppress_j & -#endif - ,k22m & - ,jminm,tropics) - - do i=its,itf - do k=kts,ktf - qcheck(i,k)=qv(i,k) +outqs(i,k)*dt - enddo - enddo - call neg_check('mid',ipn,dt,qcheck,outqm,outtm,outum,outvm, & - outqcm,pretm,its,ite,kts,kte,itf,ktf,ktopm) - endif -!> if ideep=1, call cup_gf() - if(ideep.eq.1)then - call cu_gf_deep_run( & - itf,ktf,its,ite, kts,kte & - - ,dicycle & - ,ichoice & - ,ipr & - ,ccn & - ,dt & - ,0 & - - ,kpbli & - ,dhdt & - ,xlandi & - - ,zo & - ,forcing & - ,t2d & - ,q2d & - ,ter11 & - ,tn & - ,qo & - ,p2d & - ,psur & - ,us & - ,vs & - ,rhoi & - ,hfx & - ,qfx & - ,dx & !dx(im) - ,mconv & - ,omeg & - - ,cactiv & - ,cnvwt & - ,zu & - ,zd & - ,zdm & ! hli - ,edt & - ,edtm & ! hli - ,xmb & - ,xmbm & - ,xmbs & - ,pret & - ,outu & - ,outv & - ,outt & - ,outq & - ,outqc & - ,kbcon & - ,ktop & - ,cupclw & - ,ierr & - ,ierrc & -! the following should be set to zero if not available - ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist - ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist - ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist - ,0 & ! flag to what you want perturbed - ! 1 = momentum transport - ! 2 = normalized vertical mass flux profile - ! 3 = closures - ! more is possible, talk to developer or - ! implement yourself. pattern is expected to be - ! betwee -1 and +1 -#if ( wrf_dfi_radar == 1 ) - ,do_capsuppress,cap_suppress_j & -#endif - ,k22 & - ,jmin,tropics) - - jpr=0 - ipr=0 - do i=its,itf - do k=kts,ktf - qcheck(i,k)=qv(i,k) +(outqs(i,k)+outqm(i,k))*dt - enddo - enddo - call neg_check('deep',ipn,dt,qcheck,outq,outt,outu,outv, & - outqc,pret,its,ite,kts,kte,itf,ktf,ktop) -! - endif -! do i=its,itf -! kcnv(i)=0 -! if(pret(i).gt.0.)then -! cuten(i)=1. -! kcnv(i)= 1 !jmin(i) -! else -! kbcon(i)=0 -! ktop(i)=0 -! cuten(i)=0. -! endif ! pret > 0 -! if(pretm(i).gt.0.)then -! kcnv(i)= 1 !jmin(i) -! cutenm(i)=1. -! else -! kbconm(i)=0 -! ktopm(i)=0 -! cutenm(i)=0. -! endif ! pret > 0 -! enddo - do i=its,itf - kcnv(i)=0 - if(pretm(i).gt.0.)then - kcnv(i)= 1 !jmin(i) - cutenm(i)=1. - else - kbconm(i)=0 - ktopm(i)=0 - cutenm(i)=0. - endif ! pret > 0 - - if(pret(i).gt.0.)then - cuten(i)=1. - cutenm(i)=0. - pretm(i)=0. - kcnv(i)= 1 !jmin(i) - ktopm(i)=0 - kbconm(i)=0 - else - kbcon(i)=0 - ktop(i)=0 - cuten(i)=0. - endif ! pret > 0 - enddo -! - do i=its,itf - kstop=kts - if(ktopm(i).gt.kts .or. ktop(i).gt.kts)kstop=max(ktopm(i),ktop(i)) - if(ktops(i).gt.kts)kstop=max(kstop,ktops(i)) - - if(kstop.gt.2)then - htop(i)=kstop - if(kbcon(i).gt.2 .or. kbconm(i).gt.2)then - hbot(i)=max(kbconm(i),kbcon(i)) !jmin(i) - endif -!kbcon(i) - do k=kts,kstop - cnvc(i,k) = 0.04 * log(1. + 675. * zu(i,k) * xmb(i)) + & - 0.04 * log(1. + 675. * zum(i,k) * xmbm(i)) + & - 0.04 * log(1. + 675. * zus(i,k) * xmbs(i)) - cnvc(i,k) = min(cnvc(i,k), 0.6) - cnvc(i,k) = max(cnvc(i,k), 0.0) - cnvw(i,k)=cnvwt(i,k)*xmb(i)*dt+cnvwts(i,k)*xmbs(i)*dt+cnvwtm(i,k)*xmbm(i)*dt - ud_mf(i,k)=cuten(i)*zu(i,k)*xmb(i)*dt - dd_mf(i,k)=cuten(i)*zd(i,k)*edt(i)*xmb(i)*dt - t(i,k)=t(i,k)+dt*(cutens(i)*outts(i,k)+cutenm(i)*outtm(i,k)+outt(i,k)*cuten(i)) - qv(i,k)=max(1.e-16,qv(i,k)+dt*(cutens(i)*outqs(i,k)+cutenm(i)*outqm(i,k)+outq(i,k)*cuten(i))) - gdc(i,k,7)=sqrt(us(i,k)**2 +vs(i,k)**2) - us(i,k)=us(i,k)+outu(i,k)*cuten(i)*dt +outum(i,k)*cutenm(i)*dt +outus(i,k)*cutens(i)*dt - vs(i,k)=vs(i,k)+outv(i,k)*cuten(i)*dt +outvm(i,k)*cutenm(i)*dt +outvs(i,k)*cutens(i)*dt - - gdc(i,k,1)= max(0.,tun_rad_shall(i)*cupclws(i,k)*cutens(i)) ! my mod - gdc2(i,k,1)=max(0.,tun_rad_deep(i)*(cupclwm(i,k)*cutenm(i)+cupclw(i,k)*cuten(i))) - gdc(i,k,2)=(outt(i,k))*86400. - gdc(i,k,3)=(outtm(i,k))*86400. - gdc(i,k,4)=(outts(i,k))*86400. - gdc(i,k,7)=-(gdc(i,k,7)-sqrt(us(i,k)**2 +vs(i,k)**2))/dt - !gdc(i,k,8)=(outq(i,k))*86400.*xlv/cp - gdc(i,k,8)=(outqm(i,k)+outqs(i,k)+outq(i,k))*86400.*xlv/cp - gdc(i,k,9)=gdc(i,k,2)+gdc(i,k,3)+gdc(i,k,4) -! -!> calculate subsidence effect on clw -! - dsubclw=0. - dsubclwm=0. - dsubclws=0. - dp=100.*(p2d(i,k)-p2d(i,k+1)) - if (clw(i,k,2) .gt. -999.0 .and. clw(i,k+1,2) .gt. -999.0 )then - clwtot = clw(i,k,1) + clw(i,k,2) - clwtot1= clw(i,k+1,1) + clw(i,k+1,2) - dsubclw=((-edt(i)*zd(i,k+1)+zu(i,k+1))*clwtot1 & - -(-edt(i)*zd(i,k) +zu(i,k)) *clwtot )*g/dp - dsubclwm=((-edtm(i)*zdm(i,k+1)+zum(i,k+1))*clwtot1 & - -(-edtm(i)*zdm(i,k) +zum(i,k)) *clwtot )*g/dp - dsubclws=(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp - dsubclw=dsubclw+(zu(i,k+1)*clwtot1-zu(i,k)*clwtot)*g/dp - dsubclwm=dsubclwm+(zum(i,k+1)*clwtot1-zum(i,k)*clwtot)*g/dp - dsubclws=dsubclws+(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp - endif - tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & - +outqcm(i,k)*cutenm(i) & -! +dsubclw*xmb(i)+dsubclws*xmbs(i)+dsubclwm*xmbm(i) & - ) - tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) - if (clw(i,k,2) .gt. -999.0) then - clw(i,k,1) = max(0.,clw(i,k,1) + tem * tem1) ! ice - clw(i,k,2) = max(0.,clw(i,k,2) + tem *(1.0-tem1)) ! water - else - clw(i,k,1) = max(0.,clw(i,k,1) + tem) - endif - enddo ! kstop loop - - gdc(i,1,10)=forcing(i,1) - gdc(i,2,10)=forcing(i,2) - gdc(i,3,10)=forcing(i,3) - gdc(i,4,10)=forcing(i,4) - gdc(i,5,10)=forcing(i,5) - gdc(i,6,10)=forcing(i,6) - gdc(i,7,10)=forcing(i,7) - gdc(i,8,10)=forcing(i,8) - gdc(i,10,10)=xmb(i) - gdc(i,11,10)=xmbm(i) - gdc(i,12,10)=xmbs(i) - gdc(i,13,10)=hfx(i) - gdc(i,15,10)=qfx(i) - gdc(i,16,10)=pret(i)*3600. - if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) - endif ! kstop if - enddo - - do i=its,itf - if(pret(i).gt.0.)then - cactiv(i)=1 - raincv(i)=.001*(cutenm(i)*pretm(i)+cutens(i)*prets(i)+cuten(i)*pret(i))*dt - else - cactiv(i)=0 - if(pretm(i).gt.0)raincv(i)=.001*cutenm(i)*pretm(i)*dt - endif ! pret > 0 - enddo - 100 continue -! -! Scale dry mixing ratios for water wapor and cloud water to specific humidy / moist mixing ratios -! - qv_spechum = qv/(1.0_kind_phys+qv) - cnvw_moist = cnvw/(1.0_kind_phys+qv) -! - end subroutine cu_gf_driver_run -end module cu_gf_driver diff --git a/cu_gf_sh.F90 b/cu_gf_sh.F90 deleted file mode 100644 index 173de662e..000000000 --- a/cu_gf_sh.F90 +++ /dev/null @@ -1,937 +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 cu_gf_sh - use machine , only : kind_phys - !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 - real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 - real(kind=kind_phys), parameter:: g =9.81 - real(kind=kind_phys), parameter:: cp =1004. - real(kind=kind_phys), parameter:: xlv=2.5e6 - real(kind=kind_phys), parameter:: r_v=461. - real(kind=kind_phys), parameter:: c0_shal=.001 - real(kind=kind_phys), parameter:: fluxtune=1.5 - -contains - - subroutine cu_gf_sh_run ( & -! input variables, must be supplied - us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & - hfx,qfx,xland,ichoice,tcrit,dtime, & -! input variables. ierr should be initialized to zero or larger than zero for -! turning off shallow convection for grid points - zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & -! output tendencies - outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & -! dimesnional variables - itf,ktf,its,ite, kts,kte,ipr,tropics) -! -! this module needs some subroutines from gf_deep -! - use cu_gf_deep,only:cup_env,cup_env_clev,get_cloud_bc,cup_minimi, & - get_inversion_layers,rates_up_pdf,get_cloud_bc, & - cup_up_aa0,cup_kbcon,get_lateral_massflux - implicit none - integer & - ,intent (in ) :: & - itf,ktf, & - its,ite, kts,kte,ipr - logical :: make_calc_for_xk = .true. - integer, intent (in ) :: & - ichoice - ! - ! - ! - ! outtem = output temp tendency (per s) - ! outq = output q tendency (per s) - ! outqc = output qc tendency (per s) - ! pre = output precip - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (inout ) :: & - cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv - real(kind=kind_phys), dimension (its:ite) & - ,intent (out ) :: & - xmb_out - integer, dimension (its:ite) & - ,intent (inout ) :: & - ierr - integer, dimension (its:ite) & - ,intent (out ) :: & - kbcon,ktop,k22 - integer, dimension (its:ite) & - ,intent (in ) :: & - kpbl,tropics - ! - ! basic environmental input includes a flag (ierr) to turn off - ! convection for this call only and at that particular gridpoint - ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (in ) :: & - t,po,tn,dhdt,rho,us,vs - real(kind=kind_phys), dimension (its:ite,kts:kte) & - ,intent (inout) :: & - q,qo - real(kind=kind_phys), dimension (its:ite) & - ,intent (in ) :: & - xland,z1,psur,hfx,qfx - - real(kind=kind_phys) & - ,intent (in ) :: & - dtime,tcrit - ! - !***************** the following are your basic environmental - ! variables. they carry a "_cup" if they are - ! on model cloud levels (staggered). they carry - ! an "o"-ending (z becomes zo), if they are the forced - ! variables. - ! - ! z = heights of model levels - ! q = environmental mixing ratio - ! qes = environmental saturation mixing ratio - ! t = environmental temp - ! p = environmental pressure - ! he = environmental moist static energy - ! hes = environmental saturation moist static energy - ! z_cup = heights of model cloud levels - ! q_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! t_cup = temperature (kelvin) on model cloud levels - ! p_cup = environmental pressure - ! he_cup = moist static energy on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! gamma_cup = gamma on model cloud levels - ! dby = buoancy term - ! entr = entrainment rate - ! bu = buoancy term - ! gamma_cup = gamma on model cloud levels - ! qrch = saturation q in cloud - ! pwev = total normalized integrated evaoprate (i2) - ! z1 = terrain elevation - ! psur = surface pressure - ! zu = updraft normalized mass flux - ! kbcon = lfc of parcel from k22 - ! k22 = updraft originating level - ! ichoice = flag if only want one closure (usually set to zero!) - ! dby = buoancy term - ! ktop = cloud top (output) - ! xmb = total base mass flux - ! hc = cloud moist static energy - ! hkb = moist static energy at originating level - - real(kind=kind_phys), dimension (its:ite,kts:kte) :: & - entr_rate_2d,he,hes,qes,z, & - heo,heso,qeso,zo, & - xhe,xhes,xqes,xz,xt,xq, & - qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & - qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup, & - tn_cup, & - xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & - xt_cup,dby,hc,zu, & - dbyo,qco,pwo,hco,qrco, & - dbyt,xdby,xhc,xzu, & - - ! cd = detrainment function for updraft - ! dellat = change of temperature per unit mass flux of cloud ensemble - ! dellaq = change of q per unit mass flux of cloud ensemble - ! dellaqc = change of qc per unit mass flux of cloud ensemble - - cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup - - ! aa0 cloud work function for downdraft - ! aa0 = cloud work function without forcing effects - ! aa1 = cloud work function with forcing effects - ! xaa0 = cloud work function with cloud effects (ensemble dependent) - - real(kind=kind_phys), dimension (its:ite) :: & - zws,ztexec,zqexec,pre,aa1,aa0,xaa0,hkb, & - flux_tun,hkbo,xhkb, & - rand_vmas,xmbmax,xmb, & - cap_max,entr_rate, & - cap_max_increment,lambau - integer, dimension (its:ite) :: & - kstabi,xland1,kbmax,ktopx - - integer :: & - kstart,i,k,ki - real(kind=kind_phys) :: & - dz,mbdt,zkbmax, & - cap_maxs,trash,trash2,frh - - real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas - - real(kind=kind_phys) xff_shal(3),blqe,xkshal - character*50 :: ierrc(its:ite) - real(kind=kind_phys), dimension (its:ite,kts:kte) :: & - up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru - real(kind=kind_phys) :: c_up,x_add,qaver,dts,fp,fpi - real(kind=kind_phys), dimension (its:ite,kts:kte) :: c1d,dtempdz - integer, dimension (its:ite,kts:kte) :: k_inv_layers - integer, dimension (its:ite) :: start_level, pmin_lev - start_level(:)=0 - rand_vmas(:)=0. - flux_tun=fluxtune - lambau(:)=2. - c1d(:,:)=0. - do i=its,itf - xland1(i)=int(xland(i)+.001) ! 1. - ktopx(i)=0 - if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then - xland1(i)=0 -! ierr(i)=100 - endif - pre(i)=0. - xmb_out(i)=0. - cap_max_increment(i)=25. - ierrc(i)=" " - entr_rate(i) = 1.e-3 !9.e-5 ! 1.75e-3 ! 1.2e-3 ! .2/50. - enddo -! -!--- initial entrainment rate (these may be changed later on in the -!--- program -! - -! -!--- initial detrainmentrates -! - do k=kts,ktf - do i=its,itf - up_massentro(i,k)=0. - up_massdetro(i,k)=0. - up_massentru(i,k)=0. - up_massdetru(i,k)=0. - z(i,k)=zo(i,k) - xz(i,k)=zo(i,k) - qrco(i,k)=0. - pwo(i,k)=0. - cd(i,k)=.1*entr_rate(i) - dellaqc(i,k)=0. - cupclw(i,k)=0. - enddo - enddo -! -!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft -! -!--- minimum depth (m), clouds must have -! -! -!--- maximum depth (mb) of capping -!--- inversion (larger cap = no convection) -! - cap_maxs=175. - do i=its,itf - kbmax(i)=1 - aa0(i)=0. - aa1(i)=0. - enddo - do i=its,itf - cap_max(i)=cap_maxs - ztexec(i) = 0. - zqexec(i) = 0. - zws(i) = 0. - enddo - do i=its,itf - !- buoyancy flux (h+le) - buo_flux= (hfx(i)/cp+0.608*t(i,1)*qfx(i)/xlv)/rho(i,1) - pgeoh = zo(i,2)*g - !-convective-scale velocity w* - zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,2)*g/t(i,1)) - if(zws(i) > tiny(pgeoh)) then - !-convective-scale velocity w* - zws(i) = 1.2*zws(i)**.3333 - !- temperature excess - ztexec(i) = max(flux_tun(i)*hfx(i)/(rho(i,1)*zws(i)*cp),0.0) - !- moisture excess - zqexec(i) = max(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.) - endif - !- zws for shallow convection closure (grant 2001) - !- height of the pbl - zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i))) - zws(i) = 1.2*zws(i)**.3333 - zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct - - enddo - -! -!--- max height(m) above ground where updraft air can originate -! - zkbmax=3000. -! -!--- calculate moist static energy, heights, qes -! - call cup_env(z,qes,he,hes,t,q,po,z1, & - psur,ierr,tcrit,-1, & - itf,ktf, & - its,ite, kts,kte) - call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, & - psur,ierr,tcrit,-1, & - itf,ktf, & - its,ite, kts,kte) - -! -!--- environmental values on cloud levels -! - call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, & - hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & - ierr,z1, & - itf,ktf, & - its,ite, kts,kte) - call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, & - heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur, & - ierr,z1, & - itf,ktf, & - its,ite, kts,kte) - do i=its,itf - if(ierr(i).eq.0)then - u_cup(i,kts)=us(i,kts) - v_cup(i,kts)=vs(i,kts) - do k=kts+1,ktf - u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) - v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) - enddo - endif - enddo - - do i=its,itf - if(ierr(i).eq.0)then -! - do k=kts,ktf - if(zo_cup(i,k).gt.zkbmax+z1(i))then - kbmax(i)=k - go to 25 - endif - enddo - 25 continue -! - kbmax(i)=min(kbmax(i),ktf/2) - endif - enddo - -! -! -! -!------- determine level with highest moist static energy content - k22 -! - do 36 i=its,itf - if(kpbl(i).gt.3)cap_max(i)=po_cup(i,kpbl(i)) - if(ierr(i) == 0)then - k22(i)=maxloc(heo_cup(i,2:kbmax(i)),1) - k22(i)=max(2,k22(i)) - if(k22(i).gt.kbmax(i))then - ierr(i)=2 - ierrc(i)="could not find k22" - ktop(i)=0 - k22(i)=0 - kbcon(i)=0 - endif - endif - 36 continue -! -!--- determine the level of convective cloud base - kbcon -! - do i=its,itf - if(ierr(i).eq.0)then - x_add = xlv*zqexec(i)+cp*ztexec(i) - call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) - call get_cloud_bc(kte,heo_cup(i,1:kte),hkbo(i),k22(i),x_add) - endif ! ierr - enddo - -!joe-georg and saulo's new idea: - do i=its,itf - do k=kts,ktf - dbyo(i,k)= 0. !hkbo(i)-heso_cup(i,k) - enddo - enddo - - - call cup_kbcon(ierrc,cap_max_increment,5,k22,kbcon,heo_cup,heso_cup, & - hkbo,ierr,kbmax,po_cup,cap_max, & - ztexec,zqexec, & - 0,itf,ktf, & - its,ite, kts,kte, & - z_cup,entr_rate,heo,0) -!--- get inversion layers for cloud tops - call cup_minimi(heso_cup,kbcon,kbmax,kstabi,ierr, & - itf,ktf, & - its,ite, kts,kte) -! - call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers,& - kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) -! -! - do i=its,itf - entr_rate_2d(i,:)=entr_rate(i) - if(ierr(i) == 0)then - start_level(i)=k22(i) - x_add = xlv*zqexec(i)+cp*ztexec(i) - call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) - if(kbcon(i).gt.ktf-4)then - ierr(i)=231 - endif - do k=kts,ktf - frh = 2.*min(qo_cup(i,k)/qeso_cup(i,k),1.) - entr_rate_2d(i,k)=entr_rate(i) !*(2.3-frh) - cd(i,k)=.1*entr_rate_2d(i,k) - enddo -! -! first estimate for shallow convection -! - ktop(i)=1 - kstart=kpbl(i) - if(kpbl(i).lt.5)kstart=kbcon(i) -! if(k_inv_layers(i,1).gt.0)then -!! ktop(i)=min(k_inv_layers(i,1),k_inv_layers(i,2)) - if(k_inv_layers(i,1).gt.0 .and. & - (po_cup(i,kstart)-po_cup(i,k_inv_layers(i,1))).lt.200.)then - ktop(i)=k_inv_layers(i,1) - else - do k=kbcon(i)+1,ktf - if((po_cup(i,kstart)-po_cup(i,k)).gt.200.)then - ktop(i)=k - exit - endif - enddo - endif - endif - enddo -! get normalized mass flux profile - call rates_up_pdf(rand_vmas,ipr,'shallow',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & - xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopx,kbcon,pmin_lev) - do i=its,itf - if(ierr(i).eq.0)then -! do k=maxloc(zuo(i,:),1),1,-1 ! ktop(i)-1,1,-1 -! if(zuo(i,k).lt.1.e-6)then -! k22(i)=k+1 -! start_level(i)=k22(i) -! exit -! endif -! enddo - if(k22(i).gt.1)then - do k=1,k22(i)-1 - zuo(i,k)=0. - zu (i,k)=0. - xzu(i,k)=0. - enddo - endif - do k=maxloc(zuo(i,:),1),ktop(i) - if(zuo(i,k).lt.1.e-6)then - ktop(i)=k-1 - exit - endif - enddo - do k=k22(i),ktop(i) - xzu(i,k)= zuo(i,k) - zu(i,k)= zuo(i,k) - enddo - do k=ktop(i)+1,ktf - zuo(i,k)=0. - zu (i,k)=0. - xzu(i,k)=0. - enddo - k22(i)=max(2,k22(i)) - endif - enddo -! -! calculate mass entrainment and detrainment -! - call get_lateral_massflux(itf,ktf, its,ite, kts,kte & - ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & - ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,'shallow',kbcon,k22,up_massentru,up_massdetru,lambau) - - do k=kts,ktf - do i=its,itf - hc(i,k)=0. - qco(i,k)=0. - qrco(i,k)=0. - dby(i,k)=0. - hco(i,k)=0. - dbyo(i,k)=0. - enddo - enddo - do i=its,itf - if(ierr(i) /= 0) cycle - do k=1,start_level(i) - uc(i,k)=u_cup(i,k) - vc(i,k)=v_cup(i,k) - enddo - do k=1,start_level(i)-1 - hc(i,k)=he_cup(i,k) - hco(i,k)=heo_cup(i,k) - enddo - k=start_level(i) - hc(i,k)=hkb(i) - hco(i,k)=hkbo(i) - enddo -! -! - do 42 i=its,itf - dbyt(i,:)=0. - if(ierr(i) /= 0) cycle - do k=start_level(i)+1,ktop(i) - hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & - up_massentr(i,k-1)*he(i,k-1)) / & - (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) - uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*uc(i,k-1)+ & - up_massentr(i,k-1)*us(i,k-1)) / & - (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) - vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*vc(i,k-1)+ & - up_massentr(i,k-1)*vs(i,k-1))/ & - (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) - dby(i,k)=max(0.,hc(i,k)-hes_cup(i,k)) - hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & - up_massentro(i,k-1)*heo(i,k-1)) / & - (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) - dbyo(i,k)=hco(i,k)-heso_cup(i,k) - dz=zo_cup(i,k+1)-zo_cup(i,k) - if(k.ge.kbcon(i))dbyt(i,k)=dbyt(i,k-1)+dbyo(i,k)*dz - enddo - ki=maxloc(dbyt(i,:),1) - if(ktop(i).gt.ki+1)then - ktop(i)=ki+1 - zuo(i,ktop(i)+1:ktf)=0. - zu(i,ktop(i)+1:ktf)=0. - cd(i,ktop(i)+1:ktf)=0. - up_massdetro(i,ktop(i))=zuo(i,ktop(i)) -! up_massentro(i,ktop(i))=0. - up_massentro(i,ktop(i):ktf)=0. - up_massdetro(i,ktop(i)+1:ktf)=0. - entr_rate_2d(i,ktop(i)+1:ktf)=0. - -! ierr(i)=423 - endif - - if(ktop(i).lt.kbcon(i)+1)then - ierr(i)=5 - ierrc(i)='ktop is less than kbcon+1' - go to 42 - endif - if(ktop(i).gt.ktf-2)then - ierr(i)=5 - ierrc(i)="ktop is larger than ktf-2" - go to 42 - endif -! - call get_cloud_bc(kte,qo_cup (i,1:kte),qaver,k22(i)) - qaver = qaver + zqexec(i) - do k=1,start_level(i)-1 - qco (i,k)= qo_cup(i,k) - enddo - k=start_level(i) - qco (i,k)= qaver -! - do k=start_level(i)+1,ktop(i) - trash=qeso_cup(i,k)+(1./xlv)*(gammao_cup(i,k) & - /(1.+gammao_cup(i,k)))*dbyo(i,k) - !- total water liq+vapour - trash2 = qco(i,k-1) ! +qrco(i,k-1) - qco (i,k)= (trash2* ( zuo(i,k-1)-0.5*up_massdetr(i,k-1)) + & - up_massentr(i,k-1)*qo(i,k-1)) / & - (zuo(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) - - if(qco(i,k)>=trash ) then - dz=z_cup(i,k)-z_cup(i,k-1) - ! cloud liquid water -! qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) -! qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1_shal)*dz) - qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) - c1d(i,k-1)=10.*up_massdetr(i,k-1)*.5*(qrco(i,k-1)+qrco(i,k)) - qrco(i,k)= qrco(i,k)-c1d(i,k-1)*dz*qrco(i,k) - if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 - qrco(i,k)=0. - c1d(i,k-1)=1./dz - endif - pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) - ! cloud water vapor - qco (i,k)= trash+qrco(i,k) - - else - qrco(i,k)= 0.0 - endif - cupclw(i,k)=qrco(i,k) - enddo - trash=0. - trash2=0. - do k=k22(i)+1,ktop(i) - dp=100.*(po_cup(i,k)-po_cup(i,k+1)) - cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp - trash2=trash2+entr_rate_2d(i,k) - qco(i,k)=qco(i,k)-qrco(i,k) - enddo - do k=k22(i)+1,max(kbcon(i),k22(i)+1) - trash=trash+entr_rate_2d(i,k) - enddo - do k=ktop(i)+1,ktf-1 - hc (i,k)=hes_cup (i,k) - hco (i,k)=heso_cup(i,k) - qco (i,k)=qeso_cup(i,k) - uc(i,k)=u_cup(i,k) - vc(i,k)=v_cup(i,k) - qrco(i,k)=0. - dby (i,k)=0. - dbyo(i,k)=0. - zu (i,k)=0. - xzu (i,k)=0. - zuo (i,k)=0. - enddo - 42 continue -! -!--- calculate workfunctions for updrafts -! - if(make_calc_for_xk) then - call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & - kbcon,ktop,ierr, & - itf,ktf, its,ite, kts,kte) - call cup_up_aa0(aa1,zo,zuo,dbyo,gammao_cup,tn_cup, & - kbcon,ktop,ierr, & - itf,ktf, its,ite, kts,kte) - do i=its,itf - if(ierr(i) == 0)then - if(aa1(i) <= 0.)then - ierr(i)=17 - ierrc(i)="cloud work function zero" - endif - endif - enddo - endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! -!--- change per unit mass that a model cloud would modify the environment -! -!--- 1. in bottom layer -! - do k=kts,kte - do i=its,itf - dellah(i,k)=0. - dellaq(i,k)=0. - dellaqc(i,k)=0. - dellu (i,k)=0. - dellv (i,k)=0. - enddo - enddo -! -!---------------------------------------------- cloud level ktop -! -!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1 -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! -!---------------------------------------------- cloud level k+2 -! -!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1 -! -!---------------------------------------------- cloud level k+1 -! -!- - - - - - - - - - - - - - - - - - - - - - - - model level k -! -!---------------------------------------------- cloud level k -! -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! . . . -! -!---------------------------------------------- cloud level 3 -! -!- - - - - - - - - - - - - - - - - - - - - - - - model level 2 -! -!---------------------------------------------- cloud level 2 -! -!- - - - - - - - - - - - - - - - - - - - - - - - model level 1 - trash2=0. - do i=its,itf - if(ierr(i).eq.0)then - dp=100.*(po_cup(i,1)-po_cup(i,2)) - dellu(i,1)= -zuo(i,2)*(uc (i,2)-u_cup(i,2)) *g/dp - dellv(i,1)= -zuo(i,2)*(vc (i,2)-v_cup(i,2)) *g/dp - dellah(i,1)=-zuo(i,2)*(hco(i,2)-heo_cup(i,2))*g/dp - - dellaq (i,1)=-zuo(i,2)*(qco(i,2)-qo_cup(i,2))*g/dp - - do k=k22(i),ktop(i) - ! entrainment/detrainment for updraft - entup=up_massentro(i,k) - detup=up_massdetro(i,k) - totmas=detup-entup+zuo(i,k+1)-zuo(i,k) - if(abs(totmas).gt.1.e-6)then - write(0,*)'*********************',i,k,totmas - write(0,*)k22(i),kbcon(i),ktop(i) - endif - dp=100.*(po_cup(i,k)-po_cup(i,k+1)) - dellah(i,k) =-(zuo(i,k+1)*(hco(i,k+1)-heo_cup(i,k+1) )- & - zuo(i,k )*(hco(i,k )-heo_cup(i,k ) ))*g/dp - - !-- take out cloud liquid water for detrainment - dz=zo_cup(i,k+1)-zo_cup(i,k) - if(k.lt.ktop(i) .and. c1d(i,k) > 0)then - dellaqc(i,k)= zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g ! detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp - else - dellaqc(i,k)=detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp -! dellaqc(i,k)= detup*qrco(i,k) *g/dp - endif - - !-- condensation source term = detrained + flux divergence of - !-- cloud liquid water (qrco) - c_up = dellaqc(i,k)+(zuo(i,k+1)* qrco(i,k+1) - & - zuo(i,k )* qrco(i,k ) )*g/dp -! c_up = dellaqc(i,k) - !-- water vapor budget (flux divergence of q_up-q_env - condensation - !term) - dellaq(i,k) =-(zuo(i,k+1)*(qco(i,k+1)-qo_cup(i,k+1) ) - & - zuo(i,k )*(qco(i,k )-qo_cup(i,k ) ) )*g/dp & - - c_up - 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp - dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) - & - zuo(i,k )*(uc (i,k )-u_cup(i,k ) ) )*g/dp - dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) - & - zuo(i,k )*(vc (i,k )-v_cup(i,k ) ) )*g/dp - - enddo - endif - enddo - -! -!--- using dellas, calculate changed environmental profiles -! - mbdt=.5 !3.e-4 - - do k=kts,ktf - do i=its,itf - dellat(i,k)=0. - if(ierr(i)/=0)cycle - xhe(i,k)=dellah(i,k)*mbdt+heo(i,k) - xq (i,k)=max(1.e-16,(dellaq(i,k)+dellaqc(i,k))*mbdt+qo(i,k)) - dellat(i,k)=(1./cp)*(dellah(i,k)-xlv*(dellaq(i,k))) - xt (i,k)= (-dellaqc(i,k)*xlv/cp+dellat(i,k))*mbdt+tn(i,k) - xt (i,k)= max(190.,xt(i,k)) - - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then -! xhkb(i)=hkbo(i)+(dellah(i,k22(i)))*mbdt - xhe(i,ktf)=heo(i,ktf) - xq(i,ktf)=qo(i,ktf) - xt(i,ktf)=tn(i,ktf) - endif - enddo -! -! - if(make_calc_for_xk) then -! -!--- calculate moist static energy, heights, qes -! - call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, & - psur,ierr,tcrit,-1, & - itf,ktf, & - its,ite, kts,kte) -! -!--- environmental values on cloud levels -! - call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, & - xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur, & - ierr,z1, & - itf,ktf, & - its,ite, kts,kte) -! -! -!**************************** static control - do k=kts,ktf - do i=its,itf - xhc(i,k)=0. - xdby(i,k)=0. - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - x_add = xlv*zqexec(i)+cp*ztexec(i) - call get_cloud_bc(kte,xhe_cup (i,1:kte),xhkb (i),k22(i),x_add) - do k=1,start_level(i)-1 - xhc(i,k)=xhe_cup(i,k) - enddo - k=start_level(i) - xhc(i,k)=xhkb(i) - endif !ierr - enddo -! -! - do i=its,itf - if(ierr(i).eq.0)then - xzu(i,1:ktf)=zuo(i,1:ktf) - do k=start_level(i)+1,ktop(i) - xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1)+ & - up_massentro(i,k-1)*xhe(i,k-1)) / & - (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) - xdby(i,k)=xhc(i,k)-xhes_cup(i,k) - enddo - do k=ktop(i)+1,ktf - xhc (i,k)=xhes_cup(i,k) - xdby(i,k)=0. - xzu (i,k)=0. - enddo - endif - enddo - -! -!--- workfunctions for updraft -! - call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & - kbcon,ktop,ierr, & - itf,ktf, & - its,ite, kts,kte) -! - endif -! -! -! now for shallow forcing -! - do i=its,itf - xmb(i)=0. - xff_shal(1:3)=0. - if(ierr(i).eq.0)then - xmbmax(i)=1.0 -! xmbmax(i)=100.*(p(i,kbcon(i))-p(i,kbcon(i)+1))/(g*dtime) -! -!-stabilization closure - xkshal=(xaa0(i)-aa1(i))/mbdt - if(xkshal.le.0.and.xkshal.gt.-.01*mbdt) & - xkshal=-.01*mbdt - if(xkshal.gt.0.and.xkshal.lt.1.e-2) & - xkshal=1.e-2 - - xff_shal(1)=max(0.,-(aa1(i)-aa0(i))/(xkshal*dtime)) -! -!- closure from grant (2001) - xff_shal(2)=.03*zws(i) -!- boundary layer qe closure - blqe=0. - trash=0. - do k=1,kbcon(i) - blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g - enddo - trash=max((hc(i,kbcon(i))-he_cup(i,kbcon(i))),1.e1) - xff_shal(3)=max(0.,blqe/trash) - xff_shal(3)=min(xmbmax(i),xff_shal(3)) -!- average - xmb(i)=(xff_shal(1)+xff_shal(2)+xff_shal(3))/3. - xmb(i)=min(xmbmax(i),xmb(i)) - if(ichoice > 0)xmb(i)=min(xmbmax(i),xff_shal(ichoice)) - if(xmb(i) <= 0.)then - ierr(i)=21 - ierrc(i)="21" - endif - endif - if(ierr(i).ne.0)then - k22 (i)=0 - kbcon(i)=0 - ktop (i)=0 - xmb (i)=0. - outt (i,:)=0. - outu (i,:)=0. - outv (i,:)=0. - outq (i,:)=0. - outqc(i,:)=0. - else if(ierr(i).eq.0)then - xmb_out(i)=xmb(i) -! -! final tendencies -! - pre(i)=0. - do k=2,ktop(i) - outt (i,k)= dellat (i,k)*xmb(i) - outq (i,k)= dellaq (i,k)*xmb(i) - outqc(i,k)= dellaqc(i,k)*xmb(i) - pre (i) = pre(i)+pwo(i,k)*xmb(i) - enddo - outt (i,1)= dellat (i,1)*xmb(i) - outq (i,1)= dellaq (i,1)*xmb(i) - outu(i,1)=dellu(i,1)*xmb(i) - outv(i,1)=dellv(i,1)*xmb(i) - do k=kts+1,ktop(i) - outu(i,k)=.25*(dellu(i,k-1)+2.*dellu(i,k)+dellu(i,k+1))*xmb(i) - outv(i,k)=.25*(dellv(i,k-1)+2.*dellv(i,k)+dellv(i,k+1))*xmb(i) - enddo - - endif - enddo -! -! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) -! - do i=its,itf - if(ierr(i).eq.0) then - dts=0. - fpi=0. - do k=kts,ktop(i) - dp=(po_cup(i,k)-po_cup(i,k+1))*100. -!total ke dissiptaion estimate - dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g -! fpi needed for calcualtion of conversion to pot. energyintegrated - fpi = fpi +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp - enddo - if(fpi.gt.0.)then - do k=kts,ktop(i) - fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi - outt(i,k)=outt(i,k)+fp*dts*g/cp - enddo - endif - endif - enddo -! -! done shallow -!--------------------------done------------------------------ -! -! do k=1,30 -! print*,'hlisq',qco(1,k),qrco(1,k),pwo(1,k) -! enddo - - end subroutine cu_gf_sh_run -end module cu_gf_sh diff --git a/module_bl_mynn.F90 b/module_bl_mynn.F90 deleted file mode 100644 index ff8e6619a..000000000 --- a/module_bl_mynn.F90 +++ /dev/null @@ -1,6100 +0,0 @@ -!WRF:MODEL_LAYER:PHYSICS -! -! translated from NN f77 to F90 and put into WRF by Mariusz Pagowski -! NOAA/GSD & CIRA/CSU, Feb 2008 -! changes to original code: -! 1. code is 1D (in z) -! 2. no advection of TKE, covariances and variances -! 3. Cranck-Nicholson replaced with the implicit scheme -! 4. removed terrain dependent grid since input in WRF in actual -! distances in z[m] -! 5. cosmetic changes to adhere to WRF standard (remove common blocks, -! intent etc) -!------------------------------------------------------------------- -!Modifications implemented by Joseph Olson and Jaymes Kenyon NOAA/GSD/MDB - CU/CIRES -! -! Departures from original MYNN (Nakanish & Niino 2009) -! 1. Addition of BouLac mixing length in the free atmosphere. -! 2. Changed the turbulent mixing length to be integrated from the -! surface to the top of the BL + a transition layer depth. -! v3.4.1: Option to use Kitamura/Canuto modification which removes -! the critical Richardson number and negative TKE (default). -! Hybrid PBL height diagnostic, which blends a theta-v-based -! definition in neutral/convective BL and a TKE-based definition -! in stable conditions. -! TKE budget output option (bl_mynn_tkebudget) -! v3.5.0: TKE advection option (bl_mynn_tkeadvect) -! v3.5.1: Fog deposition related changes. -! v3.6.0: Removed fog deposition from the calculation of tendencies -! Added mixing of qc, qi, qni -! Added output for wstar, delta, TKE_PBL, & KPBL for correct -! coupling to shcu schemes -! v3.8.0: Added subgrid scale cloud output for coupling to radiation -! schemes (activated by setting icloud_bl =1 in phys namelist). -! Added WRF_DEBUG prints (at level 3000) -! Added Tripoli and Cotton (1981) correction. -! Added namelist option bl_mynn_cloudmix to test effect of mixing -! cloud species (default = 1: on). -! Added mass-flux option (bl_mynn_edmf, = 1 for DMP mass-flux, 0: off). -! Related options: -! bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme -! bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme -! Added mixing length option (bl_mynn_mixlength, see notes below) -! Added more sophisticated saturation checks, following Thompson scheme -! Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau -! and Bechtold (2002, JAS, with mods) -! Added capability to mix chemical species when env variable -! WRF_CHEM = 1, thanks to Wayne Angevine. -! Added scale-aware mixing length, following Junshi Ito's work -! Ito et al. (2015, BLM). -! v3.9.0 Improvement to the mass-flux scheme (dynamic number of plumes, -! better plume/cloud depth, significant speed up, better cloud -! fraction). -! Added Stochastic Parameter Perturbation (SPP) implementation. -! Many miscellaneous tweaks to the mixing lengths and stratus -! component of the subgrid clouds. -! v.4.0 Removed or added alternatives to WRF-specific functions/modules -! for the sake of portability to other models. -! the sake of portability to other models. -! Further refinement of mass-flux scheme from SCM experiments with -! Wayne Angevine: switch to linear entrainment and back to -! Simpson and Wiggert-type w-equation. -! Addition of TKE production due to radiation cooling at top of -! clouds (proto-version); not activated by default. -! Some code rewrites to move if-thens out of loops in an attempt to -! improve computational efficiency. -! New tridiagonal solver, which is supposedly 14% faster and more -! conservative. Impact seems very small. -! Many miscellaneous tweaks to the mixing lengths and stratus -! component of the subgrid-scale (SGS) clouds. -! v4.1 Big improvements in downward SW radiation due to revision of subgrid clouds -! - better cloud fraction and subgrid scale mixing ratios. -! - may experience a small cool bias during the daytime now that high -! SW-down bias is greatly reduced... -! Some tweaks to increase the turbulent mixing during the daytime for -! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact). -! Improved ensemble spread from changes to SPP in MYNN -! - now perturbing eddy diffusivity and eddy viscosity directly -! - now perturbing background rh (in SGS cloud calc only) -! - now perturbing entrainment rates in mass-flux scheme -! Added IF checks (within IFDEFS) to protect mixchem code from being used -! when HRRR smoke is used (no impact on regular non-wrf chem use) -! Important bug fix for wrf chem when transporting chemical species in MF scheme -! Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2) -! Removed unused stochastic code for mass-flux scheme -! Changed mass-flux scheme to be integrated on interface levels instead of -! mass levels - impact is small -! Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option. -! - activated with bl_mynn_mixscalars = 1; this sets scalar_pblmix = 0 -! - added tridagonal solver used in scalar_pblmix option to duplicate tendencies -! - this alone changes the interface call considerably from v4.0. -! Slight revision to TKE production due to radiation cooling at top of clouds -! Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998, JAS). -! - improves TKE in SGS clouds -! Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp) -! Misc changes made for FV3/MPAS compatibility -! -! Many of these changes are now documented in Olson et al. (2019, -! NOAA Technical Memorandum) -! -! For more explanation of some configuration options, see "JOE's mods" below: -!------------------------------------------------------------------- - -MODULE module_bl_mynn - -!================================================================== -!FV3 CONSTANTS - use physcons, only : cp => con_cp, & - & g => con_g, & - & r_d => con_rd, & - & r_v => con_rv, & - & cpv => con_cvap, & - & cliq => con_cliq, & - & Cice => con_csol, & - & rcp => con_rocp, & - & XLV => con_hvap, & - & XLF => con_hfus, & - & EP_1 => con_fvirt, & - & EP_2 => con_eps - - IMPLICIT NONE - - REAL , PARAMETER :: karman = 0.4 - REAL , PARAMETER :: XLS = 2.85E6 - REAL , PARAMETER :: p1000mb = 100000. - REAL , PARAMETER :: rvovrd = r_v/r_d - REAL , PARAMETER :: SVP1 = 0.6112 - REAL , PARAMETER :: SVP2 = 17.67 - REAL , PARAMETER :: SVP3 = 29.65 - REAL , PARAMETER :: SVPT0 = 273.15 - - INTEGER , PARAMETER :: param_first_scalar = 1, & - & p_qc = 2, & - & p_qr = 0, & - & p_qi = 2, & - & p_qs = 0, & - & p_qg = 0, & - & p_qnc= 0, & - & p_qni= 0 - -!END FV3 CONSTANTS -!==================================================================== -!WRF CONSTANTS -! USE module_model_constants, only: & -! &karman, g, p1000mb, & -! &cp, r_d, r_v, rcp, xlv, xlf, xls, & -! &svp1, svp2, svp3, svpt0, ep_1, ep_2, rvovrd, & -! &cpv, cliq, cice -! -! USE module_state_description, only: param_first_scalar, & -! &p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni -! -! IMPLICIT NONE -! -!END WRF CONSTANTS -!=================================================================== -! From here on, these are used for any model -! The parameters below depend on stability functions of module_sf_mynn. - REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & - cphh_st=5.0, cphh_unst=16.0 - - REAL, PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv, rd=r_d, & - &rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2 - - REAL, PARAMETER :: tref=300.0 ! reference temperature (K) - REAL, PARAMETER :: TKmin=253.0 ! for total water conversion, Tripoli and Cotton (1981) - REAL, PARAMETER :: tv0=p608*tref, tv1=(1.+p608)*tref, gtr=g/tref - -! Closure constants - REAL, PARAMETER :: & - &vk = karman, & - &pr = 0.74, & - &g1 = 0.235, & ! NN2009 = 0.235 - &b1 = 24.0, & - &b2 = 15.0, & ! CKmod NN2009 - &c2 = 0.729, & ! 0.729, & !0.75, & - &c3 = 0.340, & ! 0.340, & !0.352, & - &c4 = 0.0, & - &c5 = 0.2, & - &a1 = b1*( 1.0-3.0*g1 )/6.0, & -! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & - &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & - &a2 = a1*( g1-c1 )/( g1*pr ), & - &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) - - REAL, PARAMETER :: & - &cc2 = 1.0-c2, & - &cc3 = 1.0-c3, & - &e1c = 3.0*a2*b2*cc3, & - &e2c = 9.0*a1*a2*cc2, & - &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), & - &e4c = 12.0*a1*a2*cc2, & - &e5c = 6.0*a1*a1 - -! Constants for min tke in elt integration (qmin), max z/L in els (zmax), -! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): - REAL, PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 -! Note that the following mixing-length constants are now specified in mym_length -! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.4 - -! Constants for gravitational settling -! REAL, PARAMETER :: gno=1.e6/(1.e8)**(2./3.), gpw=5./3., qcgmin=1.e-8 - REAL, PARAMETER :: gno=1.0 !original value seems too agressive: 4.64158883361278196 - REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 - -! Constants for cloud PDF (mym_condensation) - REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 - -! 'parameters' for Poisson distribution (EDMF scheme) - REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0 - - !Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) - !For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the - !Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010). - !Note that this change required further modification of other parameters - !above (c2, c3). If you want to remove this option, set c2 and c3 constants - !(above) back to NN2009 values (see commented out lines next to the - !parameters above). This only removes the negative TKE problem - !but does not necessarily improve performance - neutral impact. - REAL, PARAMETER :: CKmod=1. - - !Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts - !on the cloud PDF and mass-flux scheme, using Honnert et al. (2011) similarity function - !for TKE in the upper PBL/cloud layer. - REAL, PARAMETER :: scaleaware=1. - - !Temporary switch to deactivate the mixing of chemical species (already done when WRF_CHEM = 1) - INTEGER, PARAMETER :: bl_mynn_mixchem = 0 - - !Adding top-down diffusion driven by cloud-top radiative cooling - INTEGER, PARAMETER :: bl_mynn_topdown = 1 - - !Option to activate heating due to dissipation of TKE (to activate, set to 1.0) - REAL, PARAMETER :: dheat_opt = 1. - - !option to print out more stuff for debugging purposes - LOGICAL, PARAMETER :: debug_code = .false. - -! JAYMES- -! Constants used for empirical calculations of saturation -! vapor pressures (in function "esat") and saturation mixing ratios -! (in function "qsat"), reproduced from module_mp_thompson.F, -! v3.6 - REAL, PARAMETER:: J0= .611583699E03 - REAL, PARAMETER:: J1= .444606896E02 - REAL, PARAMETER:: J2= .143177157E01 - REAL, PARAMETER:: J3= .264224321E-1 - REAL, PARAMETER:: J4= .299291081E-3 - REAL, PARAMETER:: J5= .203154182E-5 - REAL, PARAMETER:: J6= .702620698E-8 - REAL, PARAMETER:: J7= .379534310E-11 - REAL, PARAMETER:: J8=-.321582393E-13 - - REAL, PARAMETER:: K0= .609868993E03 - REAL, PARAMETER:: K1= .499320233E02 - REAL, PARAMETER:: K2= .184672631E01 - REAL, PARAMETER:: K3= .402737184E-1 - REAL, PARAMETER:: K4= .565392987E-3 - REAL, PARAMETER:: K5= .521693933E-5 - REAL, PARAMETER:: K6= .307839583E-7 - REAL, PARAMETER:: K7= .105785160E-9 - REAL, PARAMETER:: K8= .161444444E-12 -! end- - -!JOE & JAYMES'S mods -! -! Mixing Length Options -! specifed through namelist: bl_mynn_mixlength -! added: 16 Apr 2015 -! -! 0: Uses original MYNN mixing length formulation (except elt is calculated from -! a 10-km vertical integration). No scale-awareness is applied to the master -! mixing length (el), regardless of "scaleaware" setting. -! -! 1 (*DEFAULT*): Instead of (0), uses BouLac mixing length in free atmosphere. -! This helps remove excessively large mixing in unstable layers aloft. Scale- -! awareness in dx is available via the "scaleaware" setting. As of Apr 2015, -! this mixing length formulation option is used in the ESRL RAP/HRRR configuration. -! -! 2: As in (1), but elb is lengthened using separate cloud mixing length functions -! for statically stable and unstable regimes. This elb adjustment is only -! possible for nonzero cloud fractions, such that cloud-free cells are treated -! as in (1), but BouLac calculation is used more sparingly - when elb > 500 m. -! This is to reduce the computational expense that comes with the BouLac calculation. -! Also, This option is scale-aware in dx if "scaleaware" = 1. (Following Ito et al. 2015). -! -!JOE & JAYMES- end - - - - INTEGER :: mynn_level - - CHARACTER*128 :: mynn_message - - INTEGER, PARAMETER :: kdebug=27 - -CONTAINS - -! ********************************************************************** -! * An improved Mellor-Yamada turbulence closure model * -! * * -! * Aug/2005 M. Nakanishi (N.D.A) * -! * Modified: Dec/2005 M. Nakanishi (N.D.A) * -! * naka@nda.ac.jp * -! * * -! * Contents: * -! * 1. mym_initialize (to be called once initially) * -! * gives the closure constants and initializes the turbulent * -! * quantities. * -! * (2) mym_level2 (called in the other subroutines) * -! * calculates the stability functions at Level 2. * -! * (3) mym_length (called in the other subroutines) * -! * calculates the master length scale. * -! * 4. mym_turbulence * -! * calculates the vertical diffusivity coefficients and the * -! * production terms for the turbulent quantities. * -! * 5. mym_predict * -! * predicts the turbulent quantities at the next step. * -! * 6. mym_condensation * -! * determines the liquid water content and the cloud fraction * -! * diagnostically. * -! * * -! * call mym_initialize * -! * | * -! * |<----------------+ * -! * | | * -! * call mym_condensation | * -! * call mym_turbulence | * -! * call mym_predict | * -! * | | * -! * |-----------------+ * -! * | * -! * end * -! * * -! * Variables worthy of special mention: * -! * tref : Reference temperature * -! * thl : Liquid water potential temperature * -! * qw : Total water (water vapor+liquid water) content * -! * ql : Liquid water content * -! * vt, vq : Functions for computing the buoyancy flux * -! * * -! * If the water contents are unnecessary, e.g., in the case of * -! * ocean models, thl is the potential temperature and qw, ql, vt * -! * and vq are all zero. * -! * * -! * Grid arrangement: * -! * k+1 +---------+ * -! * | | i = 1 - nx * -! * (k) | * | j = 1 - ny * -! * | | k = 1 - nz * -! * k +---------+ * -! * i (i) i+1 * -! * * -! * All the predicted variables are defined at the center (*) of * -! * the grid boxes. The diffusivity coefficients are, however, * -! * defined on the walls of the grid boxes. * -! * # Upper boundary values are given at k=nz. * -! * * -! * References: * -! * 1. Nakanishi, M., 2001: * -! * Boundary-Layer Meteor., 99, 349-378. * -! * 2. Nakanishi, M. and H. Niino, 2004: * -! * Boundary-Layer Meteor., 112, 1-31. * -! * 3. Nakanishi, M. and H. Niino, 2006: * -! * Boundary-Layer Meteor., (in press). * -! * 4. Nakanishi, M. and H. Niino, 2009: * -! * Jour. Meteor. Soc. Japan, 87, 895-912. * -! ********************************************************************** -! -! SUBROUTINE mym_initialize: -! -! Input variables: -! iniflag : <>0; turbulent quantities will be initialized -! = 0; turbulent quantities have been already -! given, i.e., they will not be initialized -! nx, ny, nz : Dimension sizes of the -! x, y and z directions, respectively -! tref : Reference temperature (K) -! dz(nz) : Vertical grid spacings (m) -! # dz(nz)=dz(nz-1) -! zw(nz+1) : Heights of the walls of the grid boxes (m) -! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1) -! h(nx,ny) : G^(1/2) in the terrain-following coordinate -! # h=1-zg/zt, where zg is the height of the -! terrain and zt the top of the model domain -! pi0(nx,my,nz) : Exner function at zw*h+zg (J/kg K) -! defined by c_p*( p_basic/1000hPa )^kappa -! This is usually computed by integrating -! d(pi0)/dz = -h*g/tref. -! rmo(nx,ny) : Inverse of the Obukhov length (m^(-1)) -! flt, flq(nx,ny) : Turbulent fluxes of sensible and latent heat, -! respectively, e.g., flt=-u_*Theta_* (K m/s) -!! flt - liquid water potential temperature surface flux -!! flq - total water flux surface flux -! ust(nx,ny) : Friction velocity (m/s) -! pmz(nx,ny) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) -! is the first grid point above the surafce, z0 -! the roughness length and zeta=(z1*h+z0)*rmo -! phh(nx,ny) : phi_h at z1*h+z0 -! u, v(nx,nz,ny): Components of the horizontal wind (m/s) -! thl(nx,nz,ny) : Liquid water potential temperature -! (K) -! qw(nx,nz,ny) : Total water content Q_w (kg/kg) -! -! Output variables: -! ql(nx,nz,ny) : Liquid water content (kg/kg) -! v?(nx,nz,ny) : Functions for computing the buoyancy flux -! qke(nx,nz,ny) : Twice the turbulent kinetic energy q^2 -! (m^2/s^2) -! tsq(nx,nz,ny) : Variance of Theta_l (K^2) -! qsq(nx,nz,ny) : Variance of Q_w -! cov(nx,nz,ny) : Covariance of Theta_l and Q_w (K) -! el(nx,nz,ny) : Master length scale L (m) -! defined on the walls of the grid boxes -! -! Work arrays: see subroutine mym_level2 -! pd?(nx,nz,ny) : Half of the production terms at Level 2 -! defined on the walls of the grid boxes -! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s) -! -! # As to dtl, ...gh, see subroutine mym_turbulence. -! -!------------------------------------------------------------------- - SUBROUTINE mym_initialize ( & - & kts,kte, & - & dz, zw, & - & u, v, thl, qw, & -! & ust, rmo, pmz, phh, flt, flq, & - & zi, theta, sh, & - & ust, rmo, el, & - & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & - & spp_pbl,rstoch_col) -! -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf -! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - REAL, INTENT(IN) :: ust, rmo, Psig_bl - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& - edmf_w1,edmf_a1,edmf_qc1 - REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov - REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke - - REAL, DIMENSION(kts:kte) :: & - &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& - &gm,gh,sm,sh,qkw,vt,vq - INTEGER :: k,l,lmax - REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq - REAL :: zi - REAL, DIMENSION(kts:kte) :: theta - - REAL, DIMENSION(kts:kte) :: rstoch_col - INTEGER ::spp_pbl - -! ** At first ql, vt and vq are set to zero. ** - DO k = kts,kte - ql(k) = 0.0 - vt(k) = 0.0 - vq(k) = 0.0 - END DO -! - CALL mym_level2 ( kts,kte,& - & dz, & - & u, v, thl, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! -! ** Preliminary setting ** - - el (kts) = 0.0 - qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0) -! - phm = phh*b2 / ( b1*pmz )**(1.0/3.0) - tsq(kts) = phm*( flt/ust )**2 - qsq(kts) = phm*( flq/ust )**2 - cov(kts) = phm*( flt/ust )*( flq/ust ) -! - DO k = kts+1,kte - vkz = vk*zw(k) - el (k) = vkz/( 1.0 + vkz/100.0 ) - qke(k) = 0.0 -! - tsq(k) = 0.0 - qsq(k) = 0.0 - cov(k) = 0.0 - END DO -! -! ** Initialization with an iterative manner ** -! ** lmax is the iteration count. This is arbitrary. ** - lmax = 5 -! - DO l = 1,lmax -! - CALL mym_length ( & - & kts,kte, & - & dz, zw, & - & rmo, flt, flq, & - & vt, vq, & - & qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) -! - DO k = kts+1,kte - elq = el(k)*qkw(k) - pdk(k) = elq*( sm(k)*gm (k)+& - &sh(k)*gh (k) ) - pdt(k) = elq* sh(k)*dtl(k)**2 - pdq(k) = elq* sh(k)*dqw(k)**2 - pdc(k) = elq* sh(k)*dtl(k)*dqw(k) - END DO -! -! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** - vkz = vk*0.5*dz(kts) -! - elv = 0.5*( el(kts+1)+el(kts) ) / vkz - qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0) -! - phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0) - tsq(kts) = phm*( flt/ust )**2 - qsq(kts) = phm*( flq/ust )**2 - cov(kts) = phm*( flt/ust )*( flq/ust ) -! - DO k = kts+1,kte-1 - b1l = b1*0.25*( el(k+1)+el(k) ) - tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin) -! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k) - qke(k) = tmpq**(2.0/3.0) - -! - IF ( qke(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*( b1l/b1 ) / SQRT( qke(k) ) - END IF -! - tsq(k) = b2l*( pdt(k+1)+pdt(k) ) - qsq(k) = b2l*( pdq(k+1)+pdq(k) ) - cov(k) = b2l*( pdc(k+1)+pdc(k) ) - END DO - -! - END DO - -!! qke(kts)=qke(kts+1) -!! tsq(kts)=tsq(kts+1) -!! qsq(kts)=qsq(kts+1) -!! cov(kts)=cov(kts+1) - - qke(kte)=qke(kte-1) - tsq(kte)=tsq(kte-1) - qsq(kte)=qsq(kte-1) - cov(kte)=cov(kte-1) - -! -! RETURN - - END SUBROUTINE mym_initialize - -! -! ================================================================== -! SUBROUTINE mym_level2: -! -! Input variables: see subroutine mym_initialize -! -! Output variables: -! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m) -! dqw(nx,nz,ny) : Vertical gradient of Q_w -! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m) -! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2)) -! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2)) -! sm (nx,nz,ny) : Stability function for momentum, at Level 2 -! sh (nx,nz,ny) : Stability function for heat, at Level 2 -! -! These are defined on the walls of the grid boxes. -! - SUBROUTINE mym_level2 (kts,kte,& - & dz, & - & u, v, thl, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq - - REAL, DIMENSION(kts:kte), INTENT(out) :: & - &dtl,dqw,dtv,gm,gh,sm,sh - - INTEGER :: k - - REAL :: rfc,f1,f2,rf1,rf2,smc,shc,& - &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf - - REAL :: a2den - -! ev = 2.5e6 -! tv0 = 0.61*tref -! tv1 = 1.61*tref -! gtr = 9.81/tref -! - rfc = g1/( g1+g2 ) - f1 = b1*( g1-c1 ) +3.0*a2*( 1.0 -c2 )*( 1.0-c5 ) & - & +2.0*a1*( 3.0-2.0*c2 ) - f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) - rf1 = b1*( g1-c1 )/f1 - rf2 = b1* g1 /f2 - smc = a1 /a2* f1/f2 - shc = 3.0*a2*( g1+g2 ) -! - ri1 = 0.5/smc - ri2 = rf1*smc - ri3 = 4.0*rf2*smc -2.0*ri2 - ri4 = ri2**2 -! - DO k = kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 - duz = duz /dzk**2 - dtz = ( thl(k)-thl(k-1) )/( dzk ) - dqz = ( qw(k)-qw(k-1) )/( dzk ) -! - vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 - vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q - dtq = vtt*dtz +vqq*dqz -! - dtl(k) = dtz - dqw(k) = dqz - dtv(k) = dtq -!? dtv(i,j,k) = dtz +tv0*dqz -!? : +( ev/pi0(i,j,k)-tv1 ) -!? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) ) -! - gm (k) = duz - gh (k) = -dtq*gtr -! -! ** Gradient Richardson number ** - ri = -gh(k)/MAX( duz, 1.0e-10 ) - - !a2den is needed for the Canuto/Kitamura mod - IF (CKmod .eq. 1) THEN - a2den = 1. + MAX(ri,0.0) - ELSE - a2den = 1. + 0.0 - ENDIF - - rfc = g1/( g1+g2 ) - f1 = b1*( g1-c1 ) +3.0*(a2/a2den)*( 1.0 -c2 )*( 1.0-c5 ) & - & +2.0*a1*( 3.0-2.0*c2 ) - f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) - rf1 = b1*( g1-c1 )/f1 - rf2 = b1* g1 /f2 - smc = a1 /(a2/a2den)* f1/f2 - shc = 3.0*(a2/a2den)*( g1+g2 ) - - ri1 = 0.5/smc - ri2 = rf1*smc - ri3 = 4.0*rf2*smc -2.0*ri2 - ri4 = ri2**2 - -! ** Flux Richardson number ** - rf = MIN( ri1*( ri+ri2-SQRT(ri**2-ri3*ri+ri4) ), rfc ) -! - sh (k) = shc*( rfc-rf )/( 1.0-rf ) - sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k) - END DO -! -! RETURN - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_level2 - -! ================================================================== -! SUBROUTINE mym_length: -! -! Input variables: see subroutine mym_initialize -! -! Output variables: see subroutine mym_initialize -! -! Work arrays: -! elt(nx,ny) : Length scale depending on the PBL depth (m) -! vsc(nx,ny) : Velocity scale q_c (m/s) -! at first, used for computing elt -! -! NOTE: the mixing lengths are meant to be calculated at the full- -! sigmal levels (or interfaces beween the model layers). -! - SUBROUTINE mym_length ( & - & kts,kte, & - & dz, zw, & - & rmo, flt, flq, & - & vt, vq, & - & qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) - -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl - REAL, DIMENSION(kts:kte), INTENT(IN) :: qke,vt,vq,cldfra_bl1D,& - edmf_w1,edmf_a1,edmf_qc1 - REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el - REAL, DIMENSION(kts:kte), INTENT(in) :: dtv - - REAL :: elt,vsc - - REAL, DIMENSION(kts:kte), INTENT(IN) :: theta - REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg - - ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE - ! MIXING LENGTHS: - REAL :: cns, & ! for surface layer (els) in stable conditions - alp1, & ! for turbulent length scale (elt) - alp2, & ! for buoyancy length scale (elb) - alp3, & ! for buoyancy enhancement factor of elb - alp4, & ! for surface layer (els) in unstable conditions - alp5, & ! for BouLac mixing length or above PBLH - alp6 ! for mass-flux/ - - !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. - !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH - !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES - !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). - REAL, PARAMETER :: minzi = 300. !min mixed-layer height - REAL, PARAMETER :: maxdz = 750. !max (half) transition layer depth - !=0.3*2500 m PBLH, so the transition - !layer stops growing for PBLHs > 2.5 km. - REAL, PARAMETER :: mindz = 300. !300 !min (half) transition layer depth - - !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER - REAL, PARAMETER :: ZSLH = 100. ! Max height correlated to surface conditions (m) - REAL, PARAMETER :: CSL = 2. ! CSL = constant of proportionality to L O(1) - REAL :: z_m - - - INTEGER :: i,j,k - REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,elb,els,els1,elf, & - & el_stab,el_unstab,el_mf,el_stab_mf,elb_mf,PBLH_PLUS_ENT,el_les - -! tv0 = 0.61*tref -! gtr = 9.81/tref - - SELECT CASE(bl_mynn_mixlength) - - CASE (0) ! ORIGINAL MYNN MIXING LENGTH - - cns = 2.7 - alp1 = 0.23 - alp2 = 1.0 - alp3 = 5.0 - alp4 = 100. - alp5 = 0.4 - - ! Impose limits on the height integration for elt and the transition layer depth - zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km. - h1=MAX(0.3*zi2,mindz) - h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h2=h1/2.0 ! 1/4 transition layer depth - - qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) - DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - END DO - - elt = 1.0e-5 - vsc = 1.0e-5 - - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. zi2+h1) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO - - elt = alp1*elt/vsc - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) - - ! ** Strictly, el(i,j,1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) - - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels - - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - bv = SQRT( gtr*dtv(k) ) - elb = alp2*qkw(k) / bv & - & *( 1.0 + alp3/alp2*& - &SQRT( vsc/( bv*elt ) ) ) - elf = alp2 * qkw(k)/bv - - ELSE - elb = 1.0e10 - elf = elb - ENDIF - - z_m = MAX(0.,zwk - 4.) - - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 - END IF - - ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: - ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - ! el(k) = elb/( elb/elt+elb/els+1.0 ) - - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - - el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - - END DO - - CASE (1) !OPERATIONAL FORM OF MIXING LENGTH - - cns = 2.3 - alp1 = 0.23 - alp2 = 0.65 - alp3 = 3.0 - alp4 = 20. - alp5 = 0.4 - - ! Impose limits on the height integration for elt and the transition layer depth - zi2=MAX(zi,minzi) - h1=MAX(0.3*zi2,mindz) - h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h2=h1/2.0 ! 1/4 transition layer depth - - qtke(kts)=MAX(qke(kts)/2.,0.01) !tke at full sigma levels - thetaw(kts)=theta(kts) !theta at full-sigma levels - qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) - - DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - qtke(k) = (qkw(k)**2.)/2. ! q -> TKE - thetaw(k)= theta(k)*abk + theta(k-1)*afk - END DO - - elt = 1.0e-5 - vsc = 1.0e-5 - - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. zi2+h1) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO - - elt = alp1*elt/vsc - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) - - ! ** Strictly, el(i,j,1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) !full-sigma levels - - ! COMPUTE BouLac mixing length - CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg) - - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels - - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - bv = SQRT( gtr*dtv(k) ) - elb = alp2*qkw(k) / bv & ! formulation, - & *( 1.0 + alp3/alp2*& ! except keep - &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by - elb = MIN(elb, zwk) ! zwk - elf = alp2 * qkw(k)/bv - ELSE - elb = 1.0e10 - elf = elb - ENDIF - - z_m = MAX(0.,zwk - 4.) - - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 - END IF - - ! ** NOW BLEND THE MIXING LENGTH SCALES: - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - - !add blending to use BouLac mixing length in free atmos; - !defined relative to the PBLH (zi) + transition layer (h1) - el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - el(k) = el(k)*(1.-wt) + alp5*elBLmin(k)*wt - - ! include scale-awareness, except for original MYNN - el(k) = el(k)*Psig_bl - - END DO - - CASE (2) !Experimental mixing length formulation - - cns = 3.5 - alp1 = 0.23 - alp2 = 0.6 !0.3 - alp3 = 2.0 - alp4 = 10. - alp5 = 0.6 !0.3 !like alp2, but for free atmosphere - alp6 = 10.0 !used for MF mixing length instead of BouLac (x times MF) - - ! Impose limits on the height integration for elt and the transition layer depth - !zi2=MAX(zi,minzi) - zi2=MAX(zi, 100.) - h1=MAX(0.3*zi2,mindz) - h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h2=h1*0.5 ! 1/4 transition layer depth - - qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels - qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) - - DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - qtke(k) = 0.5*(qkw(k)**2.) ! q -> TKE - END DO - - elt = 1.0e-5 - vsc = 1.0e-5 - - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - PBLH_PLUS_ENT = MAX(zi+h1, 100.) - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. PBLH_PLUS_ENT) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk !consider reducing 0.3 - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO - - elt = MAX(alp1*elt/vsc, 10.) - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) - - ! ** Strictly, el(i,j,1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) - - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels - cldavg = 0.5*(cldfra_bl1D(k-1)+cldfra_bl1D(k)) - - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - bv = SQRT( gtr*dtv(k) ) - !elb_mf = alp2*qkw(k) / bv & - elb_mf = MAX(alp2*qkw(k), & - &MAX(1.-2.0*cldavg,0.0)**0.5*alp6*edmf_a1(k)*edmf_w1(k)) / bv & - & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) - elb = MIN(alp5*qkw(k)/bv, zwk) - elf = elb/(1. + (elb/600.)) !bound free-atmos mixing length to < 600 m. - !IF (zwk > zi .AND. elf > 400.) THEN - ! ! COMPUTE BouLac mixing length - ! !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0) - ! !elf = alp5*elBLavg0 - ! elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk) - !ENDIF - - ELSE - ! use version in development for RAP/HRRR 2016 - ! JAYMES- - ! tau_cloud is an eddy turnover timescale; - ! see Teixeira and Cheinet (2004), Eq. 1, and - ! Cheinet and Teixeira (2003), Eq. 7. The - ! coefficient 0.5 is tuneable. Expression in - ! denominator is identical to vsc (a convective - ! velocity scale), except that elt is relpaced - ! by zi, and zero is replaced by 1.0e-4 to - ! prevent division by zero. - tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(flt,1.0e-4))**(1.0/3.0)),25.),100.) - !minimize influence of surface heat flux on tau far away from the PBLH. - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - tau_cloud = tau_cloud*(1.-wt) + 50.*wt - - elb = MIN(tau_cloud*SQRT(MIN(qtke(k),50.)), zwk) - elf = elb - elb_mf = elb - END IF - - z_m = MAX(0.,zwk - 4.) - - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 - END IF - - ! ** NOW BLEND THE MIXING LENGTH SCALES: - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - - ! "el_unstab" = blended els-elt - el_unstab = els/(1. + (els1/elt)) - el(k) = MIN(el_unstab, elb_mf) - el(k) = el(k)*(1.-wt) + elf*wt - - ! include scale-awareness. For now, use simple asymptotic kz -> 12 m. - el_les= MIN(els/(1. + (els1/12.)), elb_mf) - el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les - - END DO - - END SELECT - - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_length - -! ================================================================== - SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) -! -! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW -! and modified for integration into the MYNN PBL scheme. -! WHILE loops were added to reduce the computational expense. -! This subroutine computes the length scales up and down -! and then computes the min, average of the up/down -! length scales, and also considers the distance to the -! surface. -! -! dlu = the distance a parcel can be lifted upwards give a finite -! amount of TKE. -! dld = the distance a parcel can be displaced downwards given a -! finite amount of TKE. -! lb1 = the minimum of the length up and length down -! lb2 = the average of the length up and length down -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: k,kts,kte - REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - REAL, INTENT(OUT) :: lb1,lb2 - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw - - !LOCAL VARS - INTEGER :: izz, found - REAL :: dlu,dld - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz - - - !---------------------------------- - ! FIND DISTANCE UPWARD - !---------------------------------- - zup=0. - dlu=zw(kte+1)-zw(k)-dz(k)/2. - zzz=0. - zup_inf=0. - beta=g/theta(k) !Buoyancy coefficient - - !print*,"FINDING Dup, k=",k," zw=",zw(k) - - if (k .lt. kte) then !cant integrate upwards from highest level - found = 0 - izz=k - DO WHILE (found .EQ. 0) - - if (izz .lt. kte) then - dzt=dz(izz) ! layer depth above - zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k - !print*," ",k,izz,theta(izz),dz(izz) - zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1 - zzz=zzz+dzt ! depth of layer k to izz+1 - !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz) - if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then - bbb=(theta(izz+1)-theta(izz))/dzt - if (bbb .ne. 0.) then - !fractional distance up into the layer where TKE becomes < PE - tl=(-beta*(theta(izz)-theta(k)) + & - & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2. + & - & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta - else - if (theta(izz) .ne. theta(k))then - tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k))) - else - tl=0. - endif - endif - dlu=zzz-dzt+tl - !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl - found =1 - endif - zup_inf=zup - izz=izz+1 - ELSE - found = 1 - ENDIF - - ENDDO - - endif - - !---------------------------------- - ! FIND DISTANCE DOWN - !---------------------------------- - zdo=0. - zdo_sup=0. - dld=zw(k) - zzz=0. - - !print*,"FINDING Ddown, k=",k," zwk=",zw(k) - if (k .gt. kts) then !cant integrate downwards from lowest level - - found = 0 - izz=k - DO WHILE (found .EQ. 0) - - if (izz .gt. kts) then - dzt=dz(izz-1) - zdo=zdo+beta*theta(k)*dzt - !print*," ",k,izz,theta(izz),dz(izz-1) - zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2. - zzz=zzz+dzt - !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz) - if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then - bbb=(theta(izz)-theta(izz-1))/dzt - if (bbb .ne. 0.) then - tl=(beta*(theta(izz)-theta(k))+ & - & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2. + & - & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta - else - if (theta(izz) .ne. theta(k)) then - tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k))) - else - tl=0. - endif - endif - dld=zzz-dzt+tl - !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl - found = 1 - endif - zdo_sup=zdo - izz=izz-1 - ELSE - found = 1 - ENDIF - ENDDO - - endif - - !---------------------------------- - ! GET MINIMUM (OR AVERAGE) - !---------------------------------- - !The surface layer length scale can exceed z for large z/L, - !so keep maximum distance down > z. - dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos - lb1 = min(dlu,dld) !minimum - !JOE-fight floating point errors - dlu=MAX(0.1,MIN(dlu,1000.)) - dld=MAX(0.1,MIN(dld,1000.)) - lb2 = sqrt(dlu*dld) !average - biased towards smallest - !lb2 = 0.5*(dlu+dld) !average - - if (k .eq. kte) then - lb1 = 0. - lb2 = 0. - endif - !print*,"IN MYNN-BouLac",k,lb1 - !print*,"IN MYNN-BouLac",k,dld,dlu - - END SUBROUTINE boulac_length0 - -! ================================================================== - SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) -! -! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW -! and modified for integration into the MYNN PBL scheme. -! WHILE loops were added to reduce the computational expense. -! This subroutine computes the length scales up and down -! and then computes the min, average of the up/down -! length scales, and also considers the distance to the -! surface. -! -! dlu = the distance a parcel can be lifted upwards give a finite -! amount of TKE. -! dld = the distance a parcel can be displaced downwards given a -! finite amount of TKE. -! lb1 = the minimum of the length up and length down -! lb2 = the average of the length up and length down -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - REAL, DIMENSION(kts:kte), INTENT(OUT) :: lb1,lb2 - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw - - !LOCAL VARS - INTEGER :: iz, izz, found - REAL, DIMENSION(kts:kte) :: dlu,dld - REAL, PARAMETER :: Lmax=2000. !soft limit - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz - - !print*,"IN MYNN-BouLac",kts, kte - - do iz=kts,kte - - !---------------------------------- - ! FIND DISTANCE UPWARD - !---------------------------------- - zup=0. - dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)/2. - zzz=0. - zup_inf=0. - beta=g/theta(iz) !Buoyancy coefficient - - !print*,"FINDING Dup, k=",iz," zw=",zw(iz) - - if (iz .lt. kte) then !cant integrate upwards from highest level - - found = 0 - izz=iz - DO WHILE (found .EQ. 0) - - if (izz .lt. kte) then - dzt=dz(izz) ! layer depth above - zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz - !print*," ",iz,izz,theta(izz),dz(izz) - zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1 - zzz=zzz+dzt ! depth of layer iz to izz+1 - !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz) - if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then - bbb=(theta(izz+1)-theta(izz))/dzt - if (bbb .ne. 0.) then - !fractional distance up into the layer where TKE becomes < PE - tl=(-beta*(theta(izz)-theta(iz)) + & - & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + & - & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta - else - if (theta(izz) .ne. theta(iz))then - tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz))) - else - tl=0. - endif - endif - dlu(iz)=zzz-dzt+tl - !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl - found =1 - endif - zup_inf=zup - izz=izz+1 - ELSE - found = 1 - ENDIF - - ENDDO - - endif - - !---------------------------------- - ! FIND DISTANCE DOWN - !---------------------------------- - zdo=0. - zdo_sup=0. - dld(iz)=zw(iz) - zzz=0. - - !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz) - if (iz .gt. kts) then !cant integrate downwards from lowest level - - found = 0 - izz=iz - DO WHILE (found .EQ. 0) - - if (izz .gt. kts) then - dzt=dz(izz-1) - zdo=zdo+beta*theta(iz)*dzt - !print*," ",iz,izz,theta(izz),dz(izz-1) - zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2. - zzz=zzz+dzt - !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz) - if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then - bbb=(theta(izz)-theta(izz-1))/dzt - if (bbb .ne. 0.) then - tl=(beta*(theta(izz)-theta(iz))+ & - & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + & - & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta - else - if (theta(izz) .ne. theta(iz)) then - tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz))) - else - tl=0. - endif - endif - dld(iz)=zzz-dzt+tl - !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl - found = 1 - endif - zdo_sup=zdo - izz=izz-1 - ELSE - found = 1 - ENDIF - ENDDO - - endif - - !---------------------------------- - ! GET MINIMUM (OR AVERAGE) - !---------------------------------- - !The surface layer length scale can exceed z for large z/L, - !so keep maximum distance down > z. - dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos - lb1(iz) = min(dlu(iz),dld(iz)) !minimum - !JOE-fight floating point errors - dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) - dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) - lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest - !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average - - !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%). - lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax)) - lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax)) - - if (iz .eq. kte) then - lb1(kte) = lb1(kte-1) - lb2(kte) = lb2(kte-1) - endif - !print*,"IN MYNN-BouLac",kts, kte,lb1(iz) - !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz) - - ENDDO - - END SUBROUTINE boulac_length -! -! ================================================================== -! SUBROUTINE mym_turbulence: -! -! Input variables: see subroutine mym_initialize -! levflag : <>3; Level 2.5 -! = 3; Level 3 -! -! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. -! -! Output variables: see subroutine mym_initialize -! dfm(nx,nz,ny) : Diffusivity coefficient for momentum, -! divided by dz (not dz*h(i,j)) (m/s) -! dfh(nx,nz,ny) : Diffusivity coefficient for heat, -! divided by dz (not dz*h(i,j)) (m/s) -! dfq(nx,nz,ny) : Diffusivity coefficient for q^2, -! divided by dz (not dz*h(i,j)) (m/s) -! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l -! (K/s) -! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w -! (kg/kg s) -! pd?(nx,nz,ny) : Half of the production terms -! -! Only tcd and qcd are defined at the center of the grid boxes -! -! # DO NOT forget that tcd and qcd are added on the right-hand side -! of the equations for Theta_l and Q_w, respectively. -! -! Work arrays: see subroutine mym_initialize and level2 -! -! # dtl, dqw, dtv, gm and gh are allowed to share storage units with -! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. -! - SUBROUTINE mym_turbulence ( & - & kts,kte, & - & levflag, & - & dz, zw, & - & u, v, thl, ql, qw, & - & qke, tsq, qsq, cov, & - & vt, vq, & - & rmo, flt, flq, & - & zi,theta, & - & sh, & - & El, & - & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & - & bl_mynn_tkebudget, & - & Psig_bl,Psig_shcu,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & - & TKEprodTD, & - & spp_pbl,rstoch_col) - -!------------------------------------------------------------------- -! - INTEGER, INTENT(IN) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - INTEGER, INTENT(IN) :: levflag,bl_mynn_mixlength,bl_mynn_edmf - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,& - &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& - &TKEprodTD - - REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& - &pdk,pdt,pdq,pdc,tcd,qcd,el - - REAL, DIMENSION(kts:kte), INTENT(inout) :: & - qWT1D,qSHEAR1D,qBUOY1D,qDISS1D - REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new - REAL :: dudz,dvdz,dTdz,& - upwp,vpwp,Tpwp - INTEGER, INTENT(in) :: bl_mynn_tkebudget - - REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh - - INTEGER :: k -! REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c - REAL :: e6c,dzk,afk,abk,vtt,vqq,& - &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - - REAL :: zi, cldavg - REAL, DIMENSION(kts:kte), INTENT(in) :: theta - - REAL :: a2den, duz, ri, HLmod !JOE-Canuto/Kitamura mod -!JOE-stability criteria for cw - REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2 -!JOE-end - - DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel - DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv - DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden - -! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: prlimit - - -! -! tv0 = 0.61*tref -! gtr = 9.81/tref -! -! cc2 = 1.0-c2 -! cc3 = 1.0-c3 -! e1c = 3.0*a2*b2*cc3 -! e2c = 9.0*a1*a2*cc2 -! e3c = 9.0*a2*a2*cc2*( 1.0-c5 ) -! e4c = 12.0*a1*a2*cc2 -! e5c = 6.0*a1*a1 -! - - CALL mym_level2 (kts,kte,& - & dz, & - & u, v, thl, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! - CALL mym_length ( & - & kts,kte, & - & dz, zw, & - & rmo, flt, flq, & - & vt, vq, & - & qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength, & - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf ) -! - - DO k = kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - elsq = el (k)**2 - q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) - q3sq = qkw(k)**2 - -!JOE-Canuto/Kitamura mod - duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 - duz = duz /dzk**2 - ! ** Gradient Richardson number ** - ri = -gh(k)/MAX( duz, 1.0e-10 ) - IF (CKmod .eq. 1) THEN - a2den = 1. + MAX(ri,0.0) - ELSE - a2den = 1. + 0.0 - ENDIF -!JOE-end -! -! Modified: Dec/22/2005, from here, (dlsq -> elsq) - gmel = gm (k)*elsq - ghel = gh (k)*elsq -! Modified: Dec/22/2005, up to here - - ! Level 2.0 debug prints - IF ( debug_code ) THEN - IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN - print*,"MYNN; mym_turbulence2.0; sh=",sh(k)," k=",k - print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - print*," qke=",qke(k)," el=",el(k)," ri=",ri - print*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - ENDIF - -!JOE-Apply Helfand & Labraga stability check for all Ric -! when CKmod == 1. (currently not forced below) - IF (CKmod .eq. 1) THEN - HLmod = q2sq -1. - ELSE - HLmod = q3sq - ENDIF - -! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** - -!JOE-test new stability criteria in level 2.5 (as well as level 3) - little/no impact -! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) -!JOE-end - - IF ( q3sq .LT. q2sq ) THEN - !IF ( HLmod .LT. q2sq ) THEN - !Apply Helfand & Labraga mod - qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) - sm(k) = sm(k) * qdiv - sh(k) = sh(k) * qdiv -! - !JOE-Canuto/Kitamura mod - !e1 = q3sq - e1c*ghel * qdiv**2 - !e2 = q3sq - e2c*ghel * qdiv**2 - !e3 = e1 + e3c*ghel * qdiv**2 - !e4 = e1 - e4c*ghel * qdiv**2 - e1 = q3sq - e1c*ghel/a2den * qdiv**2 - e2 = q3sq - e2c*ghel/a2den * qdiv**2 - e3 = e1 + e3c*ghel/(a2den**2) * qdiv**2 - e4 = e1 - e4c*ghel/a2den * qdiv**2 - eden = e2*e4 + e3*e5c*gmel * qdiv**2 - eden = MAX( eden, 1.0d-20 ) - ELSE - !JOE-Canuto/Kitamura mod - !e1 = q3sq - e1c*ghel - !e2 = q3sq - e2c*ghel - !e3 = e1 + e3c*ghel - !e4 = e1 - e4c*ghel - e1 = q3sq - e1c*ghel/a2den - e2 = q3sq - e2c*ghel/a2den - e3 = e1 + e3c*ghel/(a2den**2) - e4 = e1 - e4c*ghel/a2den - eden = e2*e4 + e3*e5c*gmel - eden = MAX( eden, 1.0d-20 ) - - qdiv = 1.0 - sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden - !JOE-Canuto/Kitamura mod - !sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - sh(k) = q3sq*(a2/a2den)*( e2+3.0*c1*e5c*gmel )/eden - END IF !end Helfand & Labraga check - - !JOE: Level 2.5 debug prints - ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 - IF ( debug_code ) THEN - IF (sh(k)<0.0 .OR. sm(k)<0.0 .OR. & - sh(k) > 0.76*b2 .or. (sm(k)**2*gm(k) .gt. .44**2)) THEN - print*,"MYNN; mym_turbulence2.5; sh=",sh(k)," k=",k - print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - print*," qke=",qke(k)," el=",el(k)," ri=",ri - print*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - ENDIF - -! ** Level 3 : start ** - IF ( levflag .EQ. 3 ) THEN - t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2 - r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2 - c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k) - t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 ) - r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 ) - c3sq = cov(k)*abk+cov(k-1)*afk - -! Modified: Dec/22/2005, from here - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) -! - vtt = 1.0 +vt(k)*abk +vt(k-1)*afk - vqq = tv0 +vq(k)*abk +vq(k-1)*afk - t2sq = vtt*t2sq +vqq*c2sq - r2sq = vtt*c2sq +vqq*r2sq - c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 ) - t3sq = vtt*t3sq +vqq*c3sq - r3sq = vtt*c3sq +vqq*r3sq - c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 ) -! - cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden ) -! -! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) -! -! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** - !JOE: use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10) - ! to calculate an exact limit for c3sq: - auh = 27.*a1*((a2/a2den)**2)*b2*(g/tref)**2 - aum = 54.*(a1**2)*(a2/a2den)*b2*c1*(g/tref) - adh = 9.*a1*((a2/a2den)**2)*(12.*a1 + 3.*b2)*(g/tref)**2 - adm = 18.*(a1**2)*(a2/a2den)*(b2 - 3.*(a2/a2den))*(g/tref) - - aeh = (9.*a1*((a2/a2den)**2)*b1 +9.*a1*((a2/a2den)**2)* & - (12.*a1 + 3.*b2))*(g/tref) - aem = 3.*a1*(a2/a2den)*b1*(3.*(a2/a2den) + 3.*b2*c1 + & - (18.*a1*c1 - b2)) + & - (18.)*(a1**2)*(a2/a2den)*(b2 - 3.*(a2/a2den)) - - Req = -aeh/aem - Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req) - !For now, use default values, since tests showed little/no sensitivity - Rsl = .12 !lower limit - Rsl2= 1.0 - 2.*Rsl !upper limit - !IF (k==2)print*,"Dynamic limit RSL=",Rsl - !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN - ! print*,'--- ERROR: MYNN: Dynamic Cw '// & - ! 'limit exceeds reasonable limits' - ! print*," MYNN: Dynamic Cw limit needs attention=",Rsl - !ENDIF - - !JOE-Canuto/Kitamura mod - !e2 = q3sq - e2c*ghel * qdiv**2 - !e3 = q3sq + e3c*ghel * qdiv**2 - !e4 = q3sq - e4c*ghel * qdiv**2 - e2 = q3sq - e2c*ghel/a2den * qdiv**2 - e3 = q3sq + e3c*ghel/(a2den**2) * qdiv**2 - e4 = q3sq - e4c*ghel/a2den * qdiv**2 - eden = e2*e4 + e3 *e5c*gmel * qdiv**2 - - !JOE-Canuto/Kitamura mod - !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & - ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) - wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & - & *( e2*e4c/a2den - e3c*e5c*gmel/(a2den**2) * qdiv**2 ) - - IF ( wden .NE. 0.0 ) THEN - !JOE: test dynamic limits - !clow = q3sq*( 0.12-cw25 )*eden/wden - !cupp = q3sq*( 0.76-cw25 )*eden/wden - clow = q3sq*( Rsl -cw25 )*eden/wden - cupp = q3sq*( Rsl2-cw25 )*eden/wden -! - IF ( wden .GT. 0.0 ) THEN - c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) - ELSE - c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp ) - END IF - END IF -! - e1 = e2 + e5c*gmel * qdiv**2 - eden = MAX( eden, 1.0d-20 ) -! Modified: Dec/22/2005, up to here - - !JOE-Canuto/Kitamura mod - !e6c = 3.0*a2*cc3*gtr * dlsq/elsq - e6c = 3.0*(a2/a2den)*cc3*gtr * dlsq/elsq - - !============================ - ! ** for Gamma_theta ** - !! enum = qdiv*e6c*( t3sq-t2sq ) - IF ( t2sq .GE. 0.0 ) THEN - enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) - ELSE - enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) - ENDIF - gamt =-e1 *enum /eden - - !============================ - ! ** for Gamma_q ** - !! enum = qdiv*e6c*( r3sq-r2sq ) - IF ( r2sq .GE. 0.0 ) THEN - enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) - ELSE - enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) - ENDIF - gamq =-e1 *enum /eden - - !============================ - ! ** for Sm' and Sh'd(Theta_V)/dz ** - !! enum = qdiv*e6c*( c3sq-c2sq ) - enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0) - - !JOE-Canuto/Kitamura mod - !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 - smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c/(a2den**2) + & - & e4c/a2den)*a1/(a2/a2den) - - gamv = e1 *enum*gtr/eden - sm(k) = sm(k) +smd - - !============================ - ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** - qdiv = 1.0 - - ! Level 3 debug prints - IF ( debug_code ) THEN - IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. & - qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN - print*," MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k - print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - print*," qke=",qke(k)," el=",el(k)," ri=",ri - print*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - ENDIF - -! ** Level 3 : end ** - - ELSE -! ** At Level 2.5, qdiv is not reset. ** - gamt = 0.0 - gamq = 0.0 - gamv = 0.0 - END IF -! -! Add stochastic perturbation of prandtl number limit - if (spp_pbl==1) then - prlimit = MIN(MAX(1.,2.5 + 5.0*rstoch_col(k)), 10.) - IF(sm(k) > sh(k)*Prlimit) THEN - sm(k) = sh(k)*Prlimit - ENDIF - ENDIF -! -! Add min background stability function (diffusivity) within model levels -! with active plumes and low cloud fractions. - cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) - IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN - cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) - !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & - ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & - ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - - ! for mass-flux columns - sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - ! for clouds - sm(k) = MAX(sm(k), 0.03*MIN(cldavg,1.0) ) - sh(k) = MAX(sh(k), 0.03*MIN(cldavg,1.0) ) - - ENDIF -! - elq = el(k)*qkw(k) - elh = elq*qdiv - - ! Production of TKE (pdk), T-variance (pdt), - ! q-variance (pdq), and covariance (pdc) - pdk(k) = elq*( sm(k)*gm(k) & - & +sh(k)*gh(k)+gamv ) + & ! JAYMES TKE - & TKEprodTD(k) ! JOE-top-down - pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) - pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) - pdc(k) = elh*( sh(k)*dtl(k)+gamt )& - &*dqw(k)*0.5 & - &+elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 - - ! Contergradient terms - tcd(k) = elq*gamt - qcd(k) = elq*gamq - - ! Eddy Diffusivity/Viscosity divided by dz - dfm(k) = elq*sm(k) / dzk - dfh(k) = elq*sh(k) / dzk -! Modified: Dec/22/2005, from here -! ** In sub.mym_predict, dfq for the TKE and scalar variance ** -! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) ** - dfq(k) = dfm(k) -! Modified: Dec/22/2005, up to here - - IF ( bl_mynn_tkebudget == 1) THEN - !TKE BUDGET - dudz = ( u(k)-u(k-1) )/dzk - dvdz = ( v(k)-v(k-1) )/dzk - dTdz = ( thl(k)-thl(k-1) )/dzk - - upwp = -elq*sm(k)*dudz - vpwp = -elq*sm(k)*dvdz - Tpwp = -elq*sh(k)*dTdz - Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp) - - IF ( k .EQ. kts+1 ) THEN - qWT1D(kts)=0. - q3sq_old =0. - qWTP_old =0. - !** Limitation on q, instead of L/q ** - dlsq1 = MAX(el(kts)**2,1.0) - IF ( q3sq_old/dlsq1 .LT. -gh(k) ) q3sq_old = -dlsq1*gh(k) - ENDIF - - !!!Vertical Transport Term - qWTP_new = elq*Sqfac*sm(k)*(q3sq - q3sq_old)/dzk - qWT1D(k) = 0.5*(qWTP_new - qWTP_old)/dzk - qWTP_old = elq*Sqfac*sm(k)*(q3sq - q3sq_old)/dzk - q3sq_old = q3sq - - !!!Shear Term - !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) - qSHEAR1D(k) = elq*sm(k)*gm(k) - - !!!Buoyancy Term - !!!qBUOY1D(k)=g*Tpwp/thl(k) - !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv) - qBUOY1D(k) = elq*(sh(k)*(-dTdz*g/thl(k)) + gamv) - - !!!Dissipation Term - qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) - ENDIF - - END DO -! - - dfm(kts) = 0.0 - dfh(kts) = 0.0 - dfq(kts) = 0.0 - tcd(kts) = 0.0 - qcd(kts) = 0.0 - - tcd(kte) = 0.0 - qcd(kte) = 0.0 - -! - DO k = kts,kte-1 - dzk = dz(k) - tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk ) - qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) - END DO -! - - IF ( bl_mynn_tkebudget == 1) THEN - !JOE-TKE BUDGET - qWT1D(kts)=0. - qSHEAR1D(kts)=qSHEAR1D(kts+1) - qBUOY1D(kts)=qBUOY1D(kts+1) - qDISS1D(kts)=qDISS1D(kts+1) - ENDIF - - if (spp_pbl==1) then - DO k = kts,kte - dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) - dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) - END DO - endif - -! RETURN -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_turbulence - -! ================================================================== -! SUBROUTINE mym_predict: -! -! Input variables: see subroutine mym_initialize and turbulence -! qke(nx,nz,ny) : qke at (n)th time level -! tsq, ...cov : ditto -! -! Output variables: -! qke(nx,nz,ny) : qke at (n+1)th time level -! tsq, ...cov : ditto -! -! Work arrays: -! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s) -! bp (nx,nz,ny) : = 1/2*F, see below -! rp (nx,nz,ny) : = P-1/2*F*Q, see below -! -! # The equation for a turbulent quantity Q can be expressed as -! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1) -! where A is the advection, D the diffusion, P the production, -! F*Q the dissipation and h and v denote horizontal and vertical, -! respectively. If Q is q^2, F is 2q/B_1L. -! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite -! difference equation is written as -! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} ) -! + dt/2*( Dv{n} - Av{n} - F*Q{n} ) -! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2) -! where n denotes the time level. -! When the advection and diffusion terms are discretized as -! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3) -! Eq.(2) can be rewritten as -! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1) -! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} ) -! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4) -! where Q on the left-hand side is at (n+1)th time level. -! -! In this subroutine, a(k), b(k) and c(k) are obtained from -! subprogram coefvu and are passed to subprogram tinteg via -! common. 1/2*F and P-1/2*F*Q are stored in bp and rp, -! respectively. Subprogram tinteg solves Eq.(4). -! -! Modify this subroutine according to your numerical integration -! scheme (program). -! -!------------------------------------------------------------------- - SUBROUTINE mym_predict (kts,kte,& - & levflag, & - & delt,& - & dz, & - & ust, flt, flq, pmz, phh, & - & el, dfq, & - & pdk, pdt, pdq, pdc,& - & qke, tsq, qsq, cov, & - & s_aw,s_awqke,bl_mynn_edmf_tke & - &) - -!------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - INTEGER, INTENT(IN) :: levflag - INTEGER, INTENT(IN) :: bl_mynn_edmf_tke - REAL, INTENT(IN) :: delt - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq,el - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - REAL, INTENT(IN) :: flt, flq, ust, pmz, phh - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov -! WA 8/3/15 - REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw - - INTEGER :: k - REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q - REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff - REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(kts:kte) :: a,b,c,d,x - - - ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) - IF (bl_mynn_edmf_tke == 0) THEN - onoff=0.0 - ELSE - onoff=1.0 - ENDIF - -! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** - vkz = vk*0.5*dz(kts) -! -! ** dfq for the TKE is 3.0*dfm. ** -! - DO k = kts,kte -!! qke(k) = MAX(qke(k), 0.0) - qkw(k) = SQRT( MAX( qke(k), 0.0 ) ) - df3q(k)=Sqfac*dfq(k) - dtz(k)=delt/dz(k) - END DO -! - pdk1 = 2.0*ust**3*pmz/( vkz ) - phm = 2.0/ust *phh/( vkz ) - pdt1 = phm*flt**2 - pdq1 = phm*flq**2 - pdc1 = phm*flt*flq -! -! ** pdk(i,j,1)+pdk(i,j,2) corresponds to pdk1. ** - pdk(kts) = pdk1 -pdk(kts+1) - -!! pdt(kts) = pdt1 -pdt(kts+1) -!! pdq(kts) = pdq1 -pdq(kts+1) -!! pdc(kts) = pdc1 -pdc(kts+1) - pdt(kts) = pdt(kts+1) - pdq(kts) = pdq(kts+1) - pdc(kts) = pdc(kts+1) -! -! ** Prediction of twice the turbulent kinetic energy ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b1l = b1*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b1l - rp(k) = pdk(k+1) + pdk(k) - END DO - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt. - DO k=kts,kte-1 -! a(k-kts+1)=-dtz(k)*df3q(k) -! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt -! c(k-kts+1)=-dtz(k)*df3q(k+1) -! d(k-kts+1)=rp(k)*delt + qke(k) -! WA 8/3/15 add EDMF contribution - a(k-kts+1)=-dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff - b(k-kts+1)=1. + dtz(k)*(df3q(k)+df3q(k+1)) & - + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt - c(k-kts+1)=-dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff - d(k-kts+1)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*df3q(k) -!! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1)) -!! c(k-kts+1)=-dtz(k)*df3q(k+1) -!! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt -!! ENDDO - - a(kte)=-1. !0. - b(kte)=1. - c(kte)=0. - d(kte)=0. - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! qke(k)=max(d(k-kts+1), 1.e-4) - qke(k)=max(x(k), 1.e-4) - ENDDO - - - IF ( levflag .EQ. 3 ) THEN -! -! Modified: Dec/22/2005, from here -! ** dfq for the scalar variance is 1.0*dfm. ** -! CALL coefvu ( dfq, 1.0 ) make change here -! Modified: Dec/22/2005, up to here -! -! ** Prediction of the temperature variance ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdt(k+1) + pdt(k) - END DO - -!zero gradient for tsq at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*dfq(k) - b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*dfq(k+1) - d(k-kts+1)=rp(k)*delt + tsq(k) - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt -!! ENDDO - - a(kte)=-1. !0. - b(kte)=1. - c(kte)=0. - d(kte)=0. - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! tsq(k)=d(k-kts+1) - tsq(k)=x(k) - ENDDO - -! ** Prediction of the moisture variance ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdq(k+1) +pdq(k) - END DO - -!zero gradient for qsq at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*dfq(k) - b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*dfq(k+1) - d(k-kts+1)=rp(k)*delt + qsq(k) - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + qsq(k) -qsq(k)*bp(k)*delt -!! ENDDO - - a(kte)=-1. !0. - b(kte)=1. - c(kte)=0. - d(kte)=0. - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! qsq(k)=d(k-kts+1) - qsq(k)=x(k) - ENDDO - -! ** Prediction of the temperature-moisture covariance ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdc(k+1) + pdc(k) - END DO - -!zero gradient for tqcov at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*dfq(k) - b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*dfq(k+1) - d(k-kts+1)=rp(k)*delt + cov(k) - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt -!! ENDDO - - a(kte)=-1. !0. - b(kte)=1. - c(kte)=0. - d(kte)=0. - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! cov(k)=d(k-kts+1) - cov(k)=x(k) - ENDDO - - ELSE -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - IF ( qkw(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) - END IF -! - tsq(k) = b2l*( pdt(k+1)+pdt(k) ) - qsq(k) = b2l*( pdq(k+1)+pdq(k) ) - cov(k) = b2l*( pdc(k+1)+pdc(k) ) - END DO - -!! tsq(kts)=tsq(kts+1) -!! qsq(kts)=qsq(kts+1) -!! cov(kts)=cov(kts+1) - - tsq(kte)=tsq(kte-1) - qsq(kte)=qsq(kte-1) - cov(kte)=cov(kte-1) - - END IF - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_predict - -! ================================================================== -! SUBROUTINE mym_condensation: -! -! Input variables: see subroutine mym_initialize and turbulence -! exner(nz) : Perturbation of the Exner function (J/kg K) -! defined on the walls of the grid boxes -! This is usually computed by integrating -! d(pi)/dz = h*g*tv/tref**2 -! from the upper boundary, where tv is the -! virtual potential temperature minus tref. -! -! Output variables: see subroutine mym_initialize -! cld(nx,nz,ny) : Cloud fraction -! -! Work arrays: -! qmq(nx,nz,ny) : Q_w-Q_{sl}, where Q_{sl} is the saturation -! specific humidity at T=Tl -! alp(nx,nz,ny) : Functions in the condensation process -! bet(nx,nz,ny) : ditto -! sgm(nx,nz,ny) : Combined standard deviation sigma_s -! multiplied by 2/alp -! -! # qmq, alp, bet and sgm are allowed to share storage units with -! any four of other work arrays for saving memory. -! -! # Results are sensitive particularly to values of cp and rd. -! Set these values to those adopted by you. -! -!------------------------------------------------------------------- - SUBROUTINE mym_condensation (kts,kte, & - & dx, dz, & - & thl, qw, & - & p,exner, & - & tsq, qsq, cov, & - & Sh, el, bl_mynn_cloudpdf,& - & qc_bl1D, cldfra_bl1D, & - & PBLH1,HFX1, & - & Vt, Vq, th, sgm, rmo, & - & spp_pbl,rstoch_col ) - -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz - REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, & - &tsq, qsq, cov, th - - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm - - REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,cld,RH - REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,cldfra_bl1D - DOUBLE PRECISION :: t3sq, r3sq, c3sq - - REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,eq1,qll,& - &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,ls_min,ls,wt - INTEGER :: i,j,k - - REAL :: erf - - !JOE: NEW VARIABLES FOR ALTERNATE SIGMA - REAL::dth,dtl,dqw,dzk,els - REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el - - !JOE: variables for BL clouds - REAL::zagl,cld9,damp,edown,RHcrit,RHmean,RHsum,RHnum,Hshcu,PBLH2,ql_limit - REAL, PARAMETER :: Hfac = 3.0 !cloud depth factor for HFX (m^3/W) - REAL, PARAMETER :: HFXmin = 50.0 !min W/m^2 for BL clouds - REAL :: RH_00L, RH_00O, phi_dz, lfac - REAL, PARAMETER :: cdz = 2.0 - REAL, PARAMETER :: mdz = 1.5 - - !JAYMES: variables for tropopause-height estimation - REAL :: theta1, theta2, ht1, ht2 - INTEGER :: k_tropo - -! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: qw_pert - -! First, obtain an estimate for the tropopause height (k), using the method employed in the -! Thompson subgrid-cloud scheme. This height will be a consideration later when determining -! the "final" subgrid-cloud properties. -! JAYMES: added 3 Nov 2016, adapted from G. Thompson - - DO k = kte-3, kts, -1 - theta1 = th(k) - theta2 = th(k+2) - ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190) - ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190) - if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & - & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then - goto 86 - endif - ENDDO - 86 continue - k_tropo = MAX(kts+2, k+2) - - zagl = 0. - - SELECT CASE(bl_mynn_cloudpdf) - - CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME - - DO k = kts,kte-1 - t = th(k)*exner(k) - -!x if ( ct .gt. 0.0 ) then -! a = 17.27 -! b = 237.3 -!x else -!x a = 21.87 -!x b = 265.5 -!x end if -! -! ** 3.8 = 0.622*6.11 (hPa) ** - - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - !NOTE: negative bl_mynn_cloudpdf will zero-out the stratus subgrid clouds - ! at the end of this subroutine. - !Sommeria and Deardorff (1977) scheme, as implemented - !in Nakanishi and Niino (2009), Appendix B - t3sq = MAX( tsq(k), 0.0 ) - r3sq = MAX( qsq(k), 0.0 ) - c3sq = cov(k) - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) - r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq - !DEFICIT/EXCESS WATER CONTENT - qmq(k) = qw(k) -qsl - !ORIGINAL STANDARD DEVIATION: limit e-6 produces ~10% more BL clouds - !than e-10 - sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) - !NORMALIZED DEPARTURE FROM SATURATION - q1(k) = qmq(k) / sgm(k) - !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 - cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) - - END DO - - CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and - !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = 0.5*( dz(k) + dz(k-1) ) - end if - dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) - sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & - b2 * MAX(Sh(k),0.03))/4. * & - (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) - qmq(k) = qw(k) -qsl - q1(k) = qmq(k) / sgm(k) - cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) - END DO - - CASE (2, -2) - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !JAYMES- this added 27 Apr 2015 - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - xl = xl_blend(t) ! obtain latent heat - - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl - ! CB02, Eqn. 4 - - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - - !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - - !qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; - ! the numerator of Q1 - qmq(k) = a(k) * (qw_pert - qsat_tl) - - b(k) = a(k)*rsl ! CB02 variable "b" - - dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & - & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) - - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) - - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = 0.5*( dz(k) + dz(k-1) ) - end if - - cdhdz = dtl/dzk + (g/cpm)*(1.+qw(k)) ! expression below Eq. 9 - ! in CB02 - - zagl = zagl + dz(k) - !Use analog to surface layer length scale to make the cloud mixing length scale - !become less than z in stable conditions. - els = zagl/(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) - - ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) - ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: - if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) - ! 25 m < ls_min(=zagl) < 300 m - lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: - ! lfac(750 m) = 4.4 - ! lfac(3 km) = 5.0 - ! lfac(13 km) = 6.0 - - ls = MAX(MIN(lfac*el(k),600.),ls_min) ! Bounded: ls_min < ls < 600 m - ! Note: CB02 use 900 m as a constant free-atmosphere length scale. - - ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the - ! MYNN master length scale (el) must exceed 60 m before ls - ! becomes responsive to el, otherwise ls = ls_min = 300 m. - - sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: - & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, - & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, - & +b(k)**2 * cdhdz**2))) ! < 3rd term - ! CB02 use a multiplier of 0.2, but 0.225 is chosen - ! based on tests - - q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation - - cld(k) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - - END DO - - END SELECT - - zagl = 0. - RHsum=0. - RHnum=0. - RHmean=0.1 !initialize with small value for small PBLH cases - damp =0 - PBLH2=MAX(10.,PBLH1) - - SELECT CASE(bl_mynn_cloudpdf) - - CASE (-1 : 1) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME - ! OR KUWANO ET AL. - DO k = kts,kte-1 - t = th(k)*exner(k) - q1k = q1(k) - zagl = zagl + dz(k) - !q1=0. - !cld(k)=0. - - !COMPUTE MEAN RH IN PBL (NOT PRESSURE WEIGHTED). - IF (zagl < PBLH2 .AND. PBLH2 > 400.) THEN - RHsum=RHsum+RH(k) - RHnum=RHnum+1.0 - RHmean=RHsum/RHnum - ENDIF - - RHcrit = 1. - 0.35*(1.0 - (MAX(250.- MAX(HFX1,HFXmin),0.0)/200.)**2) - if (HFX1 > HFXmin) then - cld9=MIN(MAX(0., (rh(k)-RHcrit)/(1.1-RHcrit)), 1.)**2 - else - cld9=0.0 - endif - - edown=PBLH2*.1 - !Vary BL cloud depth (Hshcu) by mean RH in PBL and HFX - !(somewhat following results from Zhang and Klein (2013, JAS)) - Hshcu=200. + (RHmean+0.5)**1.5*MAX(HFX1,0.)*Hfac - if (zagl < PBLH2-edown) then - damp=MIN(1.0,exp(-ABS(((PBLH2-edown)-zagl)/edown))) - elseif(zagl >= PBLH2-edown .AND. zagl < PBLH2+Hshcu)then - damp=1. - elseif (zagl >= PBLH2+Hshcu)then - damp=MIN(1.0,exp(-ABS((zagl-(PBLH2+Hshcu))/500.))) - endif - cldfra_bl1D(k)=cld9*damp - !cldfra_bl1D(k)=cld(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value - - !use alternate cloud fraction to estimate qc for use in BL clouds-radiation - eq1 = rrp*EXP( -0.5*q1k*q1k ) - qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql (k) = alp(k)*sgm(k)*qll - if(cldfra_bl1D(k)>0.01 .and. ql(k)<1.E-6)ql(k)=1.E-6 - qc_bl1D(k)=ql(k)*damp - !qc_bl1D(k)=ql(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value - - !now recompute estimated lwc for PBL scheme's use - !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and - !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 - eq1 = rrp*EXP( -0.5*q1k*q1k ) - qll = MAX( cld(k)*q1k + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql (k) = alp(k)*sgm(k)*qll - - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*ql(k) ! potential temp - - !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) - qt = 1.0 +p608*qw(k) -(1.+p608)*ql(k) - rac = alp(k)*( cld(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) - - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt(k) = qt-1.0 -rac*bet(k) - vq(k) = p608*pt-tv0 +rac - - !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, - ! add limit to qc_bl and cldfra_bl: - IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 - IF (CLDFRA_BL1D(k) < 1E-2)THEN - CLDFRA_BL1D(k)=0. - QC_BL1D(k)=0. - ENDIF - - END DO - CASE ( 2, -2) - ! JAYMES- this option added 8 May 2015 - ! The cloud water formulations are taken from CB02, Eq. 8. - ! "fng" represents the non-Gaussian contribution to the liquid - ! water flux; these formulations are from Cuijpers and Bechtold - ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, - ! hereafter BCMT95 - DO k = kts,kte-1 - t = th(k)*exner(k) - q1k = q1(k) - zagl = zagl + dz(k) - IF (q1k < 0.) THEN - ql (k) = sgm(k)*EXP(1.2*q1k-1) - ELSE IF (q1k > 2.) THEN - ql (k) = sgm(k)*q1k - ELSE - ql (k) = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - ENDIF - - !Above tropopause: eliminate subgrid clouds from CB scheme - if (k .ge. k_tropo-1) then - cld(k) = 0. - ql(k) = 0. - endif - - !Buoyancy-flux-related calculations follow... - ! "Fng" represents the non-Gaussian transport factor - ! (non-dimensional) from from Bechtold et al. 1995 - ! (hereafter BCMT95), section 3(c). Their suggested - ! forms for Fng (from their Eq. 20) are: - !IF (q1k < -2.) THEN - ! Fng = 2.-q1k - !ELSE IF (q1k > 0.) THEN - ! Fng = 1. - !ELSE - ! Fng = 1.-1.5*q1k - !ENDIF - ! For purposes of the buoyancy flux in stratus, we will use Fng = 1 - !Fng = 1. - Q1(k)=MAX(Q1(k),-5.0) - IF (Q1(k) .GE. 1.0) THEN - Fng = 1.0 - ELSEIF (Q1(k) .GE. -1.7 .AND. Q1(k) < 1.0) THEN - Fng = EXP(-0.4*(Q1(k)-1.0)) - ELSEIF (Q1(k) .GE. -2.5 .AND. Q1(k) .LE. -1.7) THEN - Fng = 3.0 + EXP(-3.8*(Q1(k)+1.7)) - ELSE - Fng = MIN(23.9 + EXP(-1.6*(Q1(k)+2.5)), 60.) - ENDIF - Fng = MIN(Fng, 20.) - - xl = xl_blend(t) - bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from - ! "b" in CB02 (i.e., b(k) above) by a factor - ! of T/theta. Strictly, b(k) above is formulated in - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qw(k) - alpha = 0.61*th(k) - beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - - vt(k) = qww - MIN(cld(k),0.99)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(cld(k),0.99)*beta*a(k)*Fng - tv0 - ! vt and vq correspond to beta-theta and beta-q, respectively, - ! in NN09, Eq. B8. They also correspond to the bracketed - ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng - ! The "-1" and "-tv0" terms are included for consistency with - ! the legacy vt and vq formulations (above). - - ! increase the cloud fraction estimate below PBLH+1km - if (zagl .lt. PBLH2+1000.) cld(k) = MIN( 1., 1.5*cld(k) ) - ! return a cloud condensate and cloud fraction for icloud_bl option: - cldfra_bl1D(k) = cld(k) - qc_bl1D(k) = ql(k) - - !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, - ! add limit to qc_bl and cldfra_bl: - IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 - IF (CLDFRA_BL1D(k) < 1E-2)THEN - CLDFRA_BL1D(k)=0. - QC_BL1D(k)=0. - ENDIF - - END DO - - END SELECT !end cloudPDF option - - !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. - IF (bl_mynn_cloudpdf .LT. 0) THEN - DO k = kts,kte-1 - cldfra_bl1D(k) = 0.0 - qc_bl1D(k) = 0.0 - END DO - ENDIF -! - cld(kte) = cld(kte-1) - ql(kte) = ql(kte-1) - vt(kte) = vt(kte-1) - vq(kte) = vq(kte-1) - qc_bl1D(kte)=0. - cldfra_bl1D(kte)=0. - - RETURN - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_condensation - -! ================================================================== - SUBROUTINE mynn_tendencies(kts,kte, & - &levflag,grav_settling, & - &delt,dz,rho, & - &u,v,th,tk,qv,qc,qi,qnc,qni, & - &p,exner, & - &thl,sqv,sqc,sqi,sqw, & - &qnwfa,qnifa, & - &ust,flt,flq,flqv,flqc,wspd,qcg, & - &uoce,voce, & - &tsq,qsq,cov, & - &tcd,qcd, & - &dfm,dfh,dfq, & - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & - &Dqnwfa,Dqnifa, & - &vdfg1,diss_heat, & - &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & - &s_awu,s_awv, & - &s_awqnc,s_awqni, & - &s_awqnwfa,s_awqnifa, & - &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & - &FLAG_QNWFA,FLAG_QNIFA, & - &cldfra_bl1d, & - &ztop_shallow,ktop_shallow, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) - -!------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - INTEGER, INTENT(in) :: grav_settling,levflag - INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& - bl_mynn_edmf,bl_mynn_edmf_mom, & - bl_mynn_mixscalars - LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA - -!! grav_settling = 1 or 2 for gravitational settling of droplets -!! grav_settling = 0 otherwise -! thl - liquid water potential temperature -! qw - total water -! dfm,dfh,dfq - as above -! flt - surface flux of thl -! flq - surface flux of qw - - REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,& - &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv,s_awqnwfa,s_awqnifa - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qni,qnc,& - &rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d,diss_heat - REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,& - &qnwfa,qnifa,dfm,dfh - REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& - &dqni,dqnc,dqnwfa,dqnifa - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg,& - ztop_shallow - INTEGER, INTENT(IN) :: ktop_shallow - -! REAL, INTENT(IN) :: delt,ust,flt,flq,qcg,& -! &gradu_top,gradv_top,gradth_top,gradqv_top - -!local vars - - REAL, DIMENSION(kts:kte) :: dtz,vt,vq,dfhc,dfmc !Kh for clouds (Pr < 2) - REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING - qnwfa2,qnifa2 - REAL, DIMENSION(kts:kte) :: zfac,plumeKh - REAL, DIMENSION(kts:kte) :: a,b,c,d,x - REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface - & khdz, kmdz - REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw - REAL :: grav_settling2,vdfg1 !Katata-fogdes - REAL :: t,esat,qsl,onoff,kh,km,dzk - INTEGER :: k,kk - - !Activate nonlocal mixing from the mass-flux scheme for - !scalars (0.0 = no; 1.0 = yes) - REAL, PARAMETER :: nonloc = 0.0 - - dztop=.5*(dz(kte)+dz(kte-1)) - - ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) - ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so - ! we only need to zero-out the MF term - IF (bl_mynn_edmf_mom == 0) THEN - onoff=0.0 - ELSE - onoff=1.0 - ENDIF - - !Prepare "constants" for diffusion equation. - !khdz = rho*Kh/dz - dtz(kts)=delt/dz(kts) - kh=dfh(kts)*dz(kts) - km=dfm(kts)*dz(kts) - rhoz(kts)=rho(kts) - khdz(kts)=rhoz(kts)*kh/dz(kts) - kmdz(kts)=rhoz(kts)*km/dz(kts) - DO k=kts+1,kte - dtz(k)=delt/dz(k) - rhoz(k)=(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) - - dzk = 0.5 *( dz(k)+dz(k-1) ) - kh = dfh(k)*dzk - km = dfm(k)*dzk - khdz(k)= rhoz(k)*kh/dzk - kmdz(k)= rhoz(k)*km/dzk - ENDDO - rhoz(kte+1)=rho(kte) - kh=dfh(kte)*dz(kte) - km=dfm(kte)*dz(kte) - khdz(kte+1)=rhoz(kte+1)*kh/dz(kte) - kmdz(kte+1)=rhoz(kte+1)*km/dz(kte) - -!!============================================ -!! u -!!============================================ - - k=kts - - a(1)=0. - b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff - c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff - d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff - -!JOE - tend test -! a(k)=0. -! b(k)=1.+dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(k)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + & -! dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff - - DO k=kts+1,kte-1 - a(k)= - dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff - b(k)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff - c(k)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*(s_awu(k)-s_awu(k+1))*onoff - ENDDO - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradu_top*dztop - -!! prescribed value - a(kte)=0 - b(kte)=1. - c(kte)=0. - d(kte)=u(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! du(k)=(d(k-kts+1)-u(k))/delt - du(k)=(x(k)-u(k))/delt - ENDDO - -!!============================================ -!! v -!!============================================ - - k=kts - - a(1)=0. - b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff - c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -!! d(1)=v(k) - d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff - -!JOE - tend test -! a(k)=0. -! b(k)=1.+dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(k)= -dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + & -! dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff - - DO k=kts+1,kte-1 - a(k)= - dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff - b(k)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff - c(k)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*(s_awv(k)-s_awv(k+1))*onoff - ENDDO - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradv_top*dztop - -!! prescribed value - a(kte)=0 - b(kte)=1. - c(kte)=0. - d(kte)=v(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! dv(k)=(d(k-kts+1)-v(k))/delt - dv(k)=(x(k)-v(k))/delt - ENDDO - -!!============================================ -!! thl tendency -!! NOTE: currently, gravitational settling is removed -!!============================================ - k=kts - - a(k)=0. - b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & - & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt*dheat_opt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) - b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) & - & + diss_heat(k)*delt*dheat_opt - ENDDO - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -!assume gradthl_top=gradth_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradth_top*dztop - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=thl(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte - !thl(k)=d(k-kts+1) - thl(k)=x(k) - ENDDO - -IF (bl_mynn_mixqt > 0) THEN - !============================================ - ! MIX total water (sqw = sqc + sqv + sqi) - ! NOTE: no total water tendency is output; instead, we must calculate - ! the saturation specific humidity and then - ! subtract out the moisture excess (sqc & sqi) - !============================================ - - k=kts - - a(k)=0. - b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - - !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& - - d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) - b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - - d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) - ENDDO - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqw(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqw2) - -! DO k=kts,kte -! sqw2(k)=d(k-kts+1) -! ENDDO -ELSE - sqw2=sqw -ENDIF - -IF (bl_mynn_mixqt == 0) THEN -!============================================ -! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0), -! then sqc will be backed out of saturation check (below). -!============================================ - IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN - - k=kts - - a(k)=0. - b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - - d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt -dtz(k)*s_awqc(k+1) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) - b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - - d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) - ENDDO - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqc(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqc2) - -! DO k=kts,kte -! sqc2(k)=d(k-kts+1) -! ENDDO - ELSE - !If not mixing clouds, set "updated" array equal to original array - sqc2=sqc - ENDIF -ENDIF - -IF (bl_mynn_mixqt == 0) THEN - !============================================ - ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0), - ! then sqv will be backed out of saturation check (below). - !============================================ - - k=kts - - a(k)=0. - b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) - b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) - ENDDO - -! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -! specified gradient at the top -! assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqv(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqv2) - -! DO k=kts,kte -! sqv2(k)=d(k-kts+1) -! ENDDO -ELSE - sqv2=sqv -ENDIF - -!============================================ -! MIX CLOUD ICE ( sqi ) -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN - - k=kts - - a(k)=0. - b(k)=1.+dtz(k)*dfh(k+1) - c(k)= -dtz(k)*dfh(k+1) - d(k)=sqi(k) !+ qcd(k)*delt !should we have qcd for ice? - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*dfh(k) - b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(k)= -dtz(k)*dfh(k+1) - d(k)=sqi(k) !+ qcd(k)*delt - ENDDO - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqi(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqi2) - -! DO k=kts,kte -! sqi2(k)=d(k-kts+1) -! ENDDO -ELSE - sqi2=sqi -ENDIF - -!!============================================ -!! cloud ice number concentration (qni) -!!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNI .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)/rho(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qni(k) - dtz(k)*s_awqni(k+1)*nonloc - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))/rho(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qni(k) + dtz(k)*(s_awqni(k)-s_awqni(k+1))*nonloc - ENDDO - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qni(kte) - -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !qni2(k)=d(k-kts+1) - qni2(k)=x(k) - ENDDO - -ELSE - qni2=qni -ENDIF - -!!============================================ -!! cloud water number concentration (qnc) -!! include non-local transport -!!============================================ - IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)/rho(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnc(k) - dtz(k)*s_awqnc(k+1)*nonloc - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))/rho(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnc(k) + dtz(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc - ENDDO - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnc(kte) - -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !qnc2(k)=d(k-kts+1) - qnc2(k)=x(k) - ENDDO - -ELSE - qnc2=qnc -ENDIF - -!============================================ -! Water-friendly aerosols ( qnwfa ). -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNWFA .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)/rho(k) - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) - & - & 0.5*dtz(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnwfa(k) - dtz(k)*s_awqnwfa(k+1)*nonloc - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnwfa(k) + dtz(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc - ENDDO - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnwfa(kte) - -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !qnwfa2(k)=d(k) - qnwfa2(k)=x(k) - ENDDO - -ELSE - !If not mixing aerosols, set "updated" array equal to original array - qnwfa2=qnwfa -ENDIF - -!============================================ -! Ice-friendly aerosols ( qnifa ). -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNIFA .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)/rho(k) - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) - & - & 0.5*dtz(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnifa(k) - dtz(k)*s_awqnifa(k+1)*nonloc - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnifa(k) + dtz(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc - ENDDO - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnifa(kte) - -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !qnifa2(k)=d(k-kts+1) - qnifa2(k)=x(k) - ENDDO - -ELSE - !If not mixing aerosols, set "updated" array equal to original array - qnifa2=qnifa -ENDIF - - -!!============================================ -!! Compute tendencies and convert to mixing ratios for WRF. -!! Note that the momentum tendencies are calculated above. -!!============================================ - - IF (bl_mynn_mixqt > 0) THEN - DO k=kts,kte - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat=esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - - !IF (qsl >= sqw2(k)) THEN !unsaturated - ! sqv2(k) = MAX(0.0,sqw2(k)) - ! sqi2(k) = MAX(0.0,sqi2(k)) - ! sqc2(k) = MAX(0.0,sqw2(k) - sqv2(k) - sqi2(k)) - !ELSE !saturated - IF (FLAG_QI) THEN - !sqv2(k) = qsl - sqi2(k) = MAX(0., sqi2(k)) - sqc2(k) = MAX(0., sqw2(k) - sqi2(k) - qsl) !updated cloud water - sqv2(k) = MAX(0., sqw2(k) - sqc2(k) - sqi2(k)) !updated water vapor - ELSE - !sqv2(k) = qsl - sqi2(k) = 0.0 - sqc2(k) = MAX(0., sqw2(k) - qsl) !updated cloud water - sqv2(k) = MAX(0., sqw2(k) - sqc2(k)) ! updated water vapor - ENDIF - !ENDIF - ENDDO - ENDIF - - !===================== - ! WATER VAPOR TENDENCY - !===================== - DO k=kts,kte - Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt - !IF(-Dqv(k) > qv(k)) Dqv(k)=-qv(k) - ENDDO - - IF (bl_mynn_cloudmix > 0) THEN - !===================== - ! CLOUD WATER TENDENCY - !===================== - !qc fog settling tendency is now computed in module_bl_fogdes.F, so - !sqc should only be changed by eddy diffusion or mass-flux. - !print*,"FLAG_QC:",FLAG_QC - IF (FLAG_QC) THEN - DO k=kts,kte - Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt - IF(Dqc(k)*delt + qc(k) < 0.) THEN - !print*,' neg qc:',qsl,sqw2(k),sqi2(k),sqc2(k),qc(k),tk(k) - Dqc(k)=-qc(k)/delt - ENDIF - ENDDO - ELSE - DO k=kts,kte - Dqc(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD WATER NUM CONC TENDENCY - !=================== - IF (FLAG_QNC .AND. bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - !IF(sqc2(k)>1.e-9)qnc2(k)=MAX(qnc2(k),1.e6) - Dqnc(k) = (qnc2(k)-qnc(k))/delt - !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt - ENDDO - ELSE - DO k=kts,kte - Dqnc(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD ICE TENDENCY - !=================== - IF (FLAG_QI) THEN - DO k=kts,kte - Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt - IF(Dqi(k)*delt + qi(k) < 0.) THEN - ! !print*,' neg qi;',qsl,sqw2(k),sqi2(k),sqc2(k),qi(k),tk(k) - Dqi(k)=-qi(k)/delt - ENDIF - ENDDO - ELSE - DO k=kts,kte - Dqi(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD ICE NUM CONC TENDENCY - !=================== - IF (FLAG_QNI .AND. bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - Dqni(k)=(qni2(k)-qni(k))/delt - !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt - ENDDO - ELSE - DO k=kts,kte - Dqni(k)=0. - ENDDO - ENDIF - ELSE !-MIX CLOUD SPECIES? - !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0) - DO k=kts,kte - Dqc(k)=0. - Dqnc(k)=0. - Dqi(k)=0. - Dqni(k)=0. - ENDDO - ENDIF - - !=================== - ! THETA TENDENCY - !=================== - IF (FLAG_QI) THEN - DO k=kts,kte - Dth(k)=(thl(k) + xlvcp/exner(k)*sqc(k) & - & + xlscp/exner(k)*sqi(k) & - & - th(k))/delt - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy: - !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k) & - ! & + xlscp/MAX(tk(k),TKmin)*sqi2(k)) & - ! & - th(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k)) & - !& - th(k))/delt - ENDDO - ENDIF - - !=================== - ! AEROSOL TENDENCIES - !=================== - IF (FLAG_QNWFA .AND. FLAG_QNIFA .AND. & - bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - !===================== - ! WATER-friendly aerosols - !===================== - Dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt - !===================== - ! Ice-friendly aerosols - !===================== - Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dqnwfa(k)=0. - Dqnifa(k)=0. - ENDDO - ENDIF - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mynn_tendencies - -! ================================================================== -#if (WRF_CHEM == 1) - SUBROUTINE mynn_mix_chem(kts,kte, & - levflag,grav_settling, & - delt,dz, & - nchem, kdvel, ndvel, num_vert_mix, & - chem1, vd1, & - qnc,qni, & - p,exner, & - thl,sqv,sqc,sqi,sqw, & - ust,flt,flq,flqv,flqc,wspd,qcg, & - uoce,voce, & - tsq,qsq,cov, & - tcd,qcd, & - dfm,dfh,dfq, & - s_aw, & - s_awchem, & - bl_mynn_cloudmix) - -!------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte - INTEGER, INTENT(in) :: grav_settling,levflag - INTEGER, INTENT(in) :: bl_mynn_cloudmix - - REAL, DIMENSION(kts:kte), INTENT(IN) :: qni,qnc,& - &p,exner,dfm,dfh,dfq,dz,tsq,qsq,cov,tcd,qcd - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: thl,sqw,sqv,sqc,sqi - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg - INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix - REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw - REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 - REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem - REAL, DIMENSION( ndvel ), INTENT(INOUT) :: vd1 - -!local vars - - REAL, DIMENSION(kts:kte) :: dtz,vt,vq - REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d - REAL :: rhs,gfluxm,gfluxp,dztop - REAL :: t,esl,qsl - INTEGER :: k,kk - INTEGER :: ic ! Chemical array loop index - REAL, DIMENSION( kts:kte, nchem ) :: chem_new - - dztop=.5*(dz(kte)+dz(kte-1)) - - DO k=kts,kte - dtz(k)=delt/dz(k) - ENDDO - - !============================================ - ! Patterned after mixing of water vapor in mynn_tendencies. - !============================================ - - DO ic = 1,nchem - k=kts - - a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - c(1)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) - dtz(k)*s_awchem(k+1,ic) - - DO k=kts+1,kte-1 - a(k)=-dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) - b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - ! d(kk)=chem1(k,ic) + qcd(k)*delt - d(k)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) - ENDDO - - ! prescribed value at top - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=chem1(kte,ic) - - CALL tridiag(kte,a,b,c,d) - - DO k=kts,kte - chem_new(k,ic)=d(k-kts+1) - ENDDO - ENDDO - - END SUBROUTINE mynn_mix_chem -#endif - -! ================================================================== - SUBROUTINE retrieve_exchange_coeffs(kts,kte,& - &dfm,dfh,dz,K_m,K_h) - -!------------------------------------------------------------------- - - INTEGER , INTENT(in) :: kts,kte - - REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh - - REAL, DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h - - - INTEGER :: k - REAL :: dzk - - K_m(kts)=0. - K_h(kts)=0. - - DO k=kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - K_m(k)=dfm(k)*dzk - K_h(k)=dfh(k)*dzk - ENDDO - - END SUBROUTINE retrieve_exchange_coeffs - -! ================================================================== - SUBROUTINE tridiag(n,a,b,c,d) - -!! to solve system of linear eqs on tridiagonal matrix n times n -!! after Peaceman and Rachford, 1955 -!! a,b,c,d - are vectors of order n -!! a,b,c - are coefficients on the LHS -!! d - is initially RHS on the output becomes a solution vector - -!------------------------------------------------------------------- - - INTEGER, INTENT(in):: n - REAL, DIMENSION(n), INTENT(in) :: a,b - REAL, DIMENSION(n), INTENT(inout) :: c,d - - INTEGER :: i - REAL :: p - REAL, DIMENSION(n) :: q - - c(n)=0. - q(1)=-c(1)/b(1) - d(1)=d(1)/b(1) - - DO i=2,n - p=1./(b(i)+a(i)*q(i-1)) - q(i)=-c(i)*p - d(i)=(d(i)-a(i)*d(i-1))*p - ENDDO - - DO i=n-1,1,-1 - d(i)=d(i)+q(i)*d(i+1) - ENDDO - - END SUBROUTINE tridiag - -! ================================================================== - subroutine tridiag2(n,a,b,c,d,x) - implicit none -! a - sub-diagonal (means it is the diagonal below the main diagonal) -! b - the main diagonal -! c - sup-diagonal (means it is the diagonal above the main diagonal) -! d - right part -! x - the answer -! n - number of unknowns (levels) - - integer,intent(in) :: n - real, dimension(n),intent(in) :: a,b,c,d - real ,dimension(n),intent(out) :: x - real ,dimension(n) :: cp,dp - real :: m - integer :: i - - ! initialize c-prime and d-prime - cp(1) = c(1)/b(1) - dp(1) = d(1)/b(1) - ! solve for vectors c-prime and d-prime - do i = 2,n - m = b(i)-cp(i-1)*a(i) - cp(i) = c(i)/m - dp(i) = (d(i)-dp(i-1)*a(i))/m - enddo - ! initialize x - x(n) = dp(n) - ! solve for x from the vectors c-prime and d-prime - do i = n-1, 1, -1 - x(i) = dp(i)-cp(i)*x(i+1) - end do - - end subroutine tridiag2 -! ================================================================== - subroutine tridiag3(kte,a,b,c,d,x) - -!ccccccccccccccccccccccccccccccc -! Aim: Inversion and resolution of a tridiagonal matrix -! A X = D -! Input: -! a(*) lower diagonal (Ai,i-1) -! b(*) principal diagonal (Ai,i) -! c(*) upper diagonal (Ai,i+1) -! d -! Output -! x results -!ccccccccccccccccccccccccccccccc - - implicit none - integer,intent(in) :: kte - integer, parameter :: kts=1 - real, dimension(kte) :: a,b,c,d - real ,dimension(kte),intent(out) :: x - integer :: in - -! integer kms,kme,kts,kte,in -! real a(kms:kme,3),c(kms:kme),x(kms:kme) - - do in=kte-1,kts,-1 - d(in)=d(in)-c(in)*d(in+1)/b(in+1) - b(in)=b(in)-c(in)*a(in+1)/b(in+1) - enddo - - do in=kts+1,kte - d(in)=d(in)-a(in)*d(in-1)/b(in-1) - enddo - - do in=kts,kte - x(in)=d(in)/b(in) - enddo - - return - end subroutine tridiag3 -! ================================================================== - SUBROUTINE mynn_bl_driver( & - &initflag,restart,grav_settling, & - &delt,dz,dx,znt, & - &u,v,w,th,qv,qc,qi,qnc,qni, & - &qnwfa,qnifa, & - &p,exner,rho,T3D, & - &xland,ts,qsfc,qcg,ps, & - &ust,ch,hfx,qfx,rmol,wspd, & - &uoce,voce, & !ocean current - &vdfg, & !Katata-added for fog dep - &Qke,tke_pbl, & - &qke_adv,bl_mynn_tkeadvect, & !ACF for QKE advection -#if (WRF_CHEM == 1) - chem3d, vd3d, nchem, & ! WA 7/29/15 For WRF-Chem - kdvel, ndvel, num_vert_mix, & -#endif - &Tsq,Qsq,Cov, & - &RUBLTEN,RVBLTEN,RTHBLTEN, & - &RQVBLTEN,RQCBLTEN,RQIBLTEN, & - &RQNCBLTEN,RQNIBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN, & - &exch_h,exch_m, & - &Pblh,kpbl, & - &el_pbl, & - &dqke,qWT,qSHEAR,qBUOY,qDISS, & !JOE-TKE BUDGET - &wstar,delta, & !JOE-added for grims - &bl_mynn_tkebudget, & - &bl_mynn_cloudpdf,Sh3D, & - &bl_mynn_mixlength, & - &icloud_bl,qc_bl,cldfra_bl, & - &levflag,bl_mynn_edmf, & - &bl_mynn_edmf_mom,bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &bl_mynn_cloudmix,bl_mynn_mixqt, & - &edmf_a,edmf_w,edmf_qt, & - &edmf_thl,edmf_ent,edmf_qc, & - &nupdraft,maxMF,ktop_shallow, & - &spp_pbl,pattern_spp_pbl, & - &RTHRATEN, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) - -!------------------------------------------------------------------- - - INTEGER, INTENT(in) :: initflag - LOGICAL, INTENT(IN) :: restart - !INPUT NAMELIST OPTIONS: - INTEGER, INTENT(in) :: levflag - INTEGER, INTENT(in) :: grav_settling - INTEGER, INTENT(in) :: bl_mynn_tkebudget - INTEGER, INTENT(in) :: bl_mynn_cloudpdf - INTEGER, INTENT(in) :: bl_mynn_mixlength - INTEGER, INTENT(in) :: bl_mynn_edmf - LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect - INTEGER, INTENT(in) :: bl_mynn_edmf_mom - INTEGER, INTENT(in) :: bl_mynn_edmf_tke - INTEGER, INTENT(in) :: bl_mynn_mixscalars - INTEGER, INTENT(in) :: bl_mynn_cloudmix - INTEGER, INTENT(in) :: bl_mynn_mixqt - INTEGER, INTENT(in) :: icloud_bl - - LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA - - INTEGER,INTENT(IN) :: & - & IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - -! initflag > 0 for TRUE -! else for FALSE -! levflag : <>3; Level 2.5 -! = 3; Level 3 -! grav_settling = 1 when gravitational settling accounted for -! grav_settling = 0 when gravitational settling NOT accounted for - - REAL, INTENT(in) :: delt -!WRF -! REAL, INTENT(in) :: dx -!END WRF -!FV3 - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: dx -!END FV3 - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: dz,& - &u,v,w,th,qv,p,exner,rho,T3D - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(in)::& - &qc,qi,qni,qnc,qnwfa,qnifa - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: xland,ust,& - &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd,uoce,voce, vdfg,znt - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & - &Qke,Tsq,Qsq,Cov, & - &tke_pbl, & !JOE-added for coupling (TKE_PBL = QKE/2) - &qke_adv !ACF for QKE advection - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& - &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: & - &RTHRATEN - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & - &exch_h,exch_m - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc - - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(inout) :: & - &Pblh,wstar,delta !JOE-added for GRIMS - - REAL, DIMENSION(IMS:IME,JMS:JME) :: & - &Psig_bl,Psig_shcu - - INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: & - &KPBL,nupdraft,ktop_shallow - - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: & - &maxmf - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & - &el_pbl - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & - &qWT,qSHEAR,qBUOY,qDISS,dqke - ! 3D budget arrays are not allocated when bl_mynn_tkebudget == 0. - ! 1D (local) budget arrays are used for passing between subroutines. - REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: Sh3D - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & - &qc_bl,cldfra_bl - REAL, DIMENSION(KTS:KTE) :: qc_bl1D,cldfra_bl1D,& - qc_bl1D_old,cldfra_bl1D_old - -! WA 7/29/15 Mix chemical arrays -#if (WRF_CHEM == 1) - INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, nchem ), INTENT(INOUT), OPTIONAL :: chem3d - REAL, DIMENSION( ims:ime, kdvel, jms:jme, ndvel ), INTENT(IN), OPTIONAL :: vd3d - REAL, DIMENSION( kts:kte, nchem ) :: chem1 - REAL, DIMENSION( kts:kte+1, nchem ) :: s_awchem1 - REAL, DIMENSION( ndvel ) :: vd1 - INTEGER ic -#endif - -!local vars - INTEGER :: ITF,JTF,KTF, IMD,JMD - INTEGER :: i,j,k - REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,sqv,sqc,sqi,sqw,& - &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - &Vt, Vq, sgm - - REAL, DIMENSION(KTS:KTE) :: thetav,sh,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& - & qke1,tsq1,qsq1,cov1,qv1,qi1,qc1,du1,dv1,dth1,dqv1,dqc1,dqi1, & - & k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1,dqnwfa1,dqnifa1 - -!JOE: mass-flux variables - REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,& - edmf_ent1,edmf_qc1 - REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1,& - s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1,& - s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1 - - REAL, DIMENSION(KTS:KTE+1) :: zw - REAL :: cpm,sqcg,flt,flq,flqv,flqc,pmz,phh,exnerg,zet,& - &afk,abk,ts_decay,th_sfc,ztop_shallow - -!JOE-add GRIMS parameters & variables - real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 - real,parameter :: h1 = 0.33333335, h2 = 0.6666667 - REAL :: govrth, sflux, bfx0, wstar3, wm2, wm3, delb -!JOE-end GRIMS -!JOE-top-down diffusion - REAL, DIMENSION(ITS:ITE,JTS:JTE) :: maxKHtopdown - REAL,DIMENSION(KTS:KTE) :: KHtopdown,zfac,wscalek2,& - zfacent,TKEprodTD - REAL :: bfxpbl,dthvx,tmp1,temps,templ,zl1,wstar3_2 - real :: ent_eff,radsum,radflux,we,rcldb,rvls,& - minrad,zminrad - real, parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 - integer :: kk,kminrad - logical :: cloudflg -!JOE-end top down - -! INTEGER, SAVE :: levflag - -! Stochastic fields - INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN),OPTIONAL ::pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - - - IF ( debug_code ) THEN - print*,'in MYNN driver; at beginning' - ENDIF - -!*** Begin debugging - IMD=(IMS+IME)/2 - JMD=(JMS+JME)/2 -!*** End debugging - -!WRF -! JTF=MIN0(JTE,JDE-1) -! ITF=MIN0(ITE,IDE-1) -! KTF=MIN0(KTE,KDE-1) -!FV3 - JTF=JTE - ITF=ITE - KTF=KTE - -!WRF -! levflag=mynn_level - - IF (bl_mynn_edmf > 0) THEN - ! setup random seed - !call init_random_seed - - edmf_a(its:ite,kts:kte,jts:jte)=0. - edmf_w(its:ite,kts:kte,jts:jte)=0. - edmf_qt(its:ite,kts:kte,jts:jte)=0. - edmf_thl(its:ite,kts:kte,jts:jte)=0. - edmf_ent(its:ite,kts:kte,jts:jte)=0. - edmf_qc(its:ite,kts:kte,jts:jte)=0. - ktop_shallow(its:ite,jts:jte)=0 !int - nupdraft(its:ite,jts:jte)=0 !int - maxmf(its:ite,jts:jte)=0. - ENDIF - maxKHtopdown(its:ite,jts:jte)=0. - - ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS - IF (initflag > 0) THEN - - if (.not.restart) THEN - Sh3D(its:ite,kts:kte,jts:jte)=0. - el_pbl(its:ite,kts:kte,jts:jte)=0. - tsq(its:ite,kts:kte,jts:jte)=0. - qsq(its:ite,kts:kte,jts:jte)=0. - cov(its:ite,kts:kte,jts:jte)=0. - cldfra_bl(its:ite,kts:kte,jts:jte)=0. - qc_bl(its:ite,kts:kte,jts:jte)=0. - qke(its:ite,kts:kte,jts:jte)=0. - end if - dqc1(kts:kte)=0.0 - dqi1(kts:kte)=0.0 - dqni1(kts:kte)=0.0 - dqnc1(kts:kte)=0.0 - dqnwfa1(kts:kte)=0.0 - dqnifa1(kts:kte)=0.0 - qc_bl1D(kts:kte)=0.0 - cldfra_bl1D(kts:kte)=0.0 - qc_bl1D_old(kts:kte)=0.0 - cldfra_bl1D_old(kts:kte)=0.0 - edmf_a1(kts:kte)=0.0 - edmf_w1(kts:kte)=0.0 - edmf_qc1(kts:kte)=0.0 - sgm(kts:kte)=0.0 - vt(kts:kte)=0.0 - vq(kts:kte)=0.0 - - DO j=JTS,JTF - DO k=KTS,KTE - DO i=ITS,ITF - exch_m(i,k,j)=0. - exch_h(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - IF ( bl_mynn_tkebudget == 1) THEN - DO j=JTS,JTF - DO k=KTS,KTE - DO i=ITS,ITF - qWT(i,k,j)=0. - qSHEAR(i,k,j)=0. - qBUOY(i,k,j)=0. - qDISS(i,k,j)=0. - dqke(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - DO j=JTS,JTF - DO i=ITS,ITF - DO k=KTS,KTE !KTF - dz1(k)=dz(i,k,j) - u1(k) = u(i,k,j) - v1(k) = v(i,k,j) - w1(k) = w(i,k,j) - th1(k)=th(i,k,j) - tk1(k)=T3D(i,k,j) - rho1(k)=rho(i,k,j) - sqc(k)=qc(i,k,j)/(1.+qv(i,k,j)) - sqv(k)=qv(i,k,j)/(1.+qv(i,k,j)) - thetav(k)=th(i,k,j)*(1.+0.61*sqv(k)) - IF (PRESENT(qi) .AND. FLAG_QI ) THEN - sqi(k)=qi(i,k,j)/(1.+qv(i,k,j)) - sqw(k)=sqv(k)+sqc(k)+sqi(k) - thl(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc(k) & - & - xlscp/exner(i,k,j)*sqi(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - ELSE - sqi(k)=0.0 - sqw(k)=sqv(k)+sqc(k) - thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) - ENDIF - - IF (k==kts) THEN - zw(k)=0. - ELSE - zw(k)=zw(k-1)+dz(i,k-1,j) - ENDIF - thvl(k)=thl(k)*(1.+0.61*sqv(k)) - if (restart) then - qke1(k) = qke(i,k,j) - else - qke1(k)=0.1-MIN(zw(k)*0.001, 0.0) !for initial PBLH calc only - end if - el(k)=el_pbl(i,k,j) - sh(k)=Sh3D(i,k,j) - tsq1(k)=tsq(i,k,j) - qsq1(k)=qsq(i,k,j) - cov1(k)=cov(i,k,j) - if (spp_pbl==1) then - rstoch_col(k)=pattern_spp_pbl(i,k,j) - else - rstoch_col(k)=0.0 - endif - - ENDDO - - zw(kte+1)=zw(kte)+dz(i,kte,j) - -! CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& - CALL GET_PBLH(KTS,KTE,PBLH(i,j),thvl,& - & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) - - IF (scaleaware > 0.) THEN - CALL SCALE_AWARE(dx(i,j),PBLH(i,j),Psig_bl(i,j),Psig_shcu(i,j)) - ELSE - Psig_bl(i,j)=1.0 - Psig_shcu(i,j)=1.0 - ENDIF - - ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS - CALL mym_initialize ( & - &kts,kte, & - &dz1, zw, u1, v1, thl, sqv, & - &PBLH(i,j), th1, sh, & - &ust(i,j), rmol(i,j), & - &el, Qke1, Tsq1, Qsq1, Cov1, & - &Psig_bl(i,j), cldfra_bl1D, & - &bl_mynn_mixlength, & - &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf,& - &spp_pbl,rstoch_col ) - - IF (.not.restart) THEN - !UPDATE 3D VARIABLES - DO k=KTS,KTE !KTF - el_pbl(i,k,j)=el(k) - sh3d(i,k,j)=sh(k) - qke(i,k,j)=qke1(k) - tsq(i,k,j)=tsq1(k) - qsq(i,k,j)=qsq1(k) - cov(i,k,j)=cov1(k) - !ACF,JOE- initialize qke_adv array if using advection - IF (bl_mynn_tkeadvect) THEN - qke_adv(i,k,j)=qke1(k) - ENDIF - ENDDO - ENDIF - -!*** Begin debugging -! k=kdebug -! IF(I==IMD .AND. J==JMD)THEN -! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k) -! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k,j) -! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) -! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",Tsq(i,k,j) -! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) -! ENDIF -!*** End debugging - - ENDDO - ENDDO - - ENDIF ! end initflag - - !ACF- copy qke_adv array into qke if using advection - IF (bl_mynn_tkeadvect) THEN - qke=qke_adv - ENDIF - - DO j=JTS,JTF - DO i=ITS,ITF - DO k=KTS,KTE !KTF - !JOE-TKE BUDGET - IF ( bl_mynn_tkebudget == 1) THEN - dqke(i,k,j)=qke(i,k,j) - END IF - dz1(k)= dz(i,k,j) - u1(k) = u(i,k,j) - v1(k) = v(i,k,j) - w1(k) = w(i,k,j) - th1(k)= th(i,k,j) - tk1(k)=T3D(i,k,j) - rho1(k)=rho(i,k,j) - qv1(k)= qv(i,k,j) - qc1(k)= qc(i,k,j) - sqv(k)= qv(i,k,j)/(1.+qv(i,k,j)) - sqc(k)= qc(i,k,j)/(1.+qv(i,k,j)) - IF(icloud_bl > 0)cldfra_bl1D_old(k)=cldfra_bl(i,k,j) - IF(icloud_bl > 0)qc_bl1D_old(k)=qc_bl(i,k,j) - dqc1(k)=0.0 - dqi1(k)=0.0 - dqni1(k)=0.0 - dqnc1(k)=0.0 - dqnwfa1(k)=0.0 - dqnifa1(k)=0.0 - IF(PRESENT(qi) .AND. FLAG_QI)THEN - qi1(k)= qi(i,k,j) - sqi(k)= qi(i,k,j)/(1.+qv(i,k,j)) - sqw(k)= sqv(k)+sqc(k)+sqi(k) - thl(k)= th(i,k,j) - xlvcp/exner(i,k,j)*sqc(k) & - & - xlscp/exner(i,k,j)*sqi(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - ELSE - qi1(k)=0.0 - sqi(k)=0.0 - sqw(k)= sqv(k)+sqc(k) - thl(k)= th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) - ENDIF - - IF (PRESENT(qni) .AND. FLAG_QNI ) THEN - qni1(k)=qni(i,k,j) - ELSE - qni1(k)=0.0 - ENDIF - IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN - qnc1(k)=qnc(i,k,j) - ELSE - qnc1(k)=0.0 - ENDIF - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA ) THEN - qnwfa1(k)=qnwfa(i,k,j) - ELSE - qnwfa1(k)=0.0 - ENDIF - IF (PRESENT(qnifa) .AND. FLAG_QNIFA ) THEN - qnifa1(k)=qnifa(i,k,j) - ELSE - qnifa1(k)=0.0 - ENDIF - thetav(k)=th(i,k,j)*(1.+0.608*sqv(k)) - thvl(k)=thl(k)*(1.+0.61*sqv(k)) - p1(k) = p(i,k,j) - ex1(k)= exner(i,k,j) - el(k) = el_pbl(i,k,j) - qke1(k)=qke(i,k,j) - sh(k) = sh3d(i,k,j) - tsq1(k)=tsq(i,k,j) - qsq1(k)=qsq(i,k,j) - cov1(k)=cov(i,k,j) - if (spp_pbl==1) then - rstoch_col(k)=pattern_spp_pbl(i,k,j) - else - rstoch_col(k)=0.0 - endif - - - !edmf - edmf_a1(k)=0.0 - edmf_w1(k)=0.0 - edmf_qc1(k)=0.0 - s_aw1(k)=0. - s_awthl1(k)=0. - s_awqt1(k)=0. - s_awqv1(k)=0. - s_awqc1(k)=0. - s_awu1(k)=0. - s_awv1(k)=0. - s_awqke1(k)=0. - s_awqnc1(k)=0. - s_awqni1(k)=0. - s_awqnwfa1(k)=0. - s_awqnifa1(k)=0. - -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - IF (PRESENT(chem3d) .AND. PRESENT(vd3d)) THEN - ! WA 7/29/15 Set up chemical arrays - DO ic = 1,nchem - chem1(k,ic) = chem3d(i,k,j,ic) - s_awchem1(k,ic)=0. - ENDDO - DO ic = 1,ndvel - IF (k == KTS) THEN - vd1(ic) = vd3d(i,1,j,ic) - ENDIF - ENDDO - ELSE - DO ic = 1,nchem - chem1(k,ic) = 0. - s_awchem1(k,ic)=0. - ENDDO - DO ic = 1,ndvel - IF (k == KTS) THEN - vd1(ic) = 0. - ENDIF - ENDDO - ENDIF - ENDIF -#endif - - IF (k==kts) THEN - zw(k)=0. - ELSE - zw(k)=zw(k-1)+dz(i,k-1,j) - ENDIF - ENDDO ! end k - - zw(kte+1)=zw(kte)+dz(i,kte,j) - !EDMF - s_aw1(kte+1)=0. - s_awthl1(kte+1)=0. - s_awqt1(kte+1)=0. - s_awqv1(kte+1)=0. - s_awqc1(kte+1)=0. - s_awu1(kte+1)=0. - s_awv1(kte+1)=0. - s_awqke1(kte+1)=0. - s_awqnc1(kte+1)=0. - s_awqni1(kte+1)=0. - s_awqnwfa1(kte+1)=0. - s_awqnifa1(kte+1)=0. -#if (WRF_CHEM == 1) - DO ic = 1,nchem - s_awchem1(kte+1,ic)=0. - ENDDO -#endif - -! CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& - CALL GET_PBLH(KTS,KTE,PBLH(i,j),thvl,& - & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) - - IF (scaleaware > 0.) THEN - CALL SCALE_AWARE(dx(i,j),PBLH(i,j),Psig_bl(i,j),Psig_shcu(i,j)) - ELSE - Psig_bl(i,j)=1.0 - Psig_shcu(i,j)=1.0 - ENDIF - - sqcg= 0.0 !JOE, it was: qcg(i,j)/(1.+qcg(i,j)) - cpm=cp*(1.+0.84*qv(i,kts,j)) - exnerg=(ps(i,j)/p1000mb)**rcp - - !----------------------------------------------------- - !ORIGINAL CODE - !flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & - ! +xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j) -sqcg/exnerg) - !flq = qfx(i,j)/ rho(i,kts,j) & - ! -ch(i,j)*(sqc(kts) -sqcg ) - !----------------------------------------------------- - ! Katata-added - The deposition velocity of cloud (fog) - ! water is used instead of CH. - flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & - & +xlvcp*vdfg(i,j)*(sqc(kts)/exner(i,kts,j)- sqcg/exnerg) - flq = qfx(i,j)/ rho(i,kts,j) & - & -vdfg(i,j)*(sqc(kts) - sqcg ) -!JOE-test- should this be after the call to mym_condensation?-using old vt & vq -!same as original form -! flt = flt + xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j) -sqcg/exnerg) - flqv = qfx(i,j)/rho(i,kts,j) - flqc = -vdfg(i,j)*(sqc(kts) - sqcg ) - th_sfc = ts(i,j)/ex1(kts) - - zet = 0.5*dz(i,kts,j)*rmol(i,j) - if ( zet >= 0.0 ) then - pmz = 1.0 + (cphm_st-1.0) * zet - phh = 1.0 + cphh_st * zet - else - pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet - phh = 1.0/SQRT(1.0-cphh_unst*zet) - end if - - !-- Estimate wstar & delta for GRIMS shallow-cu------- - govrth = g/th1(kts) - sflux = hfx(i,j)/rho(i,kts,j)/cpm + & - qfx(i,j)/rho(i,kts,j)*ep_1*th1(kts) - bfx0 = max(sflux,0.) - wstar3 = (govrth*bfx0*pblh(i,j)) - wstar(i,j) = wstar3**h1 - wm3 = wstar3 + 5.*ust(i,j)**3. - wm2 = wm3**h2 - delb = govrth*d3*pblh(i,j) - delta(i,j) = min(d1*pblh(i,j) + d2*wm2/delb, 100.) - !-- End GRIMS----------------------------------------- - - CALL mym_condensation ( kts,kte, & - &dx(i,j),dz1,thl,sqw,p1,ex1, & - &tsq1, qsq1, cov1, & - &Sh,el,bl_mynn_cloudpdf, & - &qc_bl1D,cldfra_bl1D, & - &PBLH(i,j),HFX(i,j), & - &Vt, Vq, th1, sgm, rmol(i,j), & - &spp_pbl, rstoch_col ) - - !ADD TKE source driven by cloud top cooling - IF (bl_mynn_topdown.eq.1)then - cloudflg=.false. - minrad=100. - kminrad=kpbl(i,j) - zminrad=PBLH(i,j) - KHtopdown(kts:kte)=0.0 - TKEprodTD(kts:kte)=0.0 - maxKHtopdown(i,j)=0.0 - !CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS - DO kk = MAX(1,kpbl(i,j)-2),kpbl(i,j)+3 - if(sqc(kk).gt. 1.e-6 .OR. sqi(kk).gt. 1.e-6 .OR. & - cldfra_bl1D(kk).gt.0.5) then - cloudflg=.true. - endif - if(rthraten(i,kk,j) < minrad)then - minrad=rthraten(i,kk,j) - kminrad=kk - zminrad=zw(kk) + 0.5*dz1(kk) - endif - ENDDO - IF (MAX(kminrad,kpbl(i,j)) < 2)cloudflg = .false. - IF (cloudflg) THEN - zl1 = dz1(kts) - k = MAX(kpbl(i,j)-1, kminrad-1) - !Best estimate of height of TKE source (top of downdrafts): - !zminrad = 0.5*pblh(i,j) + 0.5*zminrad - - templ=thl(k)*ex1(k) - !rvls is ws at full level - rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1)) - temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(rd*templ**2)) - rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1)) - rcldb=max(sqw(k)-rvls,0.) - - !entrainment efficiency - dthvx = (thl(k+2) + th1(k+2)*ep_1*sqw(k+2)) & - - (thl(k) + th1(k) *ep_1*sqw(k)) - dthvx = max(dthvx,0.1) - tmp1 = xlvcp * rcldb/(ex1(k)*dthvx) - !Originally from Nichols and Turton (1986), where a2 = 60, but lowered - !here to 8, as in Grenier and Bretherton (2001). - ent_eff = 0.2 + 0.2*8.*tmp1 - - radsum=0. - DO kk = MAX(1,kpbl(i,j)-3),kpbl(i,j)+3 - radflux=rthraten(i,kk,j)*ex1(kk) !converts theta/s to temp/s - radflux=radflux*cp/g*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2 - if (radflux < 0.0 ) radsum=abs(radflux)+radsum - ENDDO - radsum=MIN(radsum,60.0) - - !entrainment from PBL top thermals - bfx0 = max(radsum/rho1(k)/cp - max(sflux,0.0),0.) - !bfx0 = max(radsum/rho1(k)/cp,0.) - wm3 = g/thetav(k)*bfx0*MIN(pblh(i,j),1500.) ! this is wstar3(i) - wm2 = wm2 + wm3**h2 - bfxpbl = - ent_eff * bfx0 - dthvx = max(thetav(k+1)-thetav(k),0.1) - we = max(bfxpbl/dthvx,-sqrt(wm3**h2)) - - DO kk = kts,kpbl(i,j)+3 - !Analytic vertical profile - zfac(kk) = min(max((1.-(zw(kk+1)-zl1)/(zminrad-zl1)),zfmin),1.) - zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3 - - !Calculate an eddy diffusivity profile (not used at the moment) - wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**h1 - !Modify shape of KH to be similar to Lock et al (2000): use pfac = 3.0 - KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac - KHtopdown(kk) = MAX(KHtopdown(kk),0.0) - !Do not include xkzm at kpbl-1 since it changes entrainment - !if (kk.eq.kpbl(i,j)-1 .and. cloudflg .and. we.lt.0.0) then - ! KHtopdown(kk) = 0.0 - !endif - - !Calculate TKE production = 2(g/TH)(w'TH'), where w'TH' = A(TH/g)wstar^3/PBLH, - !A = ent_eff, and wstar is associated with the radiative cooling at top of PBL. - !An analytic profile controls the magnitude of this TKE prod in the vertical. - TKEprodTD(kk)=2.*ent_eff*wm3/MAX(pblh(i,j),100.)*zfacent(kk) - TKEprodTD(kk)= MAX(TKEprodTD(kk),0.0) - ENDDO - ENDIF !end cloud check - maxKHtopdown(i,j)=MAXVAL(KHtopdown(:)) - ELSE - maxKHtopdown(i,j)=0.0 - KHtopdown(kts:kte) = 0.0 - TKEprodTD(kts:kte)=0.0 - ENDIF !end top-down check - - IF (bl_mynn_edmf == 1) THEN - !PRINT*,"Calling DMP Mass-Flux: i= ",i," j=",j - CALL DMP_mf( & - &kts,kte,delt,zw,dz1,p1, & - &bl_mynn_edmf_mom, & - &bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &u1,v1,w1,th1,thl,thetav,tk1, & - &sqw,sqv,sqc,qke1, & - &qnc1,qni1,qnwfa1,qnifa1, & - &ex1,Vt,Vq,sgm, & - &ust(i,j),flt,flq,flqv,flqc, & - &PBLH(i,j),KPBL(i,j),DX(i,j), & - &xland(i,j),th_sfc, & - ! now outputs - tendencies - ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & - ! outputs - updraft properties - & edmf_a1,edmf_w1,edmf_qt1, & - & edmf_thl1,edmf_ent1,edmf_qc1, & - ! for the solver - & s_aw1,s_awthl1,s_awqt1, & - & s_awqv1,s_awqc1, & - & s_awu1,s_awv1,s_awqke1, & - & s_awqnc1,s_awqni1, & - & s_awqnwfa1,s_awqnifa1, & -#if (WRF_CHEM == 1) - & nchem,chem1,s_awchem1, & -#endif - & qc_bl1D,cldfra_bl1D, & - & FLAG_QC,FLAG_QI, & - & FLAG_QNC,FLAG_QNI, & - & FLAG_QNWFA,FLAG_QNIFA, & - & Psig_shcu(i,j), & - & nupdraft(i,j),ktop_shallow(i,j), & - & maxmf(i,j),ztop_shallow, & - & spp_pbl,rstoch_col & - ) - - ENDIF - - CALL mym_turbulence ( & - &kts,kte,levflag, & - &dz1, zw, u1, v1, thl, sqc, sqw, & - &qke1, tsq1, qsq1, cov1, & - &vt, vq, & - &rmol(i,j), flt, flq, & - &PBLH(i,j),th1, & - &Sh,el, & - &Dfm,Dfh,Dfq, & - &Tcd,Qcd,Pdk, & - &Pdt,Pdq,Pdc, & - &qWT1,qSHEAR1,qBUOY1,qDISS1, & - &bl_mynn_tkebudget, & - &Psig_bl(i,j),Psig_shcu(i,j), & - &cldfra_bl1D,bl_mynn_mixlength, & - &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & - &TKEprodTD, & - &spp_pbl,rstoch_col) - - CALL mym_predict (kts,kte,levflag, & - &delt, dz1, & - &ust(i,j), flt, flq, pmz, phh, & - &el, dfq, pdk, pdt, pdq, pdc, & - &Qke1, Tsq1, Qsq1, Cov1, & - &s_aw1, s_awqke1, bl_mynn_edmf_tke) - - DO k=kts,kte-1 - ! Set max dissipative heating rate close to 0.1 K per hour (=0.000027...) - diss_heat(k) = MIN(MAX(0.5*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.00002) - ENDDO - diss_heat(kte) = 0. - - CALL mynn_tendencies(kts,kte, & - &levflag,grav_settling, & - &delt, dz1, rho1, & - &u1, v1, th1, tk1, qv1, & - &qc1, qi1, qnc1, qni1, & - &p1, ex1, thl, sqv, sqc, sqi, sqw,& - &qnwfa1, qnifa1, & - &ust(i,j),flt,flq,flqv,flqc, & - &wspd(i,j),qcg(i,j), & - &uoce(i,j),voce(i,j), & - &tsq1, qsq1, cov1, & - &tcd, qcd, & - &dfm, dfh, dfq, & - &Du1, Dv1, Dth1, Dqv1, & - &Dqc1, Dqi1, Dqnc1, Dqni1, & - &Dqnwfa1, Dqnifa1, & - &vdfg(i,j), diss_heat, & - ! mass flux components - &s_aw1,s_awthl1,s_awqt1, & - &s_awqv1,s_awqc1,s_awu1,s_awv1, & - &s_awqnc1,s_awqni1, & - &s_awqnwfa1,s_awqnifa1, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & - &cldfra_bl1d, & - &ztop_shallow,ktop_shallow(i,j), & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) - -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - CALL mynn_mix_chem(kts,kte, & - levflag,grav_settling, & - delt, dz1, & - nchem, kdvel, ndvel, num_vert_mix, & - chem1, vd1, & - qnc1,qni1, & - p1, ex1, thl, sqv, sqc, sqi, sqw,& - ust(i,j),flt,flq,flqv,flqc, & - wspd(i,j),qcg(i,j), & - uoce(i,j),voce(i,j), & - tsq1, qsq1, cov1, & - tcd, qcd, & - &dfm, dfh, dfq, & - ! mass flux components - & s_aw1, & - & s_awchem1, & - &bl_mynn_cloudmix) - ENDIF -#endif - - - CALL retrieve_exchange_coeffs(kts,kte,& - &dfm, dfh, dz1, K_m1, K_h1) - - !UPDATE 3D ARRAYS - DO k=KTS,KTE !KTF - exch_m(i,k,j)=K_m1(k) - exch_h(i,k,j)=K_h1(k) - RUBLTEN(i,k,j)=du1(k) - RVBLTEN(i,k,j)=dv1(k) - RTHBLTEN(i,k,j)=dth1(k) - RQVBLTEN(i,k,j)=dqv1(k) - IF(bl_mynn_cloudmix > 0)THEN - IF (PRESENT(qc) .AND. FLAG_QC) RQCBLTEN(i,k,j)=dqc1(k) - IF (PRESENT(qi) .AND. FLAG_QI) RQIBLTEN(i,k,j)=dqi1(k) - ELSE - IF (PRESENT(qc) .AND. FLAG_QC) RQCBLTEN(i,k,j)=0. - IF (PRESENT(qi) .AND. FLAG_QI) RQIBLTEN(i,k,j)=0. - ENDIF - IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN - IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=dqnc1(k) - IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=dqni1(k) - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k,j)=dqnwfa1(k) - IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k,j)=dqnifa1(k) - ELSE - IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=0. - IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=0. - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k,j)=0. - IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k,j)=0. - ENDIF - - IF(icloud_bl > 0)THEN - !make BL clouds scale aware - may already be done in mym_condensation - qc_bl(i,k,j)=qc_bl1D(k) !*Psig_shcu(i,j) - cldfra_bl(i,k,j)=cldfra_bl1D(k) !*Psig_shcu(i,j) - - !DIAGNOSTIC-DECAY FOR SUBGRID-SCALE CLOUDS - IF (CLDFRA_BL(i,k,j) < cldfra_bl1D_old(k)) THEN - !DECAY TIMESCALE FOR CALM CONDITION IS THE EDDY TURNOVER - !TIMESCALE, BUT FOR - !WINDY CONDITIONS, IT IS THE ADVECTIVE TIMESCALE. USE THE - !MINIMUM OF THE TWO. - ts_decay = MIN( 1800., 3.*dx(i,j)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) - cldfra_bl(i,k,j)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.25*delt/ts_decay)) - IF (cldfra_bl(i,k,j) < 0.005) THEN - CLDFRA_BL(i,k,j)= 0. - QC_BL(i,k,j) = 0. - ENDIF - ENDIF - - !Reapply checks on cldfra_bl and qc_bl to avoid FPEs in radiation driver - ! when these two quantities are multiplied by eachother (they may have changed - ! in the MF scheme: - !IF (icloud_bl > 0) THEN - IF ( zw(k) < 3000.0 ) THEN - IF (QC_BL(i,k,j) < 5E-6 .AND. CLDFRA_BL(i,k,j) > 0.005) QC_BL(i,k,j)= 5E-6 - ELSE - IF (QC_BL(i,k,j) < 1E-8 .AND. CLDFRA_BL(i,k,j) > 0.005) QC_BL(i,k,j)= 1E-8 - ENDIF - ENDIF - - el_pbl(i,k,j)=el(k) - qke(i,k,j)=qke1(k) - tsq(i,k,j)=tsq1(k) - qsq(i,k,j)=qsq1(k) - cov(i,k,j)=cov1(k) - sh3d(i,k,j)=sh(k) - - IF ( bl_mynn_tkebudget == 1) THEN - dqke(i,k,j) = (qke1(k)-dqke(i,k,j))*0.5 !qke->tke - qWT(i,k,j) = qWT1(k)*delt - qSHEAR(i,k,j)= qSHEAR1(k)*delt - qBUOY(i,k,j) = qBUOY1(k)*delt - qDISS(i,k,j) = qDISS1(k)*delt - ENDIF - - !update updraft properties - IF (bl_mynn_edmf > 0) THEN - edmf_a(i,k,j)=edmf_a1(k) - edmf_w(i,k,j)=edmf_w1(k) - edmf_qt(i,k,j)=edmf_qt1(k) - edmf_thl(i,k,j)=edmf_thl1(k) - edmf_ent(i,k,j)=edmf_ent1(k) - edmf_qc(i,k,j)=edmf_qc1(k) - ENDIF - - !*** Begin debug prints - IF ( debug_code ) THEN - IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," sh=",sh(k) - IF ( qke(i,k,j) < -1. .OR. qke(i,k,j)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," qke=",qke(i,k,j) - IF ( el_pbl(i,k,j) < 0. .OR. el_pbl(i,k,j)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," el_pbl=",el_pbl(i,k,j) - IF ( ABS(vt(k)) > 0.8 )print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vt=",vt(k) - IF ( ABS(vq(k)) > 6000.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vq=",vq(k) - IF ( exch_m(i,k,j) < 0. .OR. exch_m(i,k,j)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," exxch_m=",exch_m(i,k,j) - IF ( vdfg(i,j) < 0. .OR. vdfg(i,j)>5. )print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vdfg=",vdfg(i,j) - IF ( ABS(QFX(i,j))>.001)print*,& - "SUSPICIOUS VALUES AT: i,j=",i,j," QFX=",QFX(i,j) - IF ( ABS(HFX(i,j))>1000.)print*,& - "SUSPICIOUS VALUES AT: i,j=",i,j," HFX=",HFX(i,j) - IF (icloud_bl > 0) then - IF( cldfra_bl(i,k,j) < 0.0 .OR. cldfra_bl(i,k,j)> 1.)THEN - PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k,j)," qc_bl=",QC_BL(i,k,j) - ENDIF - ENDIF - ENDIF - !*** End debug prints - ENDDO - - !JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) - ! TKE_PBL is defined on interfaces, while QKE is at middle of layer. - tke_pbl(i,kts,j) = 0.5*MAX(qke(i,kts,j),1.0e-10) - DO k = kts+1,kte - afk = dz1(k)/( dz1(k)+dz1(k-1) ) - abk = 1.0 -afk - tke_pbl(i,k,j) = 0.5*MAX(qke(i,k,j)*abk+qke(i,k-1,j)*afk,1.0e-3) - ENDDO - -!*** Begin debugging -! IF(I==IMD .AND. J==JMD)THEN -! k=kdebug -! PRINT*,"MYNN DRIVER END: k=",1," sh=",sh(k) -! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j) -! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) -! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j) -! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) -! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j) -! ENDIF -!*** End debugging - - ENDDO - ENDDO - -!ACF copy qke into qke_adv if using advection - IF (bl_mynn_tkeadvect) THEN - qke_adv=qke - ENDIF -!ACF-end - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mynn_bl_driver - -! ================================================================== - SUBROUTINE mynn_bl_init_driver( & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - &RQCBLTEN,RQIBLTEN & !,RQNIBLTEN,RQNCBLTEN & - &,QKE,TKE_PBL,EXCH_H & -! &,icloud_bl,qc_bl,cldfra_bl & !JOE-subgrid bl clouds - &,RESTART,ALLOWED_TO_READ,LEVEL & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) - - !--------------------------------------------------------------- - LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART - INTEGER,INTENT(IN) :: LEVEL !,icloud_bl - - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE - - - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - &RQCBLTEN,RQIBLTEN,& !RQNIBLTEN,RQNCBLTEN & - &QKE,TKE_PBL,EXCH_H - -! REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & -! &qc_bl,cldfra_bl - - INTEGER :: I,J,K,ITF,JTF,KTF - - JTF=MIN0(JTE,JDE-1) - KTF=MIN0(KTE,KDE-1) - ITF=MIN0(ITE,IDE-1) - - IF(.NOT.RESTART)THEN - DO J=JTS,JTF - DO K=KTS,KTF - DO I=ITS,ITF - RUBLTEN(i,k,j)=0. - RVBLTEN(i,k,j)=0. - RTHBLTEN(i,k,j)=0. - RQVBLTEN(i,k,j)=0. - if( p_qc >= param_first_scalar ) RQCBLTEN(i,k,j)=0. - if( p_qi >= param_first_scalar ) RQIBLTEN(i,k,j)=0. - !if( p_qnc >= param_first_scalar ) RQNCBLTEN(i,k,j)=0. - !if( p_qni >= param_first_scalar ) RQNIBLTEN(i,k,j)=0. - !QKE(i,k,j)=0. - TKE_PBL(i,k,j)=0. - EXCH_H(i,k,j)=0. -! if(icloud_bl > 0) qc_bl(i,k,j)=0. -! if(icloud_bl > 0) cldfra_bl(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - mynn_level=level - - END SUBROUTINE mynn_bl_init_driver - -! ================================================================== - - SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) - - !--------------------------------------------------------------- - ! NOTES ON THE PBLH FORMULATION - ! - !The 1.5-theta-increase method defines PBL heights as the level at - !which the potential temperature first exceeds the minimum potential - !temperature within the boundary layer by 1.5 K. When applied to - !observed temperatures, this method has been shown to produce PBL- - !height estimates that are unbiased relative to profiler-based - !estimates (Nielsen-Gammon et al. 2008). However, their study did not - !include LLJs. Banta and Pichugina (2008) show that a TKE-based - !threshold is a good estimate of the PBL height in LLJs. Therefore, - !a hybrid definition is implemented that uses both methods, weighting - !the TKE-method more during stable conditions (PBLH < 400 m). - !A variable tke threshold (TKEeps) is used since no hard-wired - !value could be found to work best in all conditions. - !--------------------------------------------------------------- - - INTEGER,INTENT(IN) :: KTS,KTE - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - REAL, INTENT(OUT) :: zi - REAL, INTENT(IN) :: landsea - REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D - REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D - !LOCAL VARS - REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv - REAL :: delt_thv !delta theta-v; dependent on land/sea point - REAL, PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m). - REAL, PARAMETER :: sbl_damp = 400. !transition length for blending (m). - INTEGER :: I,J,K,kthv,ktke,kzi,kzi2 - - !ADD KPBL (kzi) - !KZI2 is the TKE-based part of the hybrid KPBL - kzi = 2 - kzi2= 2 - - !FIND MIN THETAV IN THE LOWEST 200 M AGL - k = kts+1 - kthv = 1 - minthv = 9.E9 - DO WHILE (zw1D(k) .LE. 200.) - !DO k=kts+1,kte-1 - IF (minthv > thetav1D(k)) then - minthv = thetav1D(k) - kthv = k - ENDIF - k = k+1 - !IF (zw1D(k) .GT. sbl_lim) exit - ENDDO - - !FIND THETAV-BASED PBLH (BEST FOR DAYTIME). - zi=0. - k = kthv+1 - IF((landsea-1.5).GE.0)THEN - ! WATER - delt_thv = 0.75 - ELSE - ! LAND - delt_thv = 1.25 - ENDIF - - zi=0. - k = kthv+1 -! DO WHILE (zi .EQ. 0.) - DO k=kts+1,kte-1 - IF (thetav1D(k) .GE. (minthv + delt_thv))THEN - !kzi = MAX(k-1,1) - zi = zw1D(k) - dz1D(k-1)* & - & MIN((thetav1D(k)-(minthv + delt_thv))/ & - & MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) - kzi= MAX(k-1,1) + NINT((zi-zw1D(k-1))/dz1D(k-1)) - ENDIF - !k = k+1 - IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD - IF (zi .NE. 0.0) exit - ENDDO - !print*,"IN GET_PBLH:",thsfc,zi - - !FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE - !THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM). - !THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE - !WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM. - ktke = 1 - maxqke = MAX(Qke1D(kts),0.) - !Use 5% of tke max (Kosovic and Curry, 2000; JAS) - !TKEeps = maxtke/20. = maxqke/40. - TKEeps = maxqke/40. - TKEeps = MAX(TKEeps,0.02) !0.025) - PBLH_TKE=0. - - k = ktke+1 -! DO WHILE (PBLH_TKE .EQ. 0.) - DO k=kts+1,kte-1 - !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE. - qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE - qtkem1=MAX(Qke1D(k-1)/2.,0.) - IF (qtke .LE. TKEeps) THEN - !kzi2 = MAX(k-1,1) - PBLH_TKE = zw1D(k) - dz1D(k-1)* & - & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0) - !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL. - PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1)) - kzi2 = MAX(k-1,1) + NINT((PBLH_TKE-zw1D(k-1))/dz1D(k-1)) - !print *,"PBLH_TKE:",i,j,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) - ENDIF - !k = k+1 - IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD - IF (PBLH_TKE .NE. 0.) exit - ENDDO - - !With TKE advection turned on, the TKE-based PBLH can be very large - !in grid points with convective precipitation (> 8 km!), - !so an artificial limit is imposed to not let PBLH_TKE exceed the - !theta_v-based PBL height +/- 350 m. - !This has no impact on 98-99% of the domain, but is the simplest patch - !that adequately addresses these extremely large PBLHs. - PBLH_TKE = MIN(PBLH_TKE,zi+350.) - PBLH_TKE = MAX(PBLH_TKE,MAX(zi-350.,10.)) - - wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 - IF (maxqke <= 0.05) THEN - !Cold pool situation - default to theta_v-based def - ELSE - !BLEND THE TWO PBLH TYPES HERE: - zi=PBLH_TKE*(1.-wt) + zi*wt - ENDIF - - !ADD KPBL (kzi) for coupling to some Cu schemes - kzi = MAX(INT(kzi2*(1.-wt) + kzi*wt),1) - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE GET_PBLH - -! ================================================================== -! Dynamic Multi-Plume (DMP) Mass-Flux Scheme -! -! Much thanks to Kay Suslj of NASA-JPL for contributing the original version -! of this mass-flux scheme. Considerable changes have been made from it's -! original form. Some additions include: -! 1) scale-aware tapering as dx -> 0 -! 2) transport of TKE (extra namelist option) -! 3) Chaboureau-Bechtold cloud fraction & coupling to radiation (when icloud_bl > 0) -! 4) some extra limits for numerical stability -! This scheme remains under development, so consider it experimental code. -! - SUBROUTINE DMP_mf( & - & kts,kte,dt,zw,dz,p, & - & momentum_opt, & - & tke_opt, & - & scalar_opt, & - & u,v,w,th,thl,thv,tk, & - & qt,qv,qc,qke, & - qnc,qni,qnwfa,qnifa, & - & exner,vt,vq,sgm, & - & ust,flt,flq,flqv,flqc, & - & pblh,kpbl,DX,landsea,ts, & - ! outputs - updraft properties - & edmf_a,edmf_w, & - & edmf_qt,edmf_thl, & - & edmf_ent,edmf_qc, & - ! outputs - variables needed for solver - & s_aw,s_awthl,s_awqt, & - & s_awqv,s_awqc, & - & s_awu,s_awv,s_awqke, & - & s_awqnc,s_awqni, & - & s_awqnwfa,s_awqnifa, & -#if (WRF_CHEM == 1) - & nchem,chem,s_awchem, & -#endif - ! in/outputs - subgrid scale clouds - & qc_bl1d,cldfra_bl1d, & - ! inputs - flags for moist arrays - & F_QC,F_QI, & - F_QNC,F_QNI, & - & F_QNWFA,F_QNIFA, & - & Psig_shcu, & - ! output info - &nup2,ktop,maxmf,ztop, & - ! unputs for stochastic perturbations - &spp_pbl,rstoch_col) - - ! inputs: - INTEGER, INTENT(IN) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - -! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,& - exner,dz,THV,P,qke,qnc,qni,qnwfa,qnifa - REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma - REAL, INTENT(IN) :: DT,UST,FLT,FLQ,FLQV,FLQC,PBLH,& - DX,Psig_shcu,landsea,ts - LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA - - ! outputs - updraft properties - REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & - & edmf_qt,edmf_thl, edmf_ent,edmf_qc - !add one local edmf variable: - REAL,DIMENSION(KTS:KTE) :: edmf_th - ! output - INTEGER, INTENT(OUT) :: nup2,ktop - REAL, INTENT(OUT) :: maxmf,ztop - ! outputs - variables needed for solver - REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*wis_awphi - s_awthl, & !sum ai*wi*phii - s_awqt, & - s_awqv, & - s_awqc, & - s_awqnc, & - s_awqni, & - s_awqnwfa, & - s_awqnifa, & - s_awu, & - s_awv, & - s_awqke, s_aw2 - - REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d - - INTEGER, PARAMETER :: NUP=10, debug_mf=0 - - !------------- local variables ------------------- - ! updraft properties defined on interfaces (k=1 is the top of the - ! first model layer - REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & - UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & - UPQNI,UPQNWFA,UPQNIFA - ! entrainment variables - REAL,DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf - INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi - ! internal variables - INTEGER :: K,I,k50 - REAL :: fltv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & - pwmin,pwmax,wmin,wmax,wlv,wtv,Psig_w,maxw,maxqc,wpbl - REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & - Wn2,Wn,EntEXP,EntW,BCOEFF,THVkm1,THVk,Pk - - ! w parameters - REAL,PARAMETER :: & - &Wa=2./3., & - &Wb=0.002,& - &Wc=1.5 - - ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from - ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. - REAL,PARAMETER :: & - & L0=100.,& - & ENT0=0.1 - - ! Implement ideas from Neggers (2016, JAMES): - REAL, PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts - REAL, PARAMETER :: lmax = 1000.! diameter of largest plume - REAL, PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand - REAL, PARAMETER :: dcut = 1.0 ! max diameter of plume to parameterize relative to dx (km) - REAL :: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). - ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes. - ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. - REAL :: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx - -#if (WRF_CHEM == 1) - INTEGER, INTENT(IN) :: nchem - REAL,DIMENSION(kts:kte, nchem) :: chem - REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem - REAL,DIMENSION(nchem) :: chemn - REAL,DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM - INTEGER :: ic - REAL,DIMENSION(KTS:KTE+1, nchem) :: edmf_chem -#endif - - !JOE: add declaration of ERF - REAL :: ERF - - LOGICAL :: superadiabatic - - ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION - REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,& - Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid - - ! Variables for plume interpolation/saturation check - REAL,DIMENSION(KTS:KTE) :: exneri,dzi - REAL :: THp, QTp, QCp, esat, qsl - - ! WA TEST 11/9/15 for consistent reduction of updraft params - REAL :: csigma,acfac,EntThrottle - - !JOE- plume overshoot - INTEGER :: overshoot - REAL :: bvf, Frz - - !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux). - !This limiter makes adjustments to the entire column. - REAL :: adjustment, flx1 - REAL, PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact - ! over land (decrease maxMF by 10-20%), but no impact over water. -! check the inputs -! print *,'dt',dt -! print *,'dz',dz -! print *,'u',u -! print *,'v',v -! print *,'thl',thl -! print *,'qt',qt -! print *,'ust',ust -! print *,'flt',flt -! print *,'flq',flq -! print *,'pblh',pblh - -! Initialize individual updraft properties - UPW=0. - UPTHL=0. - UPTHV=0. - UPQT=0. - UPA=0. - UPU=0. - UPV=0. - UPQC=0. - UPQV=0. - UPQKE=0. - UPQNC=0. - UPQNI=0. - UPQNWFA=0. - UPQNIFA=0. -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 - ENDIF -#endif - ENT=0.001 -! Initialize mean updraft properties - edmf_a =0. - edmf_w =0. - edmf_qt =0. - edmf_thl=0. - edmf_ent=0. - edmf_qc =0. -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - edmf_chem(kts:kte+1,1:nchem) = 0.0 - ENDIF -#endif -! Initialize the variables needed for implicit solver - s_aw=0. - s_awthl=0. - s_awqt=0. - s_awqv=0. - s_awqc=0. - s_awu=0. - s_awv=0. - s_awqke=0. - s_awqnc=0. - s_awqni=0. - s_awqnwfa=0. - s_awqnifa=0. -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - s_awchem(kts:kte+1,1:nchem) = 0.0 - ENDIF -#endif - - - ! Taper off MF scheme when significant resolved-scale motions - ! are present This function needs to be asymetric... - k = 1 - maxw = 0.0 - cloud_base = 9000.0 -! DO WHILE (ZW(k) < pblh + 500.) - DO k=1,kte-1 - IF(ZW(k) > pblh + 500.) exit - - wpbl = w(k) - IF(w(k) < 0.)wpbl = 2.*w(k) - maxw = MAX(maxw,ABS(wpbl)) - - !Find highest k-level below 50m AGL - IF(ZW(k)<=50.)k50=k - - !Search for cloud base - IF(qc(k)>1E-5 .AND. cloud_base == 9000.0)THEN - cloud_base = 0.5*(ZW(k)+ZW(k+1)) - ENDIF - - !k = k + 1 - ENDDO - !print*," maxw before manipulation=", maxw - maxw = MAX(0.,maxw - 0.5) ! do nothing for small w, but - Psig_w = MAX(0.0, 1.0 - maxw/0.5) ! linearly taper off for w > 0.5 m/s - Psig_w = MIN(Psig_w, Psig_shcu) - !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu - - fltv = flt + svp1*flq - !PRINT*," fltv=",fltv," zi=",pblh - - !Completely shut off MF scheme for strong resolved-scale vertical velocities. - IF(Psig_w == 0.0 .and. fltv > 0.0) fltv = -1.*fltv - -! if surface buoyancy is positive we do integration, otherwise not, and make sure that -! PBLH > twice the height of the surface layer (set at z0 = 50m) -! Also, ensure that it is at least slightly superadiabatic up through 50 m - superadiabatic = .false. - IF((landsea-1.5).GE.0)THEN - hux = -0.002 ! WATER ! dT/dz must be < - 0.2 K per 100 m. - ELSE - hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m. - ENDIF - DO k=1,MAX(1,k50-1) - IF (k == 1) then - IF ((th(k)-ts)/(0.5*dz(k)) < hux) THEN - superadiabatic = .true. - ELSE - superadiabatic = .false. - exit - ENDIF - ELSE - IF ((th(k)-th(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) THEN - superadiabatic = .true. - ELSE - superadiabatic = .false. - exit - ENDIF - ENDIF - ENDDO - - ! Determine the numer of updrafts/plumes in the grid column: - ! Some of these criteria may be a little redundant but useful for bullet-proofing. - ! (1) largest plume = 1.0 * dx. - ! (2) Apply a scale-break, assuming no plumes with diameter larger than PBLH can exist. - ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base. - ! (4) add shear-dependent limit, when plume model breaks down. (taken out) - ! (5) land-only limit to reduce plume sizes in weakly forced conditions - ! Criteria (1) - NUP2 = max(1,min(NUP,INT(dx*dcut/dl))) - ! Criteria (2) and (4) - !wspd_pbl=SQRT(MAX(u(kpbl)**2 + v(kpbl)**2, 0.01)) - maxwidth = 1.1*PBLH !- MIN(15.*MAX(wspd_pbl - 7.5, 0.), 0.3*PBLH) - ! Criteria (3) -! maxwidth = MIN(maxwidth,0.5*cloud_base) - maxwidth = MIN(maxwidth,0.75*cloud_base) - ! Criteria (5) - IF((landsea-1.5).LT.0)THEN - IF (cloud_base .LT. 2000.) THEN - !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.120)/0.03) + .5),1000.), 0.) - width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.090)/0.03) + .5),1000.), 0.) - ELSE - width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.) - !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) - ENDIF - maxwidth = MIN(maxwidth,width_flx) - ENDIF - ! Convert maxwidth to number of plumes - NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2) - - !Initialize values: - ktop = 0 - ztop = 0.0 - maxmf= 0.0 - - IF ( fltv > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then - !PRINT*," Conditions met to run mass-flux scheme",fltv,pblh - - ! Find coef C for number size density N - cn = 0. - d=-1.9 !set d to value suggested by Neggers 2015 (JAMES). - !d=-1.9 + .2*tanh((fltv - 0.05)/0.15) - do I=1,NUP !NUP2 - IF(I > NUP2) exit - l = dl*I ! diameter of plume - cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume - enddo - C = Atot/cn !Normalize C according to the defined total fraction (Atot) - - ! Find the portion of the total fraction (Atot) of each plume size: - An2 = 0. - do I=1,NUP !NUP2 - IF(I > NUP2) exit - l = dl*I ! diameter of plume - N = C*l**d ! number density of plume n - UPA(1,I) = N*l*l/(dx*dx) * dl ! fractional area of plume n - ! Make updraft area (UPA) a function of the buoyancy flux -! acfac = .5*tanh((fltv - 0.05)/0.2) + .5 -! acfac = .5*tanh((fltv - 0.07)/0.09) + .5 -! acfac = .5*tanh((fltv - 0.03)/0.09) + .5 - acfac = .5*tanh((fltv - 0.02)/0.09) + .5 -! acfac = .5*tanh((fltv - 0.015)/0.05) + .5 - UPA(1,I)=UPA(1,I)*acfac - An2 = An2 + UPA(1,I) ! total fractional area of all plumes - !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 - end do - - ! set initial conditions for updrafts - z0=50. - pwmin=0.1 ! was 0.5 - pwmax=0.4 ! was 3.0 - - wstar=max(1.E-2,(g/thv(1)*fltv*pblh)**(1./3.)) - qstar=max(flq,1.0E-5)/wstar - thstar=flt/wstar - - IF((landsea-1.5).GE.0)THEN - csigma = 1.34 ! WATER - ELSE - csigma = 1.34 ! LAND - ENDIF - sigmaW =1.34*wstar*(z0/pblh)**(1./3.)*(1 - 0.8*z0/pblh) - sigmaQT=csigma*qstar*(z0/pblh)**(-1./3.) - sigmaTH=csigma*thstar*(z0/pblh)**(-1./3.) - - wmin=MIN(sigmaW*pwmin,0.1) - wmax=MIN(sigmaW*pwmax,0.5) - - !recompute acfac for plume excess - acfac = .5*tanh((fltv - 0.08)/0.07) + .5 - - !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 - DO I=1,NUP !NUP2 - IF(I > NUP2) exit - wlv=wmin+(wmax-wmin)/NUP2*(i-1) - wtv=wmin+(wmax-wmin)/NUP2*i - - !SURFACE UPDRAFT VERTICAL VELOCITY - !UPW(1,I)=0.5*(wlv+wtv) - UPW(1,I)=wmin + REAL(i)/REAL(NUP)*(wmax-wmin) - !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt - - !SURFACE UPDRAFT AREA - !UPA(1,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.5*ERF(wlv/(sqrt(2.)*sigmaW)) - !UPA(1,I)=0.25*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.25*ERF(wlv/(sqrt(2.)*sigmaW)) !12.0 - - UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQC(1,I)=0 - !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& - & +0.58*UPW(1,I)*sigmaQT/sigmaW - UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & +0.58*UPW(1,I)*sigmaTH/sigmaW -!was UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) !assume no saturated parcel at surface - UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & +0.58*UPW(1,I)*sigmaTH/sigmaW - UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - UPCHEM(1,I,ic)= (CHEM(KTS,ic)*DZ(KTS+1)+CHEM(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - enddo - ENDIF -#endif - - ENDDO - - EntThrottle = 0.001 !MAX(0.02/MAX((flt*1.25*1004.)-25.,5.),0.0002) - !QCn = 0. - ! do integration updraft - DO I=1,NUP !NUP2 - IF(I > NUP2) exit - QCn = 0. - overshoot = 0 - l = dl*I ! diameter of plume - DO k=KTS+1,KTE-1 - !w-dependency for entrainment a la Tian and Kuang (2016) - !ENT(k,i) = 0.5/(MIN(MAX(UPW(K-1,I),0.75),1.5)*l) - ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.5)*l) - !Entrainment from Negggers (2015, JAMES) - !ENT(k,i) = 0.02*l**-0.35 - 0.0009 - !JOE - implement minimum background entrainment - ENT(k,i) = max(ENT(k,i),0.0003) - !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang - !JOE - increase entrainment for plumes extending very high. - IF(ZW(k) >= MIN(pblh+1500., 3500.))THEN - ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,3500.))*5.0E-6 - ENDIF - IF(UPW(K-1,I) > 2.0) ENT(k,i) = ENT(k,i) + EntThrottle*(UPW(K-1,I) - 2.0) - - !SPP - ENT(k,i) = ENT(k,i) * (1.0 - rstoch_col(k)) - - ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) - - ! Linear entrainment: - EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) - QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp - THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp - Un =UPU(k-1,I) *(1.-EntExp) + U(k)*EntExp - Vn =UPV(k-1,I) *(1.-EntExp) + V(k)*EntExp - QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp - QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp - QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp - QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp - QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp - - ! Exponential Entrainment: - !EntExp= exp(-ENT(K,I)*(ZW(k)-ZW(k-1))) - !QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp - !THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp - !Un =U(K) *(1-EntExp)+UPU(K-1,I)*EntExp - !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp - !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp - -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - ! Exponential Entrainment: - !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp - ! Linear entrainment: - chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem(k,ic)*EntExp - enddo - ENDIF -#endif - - ! Define pressure at model interface - Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - ! Compute plume properties thvn and qcn - call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn) - - ! Define environment THV at the model interface levels - THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) - -! B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0) - B=g*(THVn/THVk - 1.0) - IF(B>0.)THEN - BCOEFF = 0.15 !w typically stays < 2.5, so doesnt hit the limits nearly as much - ELSE - BCOEFF = 0.2 !0.33 - ENDIF - - ! Original StEM with exponential entrainment - !EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1))) - !Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I)) - ! Original StEM with linear entrainment - !Wn2=UPW(K-1,I)**2*(1.-EntExp) + EntExp*0.5*Wa*B/(Wb+Wc*ENT(K,I)) - !Wn2=MAX(Wn2,0.0) - !WA: TEMF form -! IF (B>0.0 .AND. UPW(K-1,I) < 0.2 ) THEN - IF (UPW(K-1,I) < 0.2 ) THEN - Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / MAX(UPW(K-1,I),0.2)) * MIN(ZW(k)-ZW(k-1), 250.) - ELSE - Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / UPW(K-1,I)) * MIN(ZW(k)-ZW(k-1), 250.) - ENDIF - !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. - !Add max increase of 2.0 m/s for coarse vertical resolution. - IF(Wn > UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN - Wn = UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) - ENDIF - !Add symmetrical max decrease in w - IF(Wn < UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN - Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) - ENDIF - Wn = MIN(MAX(Wn,0.0), 3.0) - - IF (debug_mf == 1) THEN - IF (Wn .GE. 3.0) THEN - ! surface values - print *," **** SUSPICIOUSLY LARGE W:" - print *,' QCn:',QCn,' ENT=',ENT(k,i),' Nup2=',Nup2 - print *,'pblh:',pblh,' Wn:',Wn,' UPW(k-1)=',UPW(K-1,I) - print *,'K=',k,' B=',B,' dz=',ZW(k)-ZW(k-1) - ENDIF - ENDIF - - !Allow strongly forced plumes to overshoot if KE is sufficient - IF (fltv > 0.05 .AND. Wn <= 0 .AND. overshoot == 0) THEN - overshoot = 1 - IF ( THVk-THVkm1 .GT. 0.0 ) THEN - bvf = SQRT( gtr*(THVk-THVkm1)/dz(k) ) - !vertical Froude number - Frz = UPW(K-1,I)/(bvf*dz(k)) - IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I) - ENDIF - ELSEIF (fltv > 0.05 .AND. overshoot == 1) THEN - !Do not let overshooting parcel go more than 1 layer up - Wn = 0.0 - ENDIF - - !Limit very tall plumes -! Wn2=Wn2*EXP(-MAX(ZW(k)-(pblh+2000.),0.0)/1000.) -! IF(ZW(k) >= pblh+3000.)Wn2=0. - Wn=Wn*EXP(-MAX(ZW(k+1)-MIN(pblh+2000.,3000.),0.0)/1000.) - IF(ZW(k+1) >= MIN(pblh+3000.,4500.))Wn=0. - - !JOE- minimize the plume penetratration in stratocu-topped PBL - ! IF (fltv < 0.06) THEN - ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. - ! ENDIF - - IF (Wn > 0.) THEN - UPW(K,I)=Wn !Wn !sqrt(Wn2) - UPTHV(K,I)=THVn - UPTHL(K,I)=THLn - UPQT(K,I)=QTn - UPQC(K,I)=QCn - UPU(K,I)=Un - UPV(K,I)=Vn - UPQKE(K,I)=QKEn - UPQNC(K,I)=QNCn - UPQNI(K,I)=QNIn - UPQNWFA(K,I)=QNWFAn - UPQNIFA(K,I)=QNIFAn - UPA(K,I)=UPA(K-1,I) -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - UPCHEM(k,I,ic) = chemn(ic) - enddo - ENDIF -#endif - ktop = MAX(ktop,k) - ELSE - exit !exit k-loop - END IF - ENDDO - IF (debug_mf == 1) THEN - IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. & - MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN - ! surface values - print *,'flq:',flq,' fltv:',fltv,' Nup2=',Nup2 - print *,'pblh:',pblh,' wstar:',wstar,' ktop=',ktop - print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT - ! means - print *,'u:',u - print *,'v:',v - print *,'thl:',thl - print *,'UPA:',UPA(:,I) - print *,'UPW:',UPW(:,I) - print *,'UPTHL:',UPTHL(:,I) - print *,'UPQT:',UPQT(:,I) - print *,'ENT:',ENT(:,I) - ENDIF - ENDIF - ENDDO - ELSE - !At least one of the conditions was not met for activating the MF scheme. - NUP2=0. - END IF !end criteria for mass-flux scheme - - ktop=MIN(ktop,KTE-1) ! Just to be safe... - IF (ktop == 0) THEN - ztop = 0.0 - ELSE - ztop=zw(ktop+1) - ENDIF - - IF(nup2 > 0) THEN - - !Calculate the fluxes for each variable - DO k=KTS,KTE - IF(k > KTOP) exit - DO i=1,NUP !NUP2 - IF(I > NUP2) exit - s_aw(k+1) = s_aw(k+1) + UPA(K,i)*UPW(K,i)*Psig_w - s_awthl(k+1)= s_awthl(k+1) + UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w - s_awqt(k+1) = s_awqt(k+1) + UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w - s_awqc(k+1) = s_awqc(k+1) + UPA(K,i)*UPW(K,i)*UPQC(K,i)*Psig_w - IF (momentum_opt > 0) THEN - s_awu(k+1) = s_awu(k+1) + UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w - s_awv(k+1) = s_awv(k+1) + UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w - ENDIF - IF (tke_opt > 0) THEN - s_awqke(k+1)= s_awqke(k+1) + UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w - ENDIF -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - s_awchem(k+1,ic) = s_awchem(k+1,ic) + UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w - enddo - ENDIF -#endif - ENDDO - s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) - ENDDO - IF (scalar_opt > 0) THEN - DO k=KTS,KTE - IF(k > KTOP) exit - DO I=1,NUP !NUP2 - IF (I > NUP2) exit - s_awqnc(k+1)= s_awqnc(K+1) + UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w - s_awqni(k+1)= s_awqni(K+1) + UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w - s_awqnwfa(k+1)= s_awqnwfa(K+1) + UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w - s_awqnifa(k+1)= s_awqnifa(K+1) + UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w - ENDDO - ENDDO - ENDIF - - !Flux limiter: Check for too large heat flux at top of first model layer - ! Given that the temperature profile is calculated as: - ! d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & - ! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt*dheat_opt - ! So, s_awthl(kts+1) must be less than flt - THVk = (THL(kts)*DZ(kts+1)+THL(kts+1)*DZ(kts))/(DZ(kts+1)+DZ(kts)) - flx1 = MAX(s_aw(kts+1)*(s_awthl(kts+1)/s_aw(kts+1) - THVk),0.0) - !flx1 = -dt/dz(kts)*s_awthl(kts+1) - !flx1 = (s_awthl(kts+1)-s_awthl(kts))!/(0.5*(dz(k)+dz(k-1))) - adjustment=1.0 - !Print*,"Flux limiter in MYNN-EDMF:" - !Print*,"flx1=",flx1," s_awthl(kts+1)=",s_awthl(kts+1)," s_awthl(kts)=",s_awthl(kts) - IF (flx1 > fluxportion*flt .AND. flx1>0.0) THEN - adjustment= fluxportion*flt/flx1 - s_aw = s_aw*adjustment - s_awthl= s_awthl*adjustment - s_awqt = s_awqt*adjustment - s_awqc = s_awqc*adjustment - s_awqv = s_awqv*adjustment - s_awqnc= s_awqnc*adjustment - s_awqni= s_awqni*adjustment - s_awqnwfa= s_awqnwfa*adjustment - s_awqnifa= s_awqnifa*adjustment - IF (momentum_opt > 0) THEN - s_awu = s_awu*adjustment - s_awv = s_awv*adjustment - ENDIF - IF (tke_opt > 0) THEN - s_awqke= s_awqke*adjustment - ENDIF -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - s_awchem = s_awchem*adjustment - ENDIF -#endif - UPA = UPA*adjustment - ENDIF - !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt - - !Calculate mean updraft properties for output: - DO k=KTS,KTE-1 - IF(k > KTOP) exit - DO I=1,NUP !NUP2 - IF(I > NUP2) exit - edmf_a(K) =edmf_a(K) +UPA(K,i) - edmf_w(K) =edmf_w(K) +UPA(K,i)*UPW(K,i) - edmf_qt(K) =edmf_qt(K) +UPA(K,i)*UPQT(K,i) - edmf_thl(K)=edmf_thl(K)+UPA(K,i)*UPTHL(K,i) - edmf_ent(K)=edmf_ent(K)+UPA(K,i)*ENT(K,i) - edmf_qc(K) =edmf_qc(K) +UPA(K,i)*UPQC(K,i) -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic) + UPA(K,I)*UPCHEM(k,i,ic) - enddo - ENDIF -#endif - ENDDO - - IF (edmf_a(k)>0.) THEN - edmf_w(k)=edmf_w(k)/edmf_a(k) - edmf_qt(k)=edmf_qt(k)/edmf_a(k) - edmf_thl(k)=edmf_thl(k)/edmf_a(k) - edmf_ent(k)=edmf_ent(k)/edmf_a(k) - edmf_qc(k)=edmf_qc(k)/edmf_a(k) -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) - enddo - ENDIF -#endif - edmf_a(k)=edmf_a(k)*Psig_w - - !FIND MAXIMUM MASS-FLUX IN THE COLUMN: - IF(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) - ENDIF - ENDDO - - !First, compute exner, plume theta, and dz centered at interface - !Here, k=1 is the top of the first model layer. These values do not - !need to be defined at k=kte (unused level). - DO K=KTS,KTE-1 - exneri(k) = (exner(k)*DZ(k+1)+exner(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K) - dzi(k) = 0.5*(DZ(k)+DZ(k+1)) - ENDDO - -!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in -! mym_condensation. Here, a shallow-cu component is added, but no cumulus -! clouds can be added at k=1 (start loop at k=2). - DO K=KTS+1,KTE-2 - IF(k > KTOP) exit - IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN - - satvp = 3.80*exp(17.27*(th(k)-273.)/ & - (th(k)-36.))/(.01*p(k)) - rhgrid = max(.01,MIN( 1., qv(k) /satvp)) - - !then interpolate plume thl, th, and qt to mass levels - THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - !convert TH to T - t = THp*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - - !condensed liquid in the plume on mass levels - IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN - QCp = 0.5*(edmf_qc(k)+edmf_qc(k-1)) - ELSE - QCp = MAX(0.0, QTp-qsl) - ENDIF - - !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq - - xl = xl_blend(tk(k)) ! obtain blended heat capacity - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl - ! CB02, Eqn. 4 - cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 - a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - b9 = a*rsl ! CB02 variable "b" - - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*QCp*0.5*(edmf_a(k)+edmf_a(k-1)) ! potential temp (env + plume) - bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from - ! "b9" in CB02 by a factor - ! of T/theta. Strictly, b9 above is formulated in - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qt(k) - alpha = 0.61*pt - t = TH(k)*exner(k) - beta = pt*xl/(t*cp) - 1.61*pt - !Buoyancy flux terms have been moved to the end of this section... - - !Now calculate convective component of the cloud fraction: - if (a > 0.0) then - f = MIN(1.0/a, 4.0) ! f is vertical profile scaling function (CB2005) - else - f = 1.0 - endif - sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & - & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) - !sigq = MAX(sigq, 1.0E-4) - sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components - - qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; - ! the numerator of Q1 - mf_cf = min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) - IF ( debug_code ) THEN - print*,"In MYNN, StEM edmf" - print*," CB: env qt=",qt(k)," qsat=",qsat_tl - print*," satdef=",QTp - qsat_tl - print*," CB: sigq=",sigq," qmq=",qmq," tlk=",tlk - print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) - ENDIF - - IF (cldfra_bl1d(k) < 0.5) THEN - IF (mf_cf > 0.5*(edmf_a(k)+edmf_a(k-1))) THEN - cldfra_bl1d(k) = mf_cf - qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf - ELSE - cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) - qc_bl1d(k) = QCp - ENDIF - ENDIF - - !Now recalculate the terms for the buoyancy flux for mass-flux clouds: - !See mym_condensation for details on these formulations. The - !cloud-fraction bounding was added to improve cloud retention, - !following RAP and HRRR testing. - !Fng = 2.05 ! the non-Gaussian transport factor (assumed constant) - !Use Bechtold and Siebesma (1998) piecewise estimation of Fng: - Q1 = qmq/MAX(sigq,1E-10) - Q1=MAX(Q1,-5.0) - IF (Q1 .GE. 1.0) THEN - Fng = 1.0 - ELSEIF (Q1 .GE. -1.7 .AND. Q1 < 1.0) THEN - Fng = EXP(-0.4*(Q1-1.0)) - ELSEIF (Q1 .GE. -2.5 .AND. Q1 .LE. -1.7) THEN - Fng = 3.0 + EXP(-3.8*(Q1+1.7)) - ELSE - Fng = MIN(23.9 + EXP(-1.6*(Q1+2.5)), 60.) - ENDIF - - vt(k) = qww - MIN(0.4,cldfra_bl1D(k))*beta*bb*Fng - 1. - vq(k) = alpha + MIN(0.4,cldfra_bl1D(k))*beta*a*Fng - tv0 - ENDIF - - ENDDO - - ENDIF !end nup2 > 0 - - !modify output (negative: dry plume, positive: moist plume) - IF (ktop > 0) THEN - maxqc = maxval(edmf_qc(1:ktop)) - IF ( maxqc < 1.E-8) maxmf = -1.0*maxmf - ENDIF - -! -! debugging -! -IF (edmf_w(1) > 4.0) THEN -! surface values - print *,'flq:',flq,' fltv:',fltv - print *,'pblh:',pblh,' wstar:',wstar - print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT -! means -! print *,'u:',u -! print *,'v:',v -! print *,'thl:',thl -! print *,'thv:',thv -! print *,'qt:',qt -! print *,'p:',p - -! updrafts -! DO I=1,NUP2 -! print *,'up:A',i -! print *,UPA(:,i) -! print *,'up:W',i -! print*,UPW(:,i) -! print *,'up:thv',i -! print *,UPTHV(:,i) -! print *,'up:thl',i -! print *,UPTHL(:,i) -! print *,'up:qt',i -! print *,UPQT(:,i) -! print *,'up:tQC',i -! print *,UPQC(:,i) -! print *,'up:ent',i -! print *,ENT(:,i) -! ENDDO - -! mean updrafts - print *,' edmf_a',edmf_a(1:14) - print *,' edmf_w',edmf_w(1:14) - print *,' edmf_qt:',edmf_qt(1:14) - print *,' edmf_thl:',edmf_thl(1:14) - -ENDIF !END Debugging - - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - -END SUBROUTINE DMP_MF -!================================================================= - -subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) -! -! zero or one condensation for edmf: calculates THV and QC -! -real,intent(in) :: QT,THL,P,zagl -real,intent(out) :: THV -real,intent(inout):: QC - -integer :: niter,i -real :: diff,exn,t,th,qs,qcold - -! constants used from module_model_constants.F -! p1000mb -! rcp ... Rd/cp -! xlv ... latent heat for water (2.5e6) -! cp -! rvord .. rv/rd (1.6) - -! number of iterations - niter=50 -! minimum difference (usually converges in < 8 iterations with diff = 2e-5) - diff=2.e-5 - - EXN=(P/p1000mb)**rcp - !QC=0. !better first guess QC is incoming from lower level, do not set to zero - do i=1,NITER - T=EXN*THL + xlv/cp*QC - QS=qsat_blend(T,P) - QCOLD=QC - QC=0.5*QC + 0.5*MAX((QT-QS),0.) - if (abs(QC-QCOLD) 0.0) THEN -! PRINT*,"EDMF SAT, p:",p," iterations:",i -! PRINT*," T=",T," THL=",THL," THV=",THV -! PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs -! ENDIF - - !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE - !TH = THL + xlv/cp/EXN*QC - !THV= TH*(1. + 0.608*QT) - - !print *,'t,p,qt,qs,qc' - !print *,t,p,qt,qs,qc - - -end subroutine condensation_edmf - -!=============================================================== - -SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) - - !--------------------------------------------------------------- - ! NOTES ON SCALE-AWARE FORMULATION - ! - !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011, - ! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS) - ! - ! Psig_bl tapers local mixing - ! Psig_shcu tapers nonlocal mixing - - REAL,INTENT(IN) :: dx,PBL1 - REAL, INTENT(OUT) :: Psig_bl,Psig_shcu - REAL :: dxdh - - Psig_bl=1.0 - Psig_shcu=1.0 - dxdh=MAX(dx,10.)/MIN(PBL1,3000.) - ! Honnert et al. 2011, TKE in PBL *** original form used until 201605 - !Psig_bl= ((dxdh**2) + 0.07*(dxdh**0.667))/((dxdh**2) + & - ! (3./21.)*(dxdh**0.67) + (3./42.)) - ! Honnert et al. 2011, TKE in entrainment layer - !Psig_bl= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & - ! (3./20.)*(dxdh**0.67) + (7./21.)) - ! New form to preseve parameterized mixing - only down 5% at dx = 750 m - Psig_bl= ((dxdh**2) + 0.106*(dxdh**0.667))/((dxdh**2) +0.066*(dxdh**0.667) + 0.071) - - !assume a 500 m cloud depth for shallow-cu clods - dxdh=MAX(dx,10.)/MIN(PBL1+500.,3500.) - ! Honnert et al. 2011, TKE in entrainment layer *** original form used until 201605 - !Psig_shcu= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & - ! (3./20.)*(dxdh**0.67) + (7./21.)) - - ! Honnert et al. 2011, TKE in cumulus - !Psig(i)= ((dxdh**2) + 1.67*(dxdh**1.4))/((dxdh**2) +1.66*(dxdh**1.4) + - !0.2) - - ! Honnert et al. 2011, w'q' in PBL - !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.03*(dxdh**1.4) - - !(4./13.))/((dxdh**2) + 0.03*(dxdh**1.4) + (4./13.)) - ! Honnert et al. 2011, w'q' in cumulus - !Psig(i)= ((dxdh**2) - 0.07*(dxdh**1.4))/((dxdh**2) -0.07*(dxdh**1.4) + - !0.02) - - ! Honnert et al. 2011, q'q' in PBL - !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.25*(dxdh**0.667) -0.73)/((dxdh**2) - !-0.03*(dxdh**0.667) + 0.73) - ! Honnert et al. 2011, q'q' in cumulus - !Psig(i)= ((dxdh**2) - 0.34*(dxdh**1.4))/((dxdh**2) - 0.35*(dxdh**1.4) - !+ 0.37) - - ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in PBL (same as Honnert's above) - !Psig_shcu= ((dxdh**2) + 0.070*(dxdh**0.667))/((dxdh**2) - !+0.142*(dxdh**0.667) + 0.071) - ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in entrainment zone *** switch to this form 201605 - Psig_shcu= ((dxdh**2) + 0.145*(dxdh**0.667))/((dxdh**2) +0.172*(dxdh**0.667) + 0.170) - - ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in PBL - !Psig(i)= 0.5 + 0.5*((dxdh**2) -0.098)/((dxdh**2) + 0.106) - ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in entrainment zone - !Psig(i)= 0.5 + 0.5*((dxdh**2) - 0.112*(dxdh**0.25) -0.071)/((dxdh**2) - !+ 0.054*(dxdh**0.25) + 0.10) - - !print*,"in scale_aware; dx, dxdh, Psig(i)=",dx,dxdh,Psig(i) - !If(Psig_bl(i) < 0.0 .OR. Psig(i) > 1.)print*,"dx, dxdh, Psig(i)=",dx,dxdh,Psig_bl(i) - If(Psig_bl > 1.0) Psig_bl=1.0 - If(Psig_bl < 0.0) Psig_bl=0.0 - - If(Psig_shcu > 1.0) Psig_shcu=1.0 - If(Psig_shcu < 0.0) Psig_shcu=0.0 - - END SUBROUTINE SCALE_AWARE - -! ===================================================================== - - FUNCTION esat_blend(t) -! JAYMES- added 22 Apr 2015 -! -! This calculates saturation vapor pressure. Separate ice and liquid functions -! are used (identical to those in module_mp_thompson.F, v3.6). Then, the -! final returned value is a temperature-dependant "blend". Because the final -! value is "phase-aware", this formulation may be preferred for use throughout -! the module (replacing "svp"). - - IMPLICIT NONE - - REAL, INTENT(IN):: t - REAL :: esat_blend,XC,ESL,ESI,chi - - XC=MAX(-80.,t-273.16) - -! For 253 < t < 273.16 K, the vapor pressures are "blended" as a function of temperature, -! using the approach of Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting -! values are returned from the function. - IF (t .GE. 273.16) THEN - esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ELSE IF (t .LE. 253.) THEN - esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - ELSE - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - chi = (273.16-t)/20.16 - esat_blend = (1.-chi)*ESL + chi*ESI - END IF - - END FUNCTION esat_blend - -! ==================================================================== - - FUNCTION qsat_blend(t, P, waterice) -! JAYMES- this function extends function "esat" and returns a "blended" -! saturation mixing ratio. - - IMPLICIT NONE - - REAL, INTENT(IN):: t, P - CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: waterice - CHARACTER(LEN=1) :: wrt - REAL :: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi - - IF ( .NOT. PRESENT(waterice) ) THEN - wrt = 'b' - ELSE - wrt = waterice - ENDIF - - XC=MAX(-80.,t-273.16) - - IF ((t .GE. 273.16) .OR. (wrt .EQ. 'w')) THEN - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - qsat_blend = 0.622*ESL/(P-ESL) - ELSE IF (t .LE. 253.) THEN - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - qsat_blend = 0.622*ESI/(P-ESI) - ELSE - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - RSLF = 0.622*ESL/(P-ESL) - RSIF = 0.622*ESI/(P-ESI) - chi = (273.16-t)/20.16 - qsat_blend = (1.-chi)*RSLF + chi*RSIF - END IF - - END FUNCTION qsat_blend - -! =================================================================== - - FUNCTION xl_blend(t) -! JAYMES- this function interpolates the latent heats of vaporization and -! sublimation into a single, temperature-dependant, "blended" value, following -! Chaboureau and Bechtold (2002), Appendix. - - IMPLICIT NONE - - REAL, INTENT(IN):: t - REAL :: xl_blend,xlvt,xlst,chi - - IF (t .GE. 273.16) THEN - xl_blend = xlv + (cpv-cliq)*(t-273.16) !vaporization/condensation - ELSE IF (t .LE. 253.) THEN - xl_blend = xls + (cpv-cice)*(t-273.16) !sublimation/deposition - ELSE - xlvt = xlv + (cpv-cliq)*(t-273.16) !vaporization/condensation - xlst = xls + (cpv-cice)*(t-273.16) !sublimation/deposition - chi = (273.16-t)/20.16 - xl_blend = (1.-chi)*xlvt + chi*xlst !blended - END IF - - END FUNCTION xl_blend - -! =================================================================== -! =================================================================== -! =================================================================== - -END MODULE module_bl_mynn From ca4810b57a7ce608b4d1200489175e4aa3225ecb Mon Sep 17 00:00:00 2001 From: "haiqin.li" Date: Thu, 28 Feb 2019 03:15:57 +0000 Subject: [PATCH 14/15] "latest GF & MYNN to ccpp-physics/physics" --- physics/cu_gf_deep.F90 | 145 ++-- physics/cu_gf_driver.F90 | 13 +- physics/cu_gf_sh.F90 | 114 ++- physics/module_bl_mynn.F90 | 1514 ++++-------------------------------- 4 files changed, 336 insertions(+), 1450 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 9f857a0cb..a706e1cdf 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -6,9 +6,9 @@ module cu_gf_deep real(kind=kind_phys), parameter::r_v=461. real(kind=kind_phys), parameter :: tcrit=258. ! tuning constant for cloudwater/ice detrainment - real(kind=kind_phys), parameter:: c1=.002 ! .0005 + real(kind=kind_phys), parameter:: c1= 0.003 !.002 ! .0005 ! parameter to turn on or off evaporation of rainwater as done in sas - integer, parameter :: irainevap=1 + integer, parameter :: irainevap=0 ! max allowed fractional coverage (frh_thresh) real(kind=kind_phys), parameter::frh_thresh = .9 ! rh threshold. if fractional coverage ~ frh_thres, do not use cupa any further @@ -362,6 +362,8 @@ subroutine cu_gf_deep_run( & el2orc=xlv*xlv/(r_v*cp) evfact=.2 evfactl=.2 + !evfact=.0 ! for 4F5f + !evfactl=.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -370,11 +372,11 @@ subroutine cu_gf_deep_run( & ! ! ecmwf pgcon=0. - lambau(:)=5. - if(imid.eq.1)lambau(:)=5. + lambau(:)=2.0 + if(imid.eq.1)lambau(:)=2.0 ! here random must be between -1 and 1 if(nranflag == 1)then - lambau(:)=4.5+rand_mom(:) + lambau(:)=1.5+rand_mom(:) endif ! sas ! lambau=0. @@ -445,7 +447,7 @@ subroutine cu_gf_deep_run( & entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 if(xland1(i) == 0)entr_rate(i)=7.e-5 if(imid.eq.1)entr_rate(i)=3.e-4 - if(imid.eq.1)c1d(i,:)=c1 ! comment to test warm bias 08/14/17 +! if(imid.eq.1)c1d(i,:)=c1 ! comment to test warm bias 08/14/17 radius=.2/entr_rate(i) frh=min(1.,3.14*radius*radius/dx(i)/dx(i)) if(frh > frh_thresh)then @@ -756,10 +758,18 @@ subroutine cu_gf_deep_run( & ! ! calculate mass entrainment and detrainment ! + if(imid.eq.1)then + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,'mid',kbcon,k22,up_massentru,up_massdetru,lambau) + else call get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & ,up_massentro, up_massdetro ,up_massentr, up_massdetr & ,'deep',kbcon,k22,up_massentru,up_massdetru,lambau) + endif + ! ! note: ktop here already includes overshooting, ktopdby is without @@ -892,10 +902,27 @@ subroutine cu_gf_deep_run( & do i=its,itf if(ierr(i) /= 0) cycle ! do k=kbcon(i)+1,ktop(i)-1 - do k=jmin(i)+1,ktop(i)-1 - c1d(i,k)=c1 - enddo +!c do k=jmin(i)+1,ktop(i)-1 +!c c1d(i,k)=c1 +!c enddo !if(imid.eq.1)c1d(i,:)=0. +! do k=kts,ktop(i) +! if(po(i,k).gt.700.)then +! c1d(i,k)=0. +! elseif(po(i,k).gt.600.)then +! c1d(i,k)=0.001 +! elseif(po(i,k).gt.500.)then +! c1d(i,k)=0.002 +! elseif(po(i,k).gt.400.)then +! c1d(i,k)=0.003 +! elseif(po(i,k).gt.300.)then +! c1d(i,k)=0.004 +! elseif(po(i,k).gt.200.)then +! c1d(i,k)=0.005 +! endif +! enddo +! if(imid.eq.1)c1d(i,:)=0.003 + do k=ktop(i)+1,ktf hco(i,k)=heso_cup(i,k) dbyo(i,k)=0. @@ -1161,8 +1188,8 @@ subroutine cu_gf_deep_run( & 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.) +! cbeg=800. !po_cup(i,kbcon(i)) !850. +! cend=min(po_cup(i,ktop(i)),200.) ! cmid=.5*(cbeg+cend) !600. ! const_b=c1/((cmid*cmid-cbeg*cbeg)*(cbeg-cend)/(cend*cend-cbeg*cbeg)+cmid-cbeg) ! const_a=const_b*(cbeg-cend)/(cend*cend-cbeg*cbeg) @@ -1170,22 +1197,22 @@ subroutine cu_gf_deep_run( & ! 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 +!! 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 - - +!! 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) @@ -1621,16 +1648,16 @@ subroutine cu_gf_deep_run( & !-- take out cloud liquid water for detrainment detup=up_massdetro(i,k) dz=zo_cup(i,k)-zo_cup(i,k-1) -! if(k.lt.ktop(i) .and. k.ge.jmin(i)) then -! if(k.lt.ktop(i) .and. c1d(i,k).gt.0) then +!! if(k.lt.ktop(i) .and. k.ge.jmin(i)) then +!! if(k.lt.ktop(i) .and. c1d(i,k).gt.0) then if(k.lt.ktop(i)) then dellaqc(i,k) = zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g else dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp endif -! if(imid.eq.1) dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp - if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp - !--- +!! if(imid.eq.1) dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! !--- g_rain= 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp e_dn = -0.5*(pwdo(i,k)+pwdo(i,k+1))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 !-- condensation source term = detrained + flux divergence of @@ -1939,7 +1966,7 @@ subroutine cu_gf_deep_run( & do k = ktop(i), 1, -1 rain = pwo(i,k) + edto(i) * pwdo(i,k) rn(i) = rn(i) + rain * xmb(i) * .001 * dtime - if(po(i,k).gt.700.)then + !if(po(i,k).gt.700.)then if(flg(i))then q1=qo(i,k)+(outq(i,k))*dtime t1=tn(i,k)+(outt(i,k))*dtime @@ -1964,7 +1991,7 @@ subroutine cu_gf_deep_run( & pre(i)=max(pre(i),0.) delqev(i) = delqev(i) + .001*dp*qevap(i)/g endif - endif ! 700mb + !endif ! 700mb endif enddo ! pre(i)=1000.*rn(i)/dtime @@ -3626,7 +3653,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & iprop,iall,i,k integer :: start_level(its:ite) real(kind=kind_phys) :: & - prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver, & + prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & c0,dz,berryc0,q1,berryc real(kind=kind_phys) :: & denom, c0t @@ -3636,6 +3663,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & prop_b(kts:kte)=0 iall=0 c0=.002 + clwdet=100. bdsp=bdispm ! !--- no precip for small clouds @@ -3813,7 +3841,14 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & pw(i,k)=(qc(i,k)-qrch)*zu(i,k) if(pw(i,k).lt.0.)pw(i,k)=0. else +! create clw detrainment profile that depends on mass detrainment and +! in-cloud clw/ice +! + c1d(i,k)=clwdet*up_massdetr(i,k-1)*qrc(i,k-1) qrc(i,k)=(qc(i,k)-qrch)/(1.+(c1d(i,k)+c0t)*dz) + if(qrc(i,k).lt.0.)then ! hli new test 02/12/19 + qrc(i,k)=0. + endif pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) !-----srf-08aug2017-----begin ! pw(i,k)=(c1d(i,k)+c0)*dz*max(0.,qrc(i,k) -qrc_crit)! units kg[rain]/kg[air] @@ -3919,7 +3954,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo integer, dimension (its:ite) :: start_level ! zustart=.1 - dbythresh= 1. !.0.95 ! 0.85, 0.6 + dbythresh= 0.8 !.0.95 ! 0.85, 0.6 if(name == 'shallow' .or. name == 'mid') dbythresh=1. dby(:)=0. @@ -3969,6 +4004,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo kfinalzu=ktf-2 ktop(i)=kfinalzu 412 continue + kklev=min(kklev+3,ktop(i)-2) ! ! at least overshoot by one level ! @@ -4017,9 +4053,10 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k implicit none ! real(kind=kind_phys), parameter :: beta_deep=1.3,g_beta_deep=0.8974707 ! real(kind=kind_phys), parameter :: beta_deep=1.2,g_beta_deep=0.8974707 - real(kind=kind_phys), parameter :: beta_sh=2.5,g_beta_sh=1.329340 -! real(kind=kind_phys), parameter :: beta_mid=1.3,g_beta_mid=0.8974707 - real(kind=kind_phys), parameter :: beta_mid=2.2,g_beta_mid=0.8974707 +! real(kind=kind_phys), parameter :: beta_sh=2.5,g_beta_sh=1.329340 + real(kind=kind_phys), parameter :: beta_sh=2.2,g_beta_sh=0.8974707 + real(kind=kind_phys), parameter :: beta_mid=1.3,g_beta_mid=0.8974707 +! real(kind=kind_phys), parameter :: beta_mid=1.8,g_beta_mid=0.8974707 real(kind=kind_phys), parameter :: beta_dd=4.0,g_beta_dd=6. integer, intent(in) ::ipr,xland,kb,kklev,kt,kts,kte,ktf,kpbli,csum,pmin_lev real(kind=kind_phys), intent(in) ::max_mass,zubeg @@ -4064,6 +4101,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k lev_start=min(.9,.1+csum*.013) kb_adj=max(kb,2) tunning=max(p(kklev+1),.5*(p(kpbli)+p(kt))) + tunning=p(kklev) ! tunning=p(kklev+1) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start ! tunning=.5*(p(kb_adj)+p(kt)) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start trash=-p(kt)+p(kb_adj) @@ -4175,7 +4213,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k kb_adj=max(kb,2) tunning=.5*(p(kt)+p(kpbli)) !p(kt)+(p(kb_adj)-p(kt))*.9 !*.33 !new nov18 - tunning=p(kpbli) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +! tunning=p(kpbli) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start !end new tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 tunning =max(0.02, tunning) @@ -4517,7 +4555,8 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte character *(*), intent (in) :: draft integer, intent(in):: itf,ktf, its,ite, kts,kte integer, intent(in) , dimension(its:ite) :: ierr,ktop,kbcon,k22 - real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau + !real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau + real(kind=kind_phys), intent(inout), optional , dimension(its:ite):: lambau real(kind=kind_phys), intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo real(kind=kind_phys), intent(inout), dimension(its:ite,kts:kte) :: cd,entr_rate_2d real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte) :: up_massentro, up_massdetro & @@ -4585,13 +4624,25 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte 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 - turn=maxloc(zuo(i,:),1) - do k=2,turn - up_massentru(i,k-1)=up_massentro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) - up_massdetru(i,k-1)=up_massdetro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'deep')then + !turn=maxloc(zuo(i,:),1) + !do k=2,turn + ! up_massentru(i,k-1)=up_massentro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + ! up_massdetru(i,k-1)=up_massdetro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + !enddo + !do k=turn+1,ktf-1 + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'shallow')then + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) enddo - do k=turn+1,ktf-1 + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'mid')then + lambau(i)=0. + do k=2,ktf-1 up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) enddo @@ -4791,7 +4842,7 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c integer, dimension (its:ite) :: start_level integer,parameter :: find_ktop_option = 1 !0=original, 1=new - dbythresh=1. !0.95 ! the range of this parameter is 0-1, higher => lower + dbythresh=0.8 !0.95 ! the range of this parameter is 0-1, higher => lower ! overshoting (cheque aa0 calculation) ! rainfall is too sensible this parameter ! for now, keep =1. diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index e6b197e04..9cf3142a6 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -374,8 +374,7 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & ierrs(:)=0 cuten(:)=0. cutenm(:)=0. - cutens(:)=1. - if(ishallow_g3.eq.0)cutens(:)=0. + cutens(:)=0. ierrc(:)=" " kbcon(:)=0 @@ -531,7 +530,7 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & !> if ishallow_g3=1, call shallow: cup_gf_sh() ! ! print*,'hli bf shallow t2d',t2d - call cu_gf_sh_run ( & + call cu_gf_sh_run (us,vs, & ! input variables, must be supplied zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli, & rhoi,hfx,qfx,xlandi,ichoice_s,tcrit,dt, & @@ -539,13 +538,13 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & ! turning off shallow convection for grid points zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & ! output tendencies - outts,outqs,outqcs,cnvwt,prets,cupclws, & + outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & ! dimesnional variables itf,ktf,its,ite, kts,kte,ipr,tropics) do i=its,itf - if(xmbs(i).le.0.)cutens(i)=0. + if(xmbs(i).gt.0.)cutens(i)=1. enddo call neg_check('shallow',ipn,dt,qcheck,outqs,outts,outus,outvs, & outqcs,prets,its,ite,kts,kte,itf,ktf,ktops) @@ -779,8 +778,8 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & t(i,k)=t(i,k)+dt*(cutens(i)*outts(i,k)+cutenm(i)*outtm(i,k)+outt(i,k)*cuten(i)) qv(i,k)=max(1.e-16,qv(i,k)+dt*(cutens(i)*outqs(i,k)+cutenm(i)*outqm(i,k)+outq(i,k)*cuten(i))) gdc(i,k,7)=sqrt(us(i,k)**2 +vs(i,k)**2) - us(i,k)=us(i,k)+outu(i,k)*cuten(i)*dt +outum(i,k)*cutenm(i)*dt - vs(i,k)=vs(i,k)+outv(i,k)*cuten(i)*dt +outvm(i,k)*cutenm(i)*dt + us(i,k)=us(i,k)+outu(i,k)*cuten(i)*dt +outum(i,k)*cutenm(i)*dt +outus(i,k)*cutens(i)*dt + vs(i,k)=vs(i,k)+outv(i,k)*cuten(i)*dt +outvm(i,k)*cutenm(i)*dt +outvs(i,k)*cutens(i)*dt !hj 10/11/2016: don't need gdc and gdc2 yet for gsm. !hli 08/18/2017: couple gdc to radiation diff --git a/physics/cu_gf_sh.F90 b/physics/cu_gf_sh.F90 index e2abdebb2..173de662e 100644 --- a/physics/cu_gf_sh.F90 +++ b/physics/cu_gf_sh.F90 @@ -41,7 +41,8 @@ ! ztexec,zqexec excess temperature and moisture for updraft module cu_gf_sh use machine , only : kind_phys - real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 + !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 + real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 real(kind=kind_phys), parameter:: g =9.81 real(kind=kind_phys), parameter:: cp =1004. real(kind=kind_phys), parameter:: xlv=2.5e6 @@ -53,13 +54,13 @@ module cu_gf_sh subroutine cu_gf_sh_run ( & ! input variables, must be supplied - zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & + us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & hfx,qfx,xland,ichoice,tcrit,dtime, & ! input variables. ierr should be initialized to zero or larger than zero for ! turning off shallow convection for grid points zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & ! output tendencies - outt,outq,outqc,cnvwt,pre,cupclw, & + outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! dimesnional variables itf,ktf,its,ite, kts,kte,ipr,tropics) ! @@ -85,7 +86,7 @@ subroutine cu_gf_sh_run ( & ! pre = output precip real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & - cnvwt,outt,outq,outqc,cupclw,zuo + cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & xmb_out @@ -104,7 +105,7 @@ subroutine cu_gf_sh_run ( & ! real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & - t,po,tn,dhdt,rho + t,po,tn,dhdt,rho,us,vs real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & q,qo @@ -172,7 +173,7 @@ subroutine cu_gf_sh_run ( & ! dellaq = change of q per unit mass flux of cloud ensemble ! dellaqc = change of qc per unit mass flux of cloud ensemble - cd,dellah,dellaq,dellat,dellaqc + cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup ! aa0 cloud work function for downdraft ! aa0 = cloud work function without forcing effects @@ -184,7 +185,7 @@ subroutine cu_gf_sh_run ( & flux_tun,hkbo,xhkb, & rand_vmas,xmbmax,xmb, & cap_max,entr_rate, & - cap_max_increment + cap_max_increment,lambau integer, dimension (its:ite) :: & kstabi,xland1,kbmax,ktopx @@ -199,14 +200,16 @@ subroutine cu_gf_sh_run ( & real(kind=kind_phys) xff_shal(3),blqe,xkshal character*50 :: ierrc(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: & - up_massentr,up_massdetr,up_massentro,up_massdetro - real(kind=kind_phys) :: c_up,x_add,qaver - real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz + up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru + real(kind=kind_phys) :: c_up,x_add,qaver,dts,fp,fpi + real(kind=kind_phys), dimension (its:ite,kts:kte) :: c1d,dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers integer, dimension (its:ite) :: start_level, pmin_lev start_level(:)=0 rand_vmas(:)=0. flux_tun=fluxtune + lambau(:)=2. + c1d(:,:)=0. do i=its,itf xland1(i)=int(xland(i)+.001) ! 1. ktopx(i)=0 @@ -232,6 +235,8 @@ subroutine cu_gf_sh_run ( & do i=its,itf up_massentro(i,k)=0. up_massdetro(i,k)=0. + up_massentru(i,k)=0. + up_massdetru(i,k)=0. z(i,k)=zo(i,k) xz(i,k)=zo(i,k) qrco(i,k)=0. @@ -315,6 +320,17 @@ subroutine cu_gf_sh_run ( & its,ite, kts,kte) do i=its,itf if(ierr(i).eq.0)then + u_cup(i,kts)=us(i,kts) + v_cup(i,kts)=vs(i,kts) + do k=kts+1,ktf + u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) + v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) + enddo + endif + enddo + + do i=its,itf + if(ierr(i).eq.0)then ! do k=kts,ktf if(zo_cup(i,k).gt.zkbmax+z1(i))then @@ -459,7 +475,7 @@ subroutine cu_gf_sh_run ( & 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) + ,'shallow',kbcon,k22,up_massentru,up_massdetru,lambau) do k=kts,ktf do i=its,itf @@ -473,6 +489,10 @@ subroutine cu_gf_sh_run ( & enddo do i=its,itf if(ierr(i) /= 0) cycle + do k=1,start_level(i) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + enddo do k=1,start_level(i)-1 hc(i,k)=he_cup(i,k) hco(i,k)=heo_cup(i,k) @@ -490,6 +510,12 @@ subroutine cu_gf_sh_run ( & hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & up_massentr(i,k-1)*he(i,k-1)) / & (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*uc(i,k-1)+ & + up_massentr(i,k-1)*us(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*vc(i,k-1)+ & + up_massentr(i,k-1)*vs(i,k-1))/ & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) dby(i,k)=max(0.,hc(i,k)-hes_cup(i,k)) hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & up_massentro(i,k-1)*heo(i,k-1)) / & @@ -545,7 +571,14 @@ subroutine cu_gf_sh_run ( & dz=z_cup(i,k)-z_cup(i,k-1) ! cloud liquid water ! qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) - qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1_shal)*dz) +! qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1_shal)*dz) + qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) + c1d(i,k-1)=10.*up_massdetr(i,k-1)*.5*(qrco(i,k-1)+qrco(i,k)) + qrco(i,k)= qrco(i,k)-c1d(i,k-1)*dz*qrco(i,k) + if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 + qrco(i,k)=0. + c1d(i,k-1)=1./dz + endif pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) ! cloud water vapor qco (i,k)= trash+qrco(i,k) @@ -570,6 +603,8 @@ subroutine cu_gf_sh_run ( & hc (i,k)=hes_cup (i,k) hco (i,k)=heso_cup(i,k) qco (i,k)=qeso_cup(i,k) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) qrco(i,k)=0. dby (i,k)=0. dbyo(i,k)=0. @@ -609,6 +644,9 @@ subroutine cu_gf_sh_run ( & do i=its,itf dellah(i,k)=0. dellaq(i,k)=0. + dellaqc(i,k)=0. + dellu (i,k)=0. + dellv (i,k)=0. enddo enddo ! @@ -653,6 +691,13 @@ subroutine cu_gf_sh_run ( & trash2=0. do i=its,itf if(ierr(i).eq.0)then + dp=100.*(po_cup(i,1)-po_cup(i,2)) + dellu(i,1)= -zuo(i,2)*(uc (i,2)-u_cup(i,2)) *g/dp + dellv(i,1)= -zuo(i,2)*(vc (i,2)-v_cup(i,2)) *g/dp + dellah(i,1)=-zuo(i,2)*(hco(i,2)-heo_cup(i,2))*g/dp + + dellaq (i,1)=-zuo(i,2)*(qco(i,2)-qo_cup(i,2))*g/dp + do k=k22(i),ktop(i) ! entrainment/detrainment for updraft entup=up_massentro(i,k) @@ -668,8 +713,8 @@ subroutine cu_gf_sh_run ( & !-- take out cloud liquid water for detrainment dz=zo_cup(i,k+1)-zo_cup(i,k) - if(k.lt.ktop(i) .and. c1_shal > 0)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 + if(k.lt.ktop(i) .and. c1d(i,k) > 0)then + dellaqc(i,k)= zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g ! detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp else dellaqc(i,k)=detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp ! dellaqc(i,k)= detup*qrco(i,k) *g/dp @@ -685,6 +730,11 @@ subroutine cu_gf_sh_run ( & dellaq(i,k) =-(zuo(i,k+1)*(qco(i,k+1)-qo_cup(i,k+1) ) - & zuo(i,k )*(qco(i,k )-qo_cup(i,k ) ) )*g/dp & - c_up - 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp + dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) - & + zuo(i,k )*(uc (i,k )-u_cup(i,k ) ) )*g/dp + dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) - & + zuo(i,k )*(vc (i,k )-v_cup(i,k ) ) )*g/dp + enddo endif enddo @@ -826,6 +876,8 @@ subroutine cu_gf_sh_run ( & ktop (i)=0 xmb (i)=0. outt (i,:)=0. + outu (i,:)=0. + outv (i,:)=0. outq (i,:)=0. outqc(i,:)=0. else if(ierr(i).eq.0)then @@ -840,12 +892,46 @@ subroutine cu_gf_sh_run ( & outqc(i,k)= dellaqc(i,k)*xmb(i) pre (i) = pre(i)+pwo(i,k)*xmb(i) enddo + outt (i,1)= dellat (i,1)*xmb(i) + outq (i,1)= dellaq (i,1)*xmb(i) + outu(i,1)=dellu(i,1)*xmb(i) + outv(i,1)=dellv(i,1)*xmb(i) + do k=kts+1,ktop(i) + outu(i,k)=.25*(dellu(i,k-1)+2.*dellu(i,k)+dellu(i,k+1))*xmb(i) + outv(i,k)=.25*(dellv(i,k-1)+2.*dellv(i,k)+dellv(i,k+1))*xmb(i) + enddo + endif enddo +! +! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) +! + do i=its,itf + if(ierr(i).eq.0) then + dts=0. + fpi=0. + do k=kts,ktop(i) + dp=(po_cup(i,k)-po_cup(i,k+1))*100. +!total ke dissiptaion estimate + dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g +! fpi needed for calcualtion of conversion to pot. energyintegrated + fpi = fpi +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp + enddo + if(fpi.gt.0.)then + do k=kts,ktop(i) + fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi + outt(i,k)=outt(i,k)+fp*dts*g/cp + enddo + endif + endif + enddo ! ! done shallow !--------------------------done------------------------------ ! +! do k=1,30 +! print*,'hlisq',qco(1,k),qrco(1,k),pwo(1,k) +! enddo end subroutine cu_gf_sh_run end module cu_gf_sh diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 661bde35e..ff8e6619a 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -35,12 +35,10 @@ ! Added Tripoli and Cotton (1981) correction. ! Added namelist option bl_mynn_cloudmix to test effect of mixing ! cloud species (default = 1: on). -! Added mass-flux option (bl_mynn_edmf, = 1 for StEM, 2 for TEMF). -! This option is off by default (=0). -! Related (hidden) options: +! Added mass-flux option (bl_mynn_edmf, = 1 for DMP mass-flux, 0: off). +! Related options: ! bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme ! bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme -! bl_mynn_edmf_part= 1 : activate areal partitioning of ED & MF ! Added mixing length option (bl_mynn_mixlength, see notes below) ! Added more sophisticated saturation checks, following Thompson scheme ! Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau @@ -68,12 +66,38 @@ ! New tridiagonal solver, which is supposedly 14% faster and more ! conservative. Impact seems very small. ! Many miscellaneous tweaks to the mixing lengths and stratus -! component of the subgrid clouds. +! component of the subgrid-scale (SGS) clouds. ! v4.1 Big improvements in downward SW radiation due to revision of subgrid clouds -! Improved ensemble spread from changes to SPP in MYNN -! Added many IF checks (within IFDEFS) to protect mixchem code +! - better cloud fraction and subgrid scale mixing ratios. +! - may experience a small cool bias during the daytime now that high +! SW-down bias is greatly reduced... +! Some tweaks to increase the turbulent mixing during the daytime for +! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact). +! Improved ensemble spread from changes to SPP in MYNN +! - now perturbing eddy diffusivity and eddy viscosity directly +! - now perturbing background rh (in SGS cloud calc only) +! - now perturbing entrainment rates in mass-flux scheme +! Added IF checks (within IFDEFS) to protect mixchem code from being used +! when HRRR smoke is used (no impact on regular non-wrf chem use) +! Important bug fix for wrf chem when transporting chemical species in MF scheme +! Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2) +! Removed unused stochastic code for mass-flux scheme +! Changed mass-flux scheme to be integrated on interface levels instead of +! mass levels - impact is small +! Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option. +! - activated with bl_mynn_mixscalars = 1; this sets scalar_pblmix = 0 +! - added tridagonal solver used in scalar_pblmix option to duplicate tendencies +! - this alone changes the interface call considerably from v4.0. +! Slight revision to TKE production due to radiation cooling at top of clouds +! Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998, JAS). +! - improves TKE in SGS clouds +! Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp) +! Misc changes made for FV3/MPAS compatibility +! +! Many of these changes are now documented in Olson et al. (2019, +! NOAA Technical Memorandum) ! -! For changes 1, 3, and 6, see "JOE's mods" below: +! For more explanation of some configuration options, see "JOE's mods" below: !------------------------------------------------------------------- MODULE module_bl_mynn @@ -113,7 +137,7 @@ MODULE module_bl_mynn & p_qnc= 0, & & p_qni= 0 -!END FV3 CONSTANTS +!END FV3 CONSTANTS !==================================================================== !WRF CONSTANTS ! USE module_model_constants, only: & @@ -181,7 +205,7 @@ MODULE module_bl_mynn ! Constants for cloud PDF (mym_condensation) REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 -! 'parameters' for Poisson distribution (StEM EDMF scheme) +! 'parameters' for Poisson distribution (EDMF scheme) REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0 !Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) @@ -931,10 +955,10 @@ SUBROUTINE mym_length ( & cns = 3.5 alp1 = 0.23 - alp2 = 0.6 !0.3 - alp3 = 4.0 + alp2 = 0.6 !0.3 + alp3 = 2.0 alp4 = 10. - alp5 = 0.6 !0.4 !like alp2, but for free atmosphere + alp5 = 0.6 !0.3 !like alp2, but for free atmosphere alp6 = 10.0 !used for MF mixing length instead of BouLac (x times MF) ! Impose limits on the height integration for elt and the transition layer depth @@ -1763,20 +1787,21 @@ SUBROUTINE mym_turbulence ( & ! ! Add min background stability function (diffusivity) within model levels ! with active plumes and low cloud fractions. - cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN - !cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) - !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) ! for mass-flux columns sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - ! for clouds + ! for clouds sm(k) = MAX(sm(k), 0.03*MIN(cldavg,1.0) ) sh(k) = MAX(sh(k), 0.03*MIN(cldavg,1.0) ) + ENDIF ! elq = el(k)*qkw(k) @@ -2255,7 +2280,7 @@ SUBROUTINE mym_condensation (kts,kte, & & Sh, el, bl_mynn_cloudpdf,& & qc_bl1D, cldfra_bl1D, & & PBLH1,HFX1, & - & Vt, Vq, th, sgm, & + & Vt, Vq, th, sgm, rmo, & & spp_pbl,rstoch_col ) !------------------------------------------------------------------- @@ -2267,7 +2292,7 @@ SUBROUTINE mym_condensation (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: dx,PBLH1,HFX1 + REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo REAL, DIMENSION(kts:kte), INTENT(IN) :: dz REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, & &tsq, qsq, cov, th @@ -2285,7 +2310,7 @@ SUBROUTINE mym_condensation (kts,kte, & REAL :: erf !JOE: NEW VARIABLES FOR ALTERNATE SIGMA - REAL::dth,dtl,dqw,dzk + REAL::dth,dtl,dqw,dzk,els REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el !JOE: variables for BL clouds @@ -2464,9 +2489,12 @@ SUBROUTINE mym_condensation (kts,kte, & ! in CB02 zagl = zagl + dz(k) + !Use analog to surface layer length scale to make the cloud mixing length scale + !become less than z in stable conditions. + els = zagl/(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) - ls_min = MIN(MAX(zagl,25.),ls_min) ! Let this be the minimum possible length scale: + ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) ! 25 m < ls_min(=zagl) < 300 m lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: @@ -2620,6 +2648,7 @@ SUBROUTINE mym_condensation (kts,kte, & !ENDIF ! For purposes of the buoyancy flux in stratus, we will use Fng = 1 !Fng = 1. + Q1(k)=MAX(Q1(k),-5.0) IF (Q1(k) .GE. 1.0) THEN Fng = 1.0 ELSEIF (Q1(k) .GE. -1.7 .AND. Q1(k) < 1.0) THEN @@ -2630,7 +2659,7 @@ SUBROUTINE mym_condensation (kts,kte, & Fng = MIN(23.9 + EXP(-1.6*(Q1(k)+2.5)), 60.) ENDIF Fng = MIN(Fng, 20.) - + xl = xl_blend(t) bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from ! "b" in CB02 (i.e., b(k) above) by a factor @@ -2642,8 +2671,8 @@ SUBROUTINE mym_condensation (kts,kte, & alpha = 0.61*th(k) beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - vt(k) = qww - MIN(cld(k),0.75)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(cld(k),0.75)*beta*a(k)*Fng - tv0 + vt(k) = qww - MIN(cld(k),0.99)*beta*bb*Fng - 1. + vq(k) = alpha + MIN(cld(k),0.99)*beta*a(k)*Fng - tv0 ! vt and vq correspond to beta-theta and beta-q, respectively, ! in NN09, Eq. B8. They also correspond to the bracketed ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng @@ -3506,6 +3535,7 @@ SUBROUTINE mynn_mix_chem(kts,kte, & tsq,qsq,cov, & tcd,qcd, & dfm,dfh,dfq, & + s_aw, & s_awchem, & bl_mynn_cloudmix) @@ -3519,6 +3549,7 @@ SUBROUTINE mynn_mix_chem(kts,kte, & REAL, DIMENSION(kts:kte), INTENT(INOUT) :: thl,sqw,sqv,sqc,sqi REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix + REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem REAL, DIMENSION( ndvel ), INTENT(INOUT) :: vd1 @@ -3547,18 +3578,16 @@ SUBROUTINE mynn_mix_chem(kts,kte, & k=kts a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) - ! d(1)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) + b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(1)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) - dtz(k)*s_awchem(k+1,ic) DO k=kts+1,kte-1 - kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) + a(k)=-dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) ! d(kk)=chem1(k,ic) + qcd(k)*delt - d(kk)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) + d(k)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) ENDDO ! prescribed value at top @@ -3797,7 +3826,7 @@ SUBROUTINE mynn_bl_driver( & ! = 3; Level 3 ! grav_settling = 1 when gravitational settling accounted for ! grav_settling = 0 when gravitational settling NOT accounted for - + REAL, INTENT(in) :: delt !WRF ! REAL, INTENT(in) :: dx @@ -3955,9 +3984,9 @@ SUBROUTINE mynn_bl_driver( & ENDIF maxKHtopdown(its:ite,jts:jte)=0. - ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS - IF (initflag > 0) THEN - + ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS + IF (initflag > 0) THEN + if (.not.restart) THEN Sh3D(its:ite,kts:kte,jts:jte)=0. el_pbl(its:ite,kts:kte,jts:jte)=0. @@ -4342,7 +4371,7 @@ SUBROUTINE mynn_bl_driver( & &Sh,el,bl_mynn_cloudpdf, & &qc_bl1D,cldfra_bl1D, & &PBLH(i,j),HFX(i,j), & - &Vt, Vq, th1, sgm, & + &Vt, Vq, th1, sgm, rmol(i,j), & &spp_pbl, rstoch_col ) !ADD TKE source driven by cloud top cooling @@ -4436,8 +4465,8 @@ SUBROUTINE mynn_bl_driver( & ENDIF !end top-down check IF (bl_mynn_edmf == 1) THEN - !PRINT*,"Calling StEM Mass-Flux: i= ",i," j=",j - CALL StEM_mf( & + !PRINT*,"Calling DMP Mass-Flux: i= ",i," j=",j + CALL DMP_mf( & &kts,kte,delt,zw,dz1,p1, & &bl_mynn_edmf_mom, & &bl_mynn_edmf_tke, & @@ -4447,7 +4476,7 @@ SUBROUTINE mynn_bl_driver( & &qnc1,qni1,qnwfa1,qnifa1, & &ex1,Vt,Vq,sgm, & &ust(i,j),flt,flq,flqv,flqc, & - &PBLH(i,j),KPBL(i,j),DX(I,J), & + &PBLH(i,j),KPBL(i,j),DX(i,j), & &xland(i,j),th_sfc, & ! now outputs - tendencies ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & @@ -4473,30 +4502,6 @@ SUBROUTINE mynn_bl_driver( & & spp_pbl,rstoch_col & ) - ELSEIF (bl_mynn_edmf == 2) THEN - CALL temf_mf( & - &kts,kte,delt,zw,p1,ex1, & - &u1,v1,w1,th1,thl,thetav, & - &sqw,sqv,sqc,qke1, & - &ust(i,j),flt,flq,flqv,flqc, & - &hfx(i,j),qfx(i,j),ts(i,j), & - &pblh(i,j),rho1,dfh,dx(i,j),znt(i,j),ep_2, & - ! outputs - updraft properties - & edmf_a1,edmf_w1,edmf_qt1, & - & edmf_thl1,edmf_ent1,edmf_qc1, & - ! for the solver - & s_aw1,s_awthl1,s_awqt1, & - & s_awqv1,s_awqc1, & - & s_awu1,s_awv1,s_awqke1, & -#if (WRF_CHEM == 1) - & nchem,chem1,s_awchem1, & -#endif - & qc_bl1D,cldfra_bl1D & - &,FLAG_QI,FLAG_QC & - &,Psig_shcu(i,j) & - &,spp_pbl,rstoch_col & - &,i,j,ids,ide,jds,jde & - ) ENDIF CALL mym_turbulence ( & @@ -4527,7 +4532,7 @@ SUBROUTINE mynn_bl_driver( & DO k=kts,kte-1 ! Set max dissipative heating rate close to 0.1 K per hour (=0.000027...) - diss_heat(k) = MIN(MAX(0.5*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.000025) + diss_heat(k) = MIN(MAX(0.5*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.00002) ENDDO diss_heat(kte) = 0. @@ -4579,22 +4584,12 @@ SUBROUTINE mynn_bl_driver( & tcd, qcd, & &dfm, dfh, dfq, & ! mass flux components + & s_aw1, & & s_awchem1, & &bl_mynn_cloudmix) ENDIF #endif -! -! add mass flux tendencies and calculate the new variables. -! Now done implicitly in the mynn_tendencies subroutine -! do k=kts,kte -! du1(k)=du1(k)+du1mf(k) -! dv1(k)=dv1(k)+dv1mf(k) -! dth1(k)=dth1(k)+dth1mf(k) -! dqv1(k)=dqv1(k)+dqv1mf(k) -! that is supposed to be done by bl_fogdes -! dqc1(k)=dqc1(k)+dqc1mf(k) -! enddo CALL retrieve_exchange_coeffs(kts,kte,& &dfm, dfh, dz1, K_m1, K_h1) @@ -4694,7 +4689,7 @@ SUBROUTINE mynn_bl_driver( & IF ( ABS(vq(k)) > 6000.)print*,& "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vq=",vq(k) IF ( exch_m(i,k,j) < 0. .OR. exch_m(i,k,j)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," exch_m=",exch_m(i,k,j) + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," exxch_m=",exch_m(i,k,j) IF ( vdfg(i,j) < 0. .OR. vdfg(i,j)>5. )print*,& "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vdfg=",vdfg(i,j) IF ( ABS(QFX(i,j))>.001)print*,& @@ -4953,6 +4948,8 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) END SUBROUTINE GET_PBLH ! ================================================================== +! Dynamic Multi-Plume (DMP) Mass-Flux Scheme +! ! Much thanks to Kay Suslj of NASA-JPL for contributing the original version ! of this mass-flux scheme. Considerable changes have been made from it's ! original form. Some additions include: @@ -4962,7 +4959,7 @@ END SUBROUTINE GET_PBLH ! 4) some extra limits for numerical stability ! This scheme remains under development, so consider it experimental code. ! - SUBROUTINE StEM_mf( & + SUBROUTINE DMP_mf( & & kts,kte,dt,zw,dz,p, & & momentum_opt, & & tke_opt, & @@ -5046,7 +5043,7 @@ SUBROUTINE StEM_mf( & !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the ! first model layer - REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & + REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & UPQNI,UPQNWFA,UPQNIFA ! entrainment variables @@ -5098,12 +5095,12 @@ SUBROUTINE StEM_mf( & ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,diffqt,& - Q1,Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid + REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,& + Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid ! Variables for plume interpolation/saturation check REAL,DIMENSION(KTS:KTE) :: exneri,dzi - REAL :: THLp, THp, QTp, QCp, rhplume, esat, qsl + REAL :: THp, QTp, QCp, esat, qsl ! WA TEST 11/9/15 for consistent reduction of updraft params REAL :: csigma,acfac,EntThrottle @@ -5257,15 +5254,16 @@ SUBROUTINE StEM_mf( & !wspd_pbl=SQRT(MAX(u(kpbl)**2 + v(kpbl)**2, 0.01)) maxwidth = 1.1*PBLH !- MIN(15.*MAX(wspd_pbl - 7.5, 0.), 0.3*PBLH) ! Criteria (3) +! maxwidth = MIN(maxwidth,0.5*cloud_base) maxwidth = MIN(maxwidth,0.75*cloud_base) ! Criteria (5) IF((landsea-1.5).LT.0)THEN IF (cloud_base .LT. 2000.) THEN !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.120)/0.03) + .5),1000.), 0.) - width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.100)/0.03) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.090)/0.03) + .5),1000.), 0.) ELSE - !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.) + !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) ENDIF maxwidth = MIN(maxwidth,width_flx) ENDIF @@ -5302,32 +5300,17 @@ SUBROUTINE StEM_mf( & ! acfac = .5*tanh((fltv - 0.05)/0.2) + .5 ! acfac = .5*tanh((fltv - 0.07)/0.09) + .5 ! acfac = .5*tanh((fltv - 0.03)/0.09) + .5 - acfac = .5*tanh((fltv - 0.015)/0.05) + .5 + acfac = .5*tanh((fltv - 0.02)/0.09) + .5 +! acfac = .5*tanh((fltv - 0.015)/0.05) + .5 UPA(1,I)=UPA(1,I)*acfac An2 = An2 + UPA(1,I) ! total fractional area of all plumes !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 end do - ! get entrainment coefficient - ! get dz/L0 - !ENTf(kts:kte,1:Nup)=0.1 - !ENTi(kts:kte,1:Nup)=0.1 - !ENT(kts:kte,1:Nup)=0.001 - !do i=1,Nup2 - ! do k=kts+1,kte - ! ENTf(k,i)=(ZW(k)-ZW(k-1))/L0 ! input into Poisson - ! ENTf(k,i)=MIN(ENTf(k,i),9.9) !JOE: test avoiding FPE - ! ENTf(k,i)=MAX(ENTf(k,i),0.05) !JOE: test avoiding FPE - ! enddo - !enddo - ! get Poisson P(dz/L0) - !call Poisson(1,Nup2,kts+1,kte,ENTf,ENTi) - ! entrainent: Ent=Ent0/dz*P(dz/L0) - ! set initial conditions for updrafts z0=50. pwmin=0.1 ! was 0.5 - pwmax=0.5 ! was 3.0 + pwmax=0.4 ! was 3.0 wstar=max(1.E-2,(g/thv(1)*fltv*pblh)**(1./3.)) qstar=max(flq,1.0E-5)/wstar @@ -5387,14 +5370,6 @@ SUBROUTINE StEM_mf( & ENDIF #endif -! !DEBUG -! IF (UPA(1,I)<0. .OR. UPA(1,I)>0.5 .OR. wstar<0. .OR. wstar>4.0 .OR. & -! ABS(thstar)> 5. .OR. sigmaW>1.5) THEN -! PRINT*,"IN Mass-Flux: UPA(1,i)=",UPA(1,i) -! PRINT*," wstar=",wstar," qstar=",qstar -! PRINT*," thstar=",thstar," sigmaW=",sigmaW -! ENDIF - ENDDO EntThrottle = 0.001 !MAX(0.02/MAX((flt*1.25*1004.)-25.,5.),0.0002) @@ -5461,9 +5436,9 @@ SUBROUTINE StEM_mf( & ! Compute plume properties thvn and qcn call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn) - ! Define THV at the model interface levels + ! Define environment THV at the model interface levels THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - THVkm1=(THV(k)*DZ(k-1)+THV(k-1)*DZ(k))/(DZ(k-1)+DZ(k)) + THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) ! B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0) B=g*(THVn/THVk - 1.0) @@ -5491,6 +5466,10 @@ SUBROUTINE StEM_mf( & IF(Wn > UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN Wn = UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ENDIF + !Add symmetrical max decrease in w + IF(Wn < UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN + Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) + ENDIF Wn = MIN(MAX(Wn,0.0), 3.0) IF (debug_mf == 1) THEN @@ -5509,7 +5488,7 @@ SUBROUTINE StEM_mf( & IF ( THVk-THVkm1 .GT. 0.0 ) THEN bvf = SQRT( gtr*(THVk-THVkm1)/dz(k) ) !vertical Froude number - Frz = UPW(K-1,I)/(bvf*0.5*dz(k)) + Frz = UPW(K-1,I)/(bvf*dz(k)) IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I) ENDIF ELSEIF (fltv > 0.05 .AND. overshoot == 1) THEN @@ -5524,9 +5503,9 @@ SUBROUTINE StEM_mf( & IF(ZW(k+1) >= MIN(pblh+3000.,4500.))Wn=0. !JOE- minimize the plume penetratration in stratocu-topped PBL - !IF (fltv < 0.06) THEN - ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. - !ENDIF + ! IF (fltv < 0.06) THEN + ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. + ! ENDIF IF (Wn > 0.) THEN UPW(K,I)=Wn !Wn !sqrt(Wn2) @@ -5632,11 +5611,7 @@ SUBROUTINE StEM_mf( & ! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt*dheat_opt ! So, s_awthl(kts+1) must be less than flt THVk = (THL(kts)*DZ(kts+1)+THL(kts+1)*DZ(kts))/(DZ(kts+1)+DZ(kts)) - if (s_aw(kts+1).ne.0) then flx1 = MAX(s_aw(kts+1)*(s_awthl(kts+1)/s_aw(kts+1) - THVk),0.0) - else - flx1 = 0.0 - end if !flx1 = -dt/dz(kts)*s_awthl(kts+1) !flx1 = (s_awthl(kts+1)-s_awthl(kts))!/(0.5*(dz(k)+dz(k-1))) adjustment=1.0 @@ -5710,8 +5685,8 @@ SUBROUTINE StEM_mf( & ENDDO !First, compute exner, plume theta, and dz centered at interface - !Here, k=1 is the top of the first model layer. These values do not - !need to be defined at k=kte (unused level). + !Here, k=1 is the top of the first model layer. These values do not + !need to be defined at k=kte (unused level). DO K=KTS,KTE-1 exneri(k) = (exner(k)*DZ(k+1)+exner(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K) @@ -5720,16 +5695,16 @@ SUBROUTINE StEM_mf( & !JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in ! mym_condensation. Here, a shallow-cu component is added, but no cumulus -! clouds can be added at k=1 (start loop at k=2). +! clouds can be added at k=1 (start loop at k=2). DO K=KTS+1,KTE-2 IF(k > KTOP) exit IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN + satvp = 3.80*exp(17.27*(th(k)-273.)/ & (th(k)-36.))/(.01*p(k)) rhgrid = max(.01,MIN( 1., qv(k) /satvp)) !then interpolate plume thl, th, and qt to mass levels - THLp= (edmf_thl(k)*dzi(k-1)+edmf_thl(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) !convert TH to T @@ -5738,8 +5713,8 @@ SUBROUTINE StEM_mf( & esat = esat_blend(t) !SATURATED SPECIFIC HUMIDITY qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - rhplume = max(.01,MIN( 1., QTp /qsl)) + !condensed liquid in the plume on mass levels IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN QCp = 0.5*(edmf_qc(k)+edmf_qc(k-1)) ELSE @@ -5748,27 +5723,27 @@ SUBROUTINE StEM_mf( & !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq - xl = xl_blend(t) ! obtain blended heat capacity - tlk = thlp*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + xl = xl_blend(tk(k)) ! obtain blended heat capacity + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio ! at tl and p rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl ! CB02, Eqn. 4 - cpm = cp + qtp*cpv ! CB02, sec. 2, para. 1 + cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" b9 = a*rsl ! CB02 variable "b" q2p = xlvcp/exner(k) - pt = THp !thlp +q2p*qcp ! potential temp - bb = b9*t/pt ! bb is "b9" in BCMT95. Their "b9" differs from + pt = thl(k) +q2p*QCp*0.5*(edmf_a(k)+edmf_a(k-1)) ! potential temp (env + plume) + bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from ! "b9" in CB02 by a factor ! of T/theta. Strictly, b9 above is formulated in ! terms of sat. mixing ratio, but bb in BCMT95 is ! cast in terms of sat. specific humidity. The ! conversion is neglected here. - qww = 1.+0.61*QTp + qww = 1.+0.61*qt(k) alpha = 0.61*pt - t = THp*exner(k) + t = TH(k)*exner(k) beta = pt*xl/(t*cp) - 1.61*pt !Buoyancy flux terms have been moved to the end of this section... @@ -5778,18 +5753,18 @@ SUBROUTINE StEM_mf( & else f = 1.0 endif - sigq = 6.E-3 * 0.5*(edmf_a(k)+edmf_a(k+1)) * & - & 0.5*(edmf_w(k)+edmf_w(k+1)) * f ! convective component of sigma (CB2005) - !sigq = MAX(sigq, 1.0E-4) + sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & + & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + !sigq = MAX(sigq, 1.0E-4) sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components - qmq = a * (QTp - qsat_tl) ! saturation deficit/excess; + qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; ! the numerator of Q1 mf_cf = min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) IF ( debug_code ) THEN print*,"In MYNN, StEM edmf" - print*," CB: env qt=",qt(k)," plume qt=",QTp - print*," qsat=",qsat_tl," satdef=",QTp - qsat_tl + print*," CB: env qt=",qt(k)," qsat=",qsat_tl + print*," satdef=",QTp - qsat_tl print*," CB: sigq=",sigq," qmq=",qmq," tlk=",tlk print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) ENDIF @@ -5797,17 +5772,13 @@ SUBROUTINE StEM_mf( & IF (cldfra_bl1d(k) < 0.5) THEN IF (mf_cf > 0.5*(edmf_a(k)+edmf_a(k-1))) THEN cldfra_bl1d(k) = mf_cf - !qc_bl1d(k) = edmf_qc(k)*edmf_a(k)/mf_cf - !qc_bl1d(k) = 0.5*(edmf_qc(k)+edmf_qc(k+1))* & - ! & 0.5*(edmf_a(k)+edmf_a(k+1))/mf_cf - qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf + qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf ELSE - !cldfra_bl1d(k)=edmf_a(k) - !qc_bl1d(k) = edmf_qc(k) cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) - qc_bl1d(k) = QCp !0.5*(edmf_qc(k)+edmf_qc(k+1)) + qc_bl1d(k) = QCp ENDIF ENDIF + !Now recalculate the terms for the buoyancy flux for mass-flux clouds: !See mym_condensation for details on these formulations. The !cloud-fraction bounding was added to improve cloud retention, @@ -5815,6 +5786,7 @@ SUBROUTINE StEM_mf( & !Fng = 2.05 ! the non-Gaussian transport factor (assumed constant) !Use Bechtold and Siebesma (1998) piecewise estimation of Fng: Q1 = qmq/MAX(sigq,1E-10) + Q1=MAX(Q1,-5.0) IF (Q1 .GE. 1.0) THEN Fng = 1.0 ELSEIF (Q1 .GE. -1.7 .AND. Q1 < 1.0) THEN @@ -5824,8 +5796,9 @@ SUBROUTINE StEM_mf( & ELSE Fng = MIN(23.9 + EXP(-1.6*(Q1+2.5)), 60.) ENDIF - vt(k) = qww - MIN(0.25,cldfra_bl1D(k))*beta*bb*Fng - 1. - vq(k) = alpha + MIN(0.25,cldfra_bl1D(k))*beta*a*Fng - tv0 + + vt(k) = qww - MIN(0.4,cldfra_bl1D(k))*beta*bb*Fng - 1. + vq(k) = alpha + MIN(0.4,cldfra_bl1D(k))*beta*a*Fng - tv0 ENDIF ENDDO @@ -5880,421 +5853,14 @@ SUBROUTINE StEM_mf( & ENDIF !END Debugging -! initialization of deltas -! DO k=kts,kte -! dth(k)=0. -! dqv(k)=0. -! dqc(k)=0. -! du(k)=0. -! dv(k)=0. -! ENDDO #ifdef HARDCODE_VERTICAL # undef kts # undef kte #endif -END SUBROUTINE StEM_MF +END SUBROUTINE DMP_MF !================================================================= -subroutine Poisson(istart,iend,jstart,jend,mu,POI) - - integer, intent(in) :: istart,iend,jstart,jend - real,dimension(istart:iend,jstart:jend),intent(in) :: MU - integer, dimension(istart:iend,jstart:jend), intent(out) :: POI - integer :: i,j - ! - ! do this only once - ! call init_random_seed - - do i=istart,iend - do j=jstart,jend - call random_Poisson(mu(i,j),.true.,POI(i,j)) - enddo - enddo - -end subroutine Poisson -!================================================================= -subroutine init_random_seed() - !JOE: PGI had problem! use iso_fortran_env, only: int64 - !JOE: PGI had problem! use ifport, only: getpid - implicit none - integer, allocatable :: seed(:) - integer :: i, n, un, istat, dt(8), pid - !JOE: PGI had problem! integer(int64) :: t - integer :: t - - call random_seed(size = n) - allocate(seed(n)) - - ! First try if the OS provides a random number generator - !JOE: PGI had problem! open(newunit=un, file="/dev/urandom", access="stream", & - un=191 - open(unit=un, file="/dev/urandom", access="stream", & - form="unformatted", action="read", status="old", iostat=istat) - - if (istat == 0) then - read(un) seed - close(un) - else - ! Fallback to XOR:ing the current time and pid. The PID is - ! useful in case one launches multiple instances of the same - ! program in parallel. - call system_clock(t) - if (t == 0) then - call date_and_time(values=dt) - !t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 * 1000 & - ! + dt(2) * 31_int64 * 24 * 60 * 60 * 1000 & - ! + dt(3) * 24_int64 * 60 * 60 * 1000 & - ! + dt(5) * 60 * 60 * 1000 & - ! + dt(6) * 60 * 1000 + dt(7) * 1000 & - ! + dt(8) - t = dt(6) * 60 & ! only return seconds for smaller t - + dt(7) - end if - - !JOE: PGI had problem!pid = getpid() - ! for distributed memory jobs we need to fix this - !pid=1 - pid = 666 + MOD(t,10) !JOE: doesnt work for PG compilers: getpid() - - t = ieor(t, int(pid, kind(t))) - do i = 1, n - seed(i) = lcg(t) - end do - end if - call random_seed(put=seed) - - contains - - ! Pseudo-random number generator (PRNG) - ! This simple PRNG might not be good enough for real work, but is - ! sufficient for seeding a better PRNG. - function lcg(s) - - integer :: lcg - !JOE: PGI had problem! integer(int64) :: s - integer :: s - - if (s == 0) then - !s = 104729 - s = 1047 - else - !s = mod(s, 4294967296_int64) - s = mod(s, 71) - end if - !s = mod(s * 279470273_int64, 4294967291_int64) - s = mod(s * 23, 17) - !lcg = int(mod(s, int(huge(0), int64)), kind(0)) - lcg = int(mod(s, int(s/3.5))) - - end function lcg - - end subroutine init_random_seed - - -subroutine random_Poisson(mu,first,ival) -!********************************************************************** -! Translated to Fortran 90 by Alan Miller from: RANLIB -! -! Library of Fortran Routines for Random Number Generation -! -! Compiled and Written by: -! -! Barry W. Brown -! James Lovato -! -! Department of Biomathematics, Box 237 -! The University of Texas, M.D. Anderson Cancer Center -! 1515 Holcombe Boulevard -! Houston, TX 77030 -! -! Generates a single random deviate from a Poisson distribution with mean mu. -! Scalar Arguments: - REAL, INTENT(IN) :: mu !The mean of the Poisson distribution from which - !a random deviate is to be generated. - LOGICAL, INTENT(IN) :: first - INTEGER :: ival - -! TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT -! COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL -! SEPARATION OF CASES A AND B -! -! .. Local Scalars .. -!JOE: since many of these scalars conflict with globally declared closure constants (above), -! need to change XX to XX_s -! REAL :: b1, b2, c, c0, c1, c2, c3, del, difmuk, e, fk, fx, fy, g, & -! omega, px, py, t, u, v, x, xx - REAL :: b1_s, b2_s, c, c0, c1_s, c2_s, c3_s, del, difmuk, e, fk, fx, fy, g_s, & - omega, px, py, t, u, v, x, xx - REAL, SAVE :: s, d, p, q, p0 - INTEGER :: j, k, kflag - LOGICAL, SAVE :: full_init - INTEGER, SAVE :: l, m -! .. -! .. Local Arrays .. - REAL, SAVE :: pp(35) -! .. -! .. Data statements .. -!JOE: since many of these scalars conflict with globally declared closure constants (above), -! need to change XX to XX_s -! REAL, PARAMETER :: a0 = -.5, a1 = .3333333, a2 = -.2500068, a3 = .2000118, & - REAL, PARAMETER :: a0 = -.5, a1_s = .3333333, a2_s = -.2500068, a3 = .2000118, & - a4 = -.1661269, a5 = .1421878, a6 = -0.1384794, & - a7 = .1250060 - - REAL, PARAMETER :: fact(10) = (/ 1., 1., 2., 6., 24., 120., 720., 5040., & - 40320., 362880. /) - -!JOE: difmuk,fk,u errors - undefined - difmuk = 0. - fk = 1.0 - u = 0. - -! .. -! .. Executable Statements .. - IF (mu > 10.0) THEN -! C A S E A. (RECALCULATION OF S, D, L IF MU HAS CHANGED) - - IF (first) THEN - s = SQRT(mu) - d = 6.0*mu*mu - -! THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL -! PROBABILITIES FK WHENEVER K >= M(MU). L=IFIX(MU-1.1484) -! IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 . - - l = mu - 1.1484 - full_init = .false. - END IF - -! STEP N. NORMAL SAMPLE - random_normal() FOR STANDARD NORMAL DEVIATE - g_s = mu + s*random_normal() - IF (g_s > 0.0) THEN - ival = g_s - - ! STEP I. IMMEDIATE ACCEPTANCE IF ival IS LARGE ENOUGH - IF (ival>=l) RETURN - - ! STEP S. SQUEEZE ACCEPTANCE - SAMPLE U - fk = ival - difmuk = mu - fk - CALL RANDOM_NUMBER(u) - IF (d*u >= difmuk*difmuk*difmuk) RETURN - END IF - - ! STEP P. PREPARATIONS FOR STEPS Q AND H. - ! (RECALCULATIONS OF PARAMETERS IF NECESSARY) - ! .3989423=(2*PI)**(-.5) .416667E-1=1./24. .1428571=1./7. - ! THE QUANTITIES B1_S, B2_S, C3_S, C2_S, C1_S, C0 ARE FOR THE HERMITE - ! APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK. - ! C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION. - - IF (.NOT. full_init) THEN - omega = .3989423/s - b1_s = .4166667E-1/mu - b2_s = .3*b1_s*b1_s - c3_s = .1428571*b1_s*b2_s - c2_s = b2_s - 15.*c3_s - c1_s = b1_s - 6.*b2_s + 45.*c3_s - c0 = 1. - b1_s + 3.*b2_s - 15.*c3_s - c = .1069/mu - full_init = .true. - END IF - - IF (g_s < 0.0) GO TO 50 - - ! 'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN) - - kflag = 0 - GO TO 70 - - ! STEP Q. QUOTIENT ACCEPTANCE (RARE CASE) - - 40 IF (fy-u*fy <= py*EXP(px-fx)) RETURN - - ! STEP E. EXPONENTIAL SAMPLE - random_exponential() FOR STANDARD EXPONENTIAL - ! DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT' - ! (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.) - - 50 e = random_exponential() - CALL RANDOM_NUMBER(u) - u = u + u - one - t = 1.8 + SIGN(e, u) - IF (t <= (-.6744)) GO TO 50 - ival = mu + s*t - fk = ival - difmuk = mu - fk - - ! 'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN) - - kflag = 1 - GO TO 70 - - ! STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION) - - 60 IF (c*ABS(u) > py*EXP(px+e) - fy*EXP(fx+e)) GO TO 50 - RETURN - - ! STEP F. 'SUBROUTINE' F. CALCULATION OF PX, PY, FX, FY. - ! CASE ival < 10 USES FACTORIALS FROM TABLE FACT - - 70 IF (ival>=10) GO TO 80 - px = -mu -!JOE: had error " Subscript #1 of FACT has value -858993459"; shouldn't be < 1. - !py = mu**ival/fact(ival+1) - py = mu**ival/fact(MAX(ival+1,1)) - GO TO 110 - - ! CASE ival >= 10 USES POLYNOMIAL APPROXIMATION - ! A0-A7 FOR ACCURACY WHEN ADVISABLE - ! .8333333E-1=1./12. .3989423=(2*PI)**(-.5) - - 80 del = .8333333E-1/fk - del = del - 4.8*del*del*del - v = difmuk/fk - IF (ABS(v)>0.25) THEN - px = fk*LOG(one + v) - difmuk - del - ELSE - px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2_s)*v+a1_s)*v+a0) - del - END IF - py = .3989423/SQRT(fk) - 110 x = (half - difmuk)/s - xx = x*x - fx = -half*xx - fy = omega* (((c3_s*xx + c2_s)*xx + c1_s)*xx + c0) - IF (kflag <= 0) GO TO 40 - GO TO 60 - - !--------------------------------------------------------------------------- - ! C A S E B. mu < 10 - ! START NEW TABLE AND CALCULATE P0 IF NECESSARY - ELSE - - IF (first) THEN - m = MAX(1, INT(mu)) - l = 0 - !print*,"mu=",mu - !print*," mu=",mu," p=",EXP(-mu) - p = EXP(-mu) - q = p - p0 = p - END IF - - ! STEP U. UNIFORM SAMPLE FOR INVERSION METHOD - - DO - CALL RANDOM_NUMBER(u) - ival = 0 - IF (u <= p0) RETURN - - ! STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE - ! PP-TABLE OF CUMULATIVE POISSON PROBABILITIES - ! (0.458=PP(9) FOR MU=10) - - IF (l == 0) GO TO 150 - j = 1 - IF (u > 0.458) j = MIN(l, m) - DO k = j, l - IF (u <= pp(k)) GO TO 180 - END DO - IF (l == 35) CYCLE - - ! STEP C. CREATION OF NEW POISSON PROBABILITIES P - ! AND THEIR CUMULATIVES Q=PP(K) - - 150 l = l + 1 - DO k = l, 35 - p = p*mu / k - q = q + p - pp(k) = q - IF (u <= q) GO TO 170 - END DO - l = 35 - END DO - - 170 l = k - 180 ival = k - RETURN - END IF - - RETURN - END subroutine random_Poisson - -!================================================================== - - FUNCTION random_normal() RESULT(fn_val) - - ! Adapted from the following Fortran 77 code - ! ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM. - ! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, - ! VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435. - - ! The function random_normal() returns a normally distributed pseudo-random - ! number with zero mean and unit variance. - - ! The algorithm uses the ratio of uniforms method of A.J. Kinderman - ! and J.F. Monahan augmented with quadratic bounding curves. - - REAL :: fn_val - - ! Local variables - REAL :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472, & - r1 = 0.27597, r2 = 0.27846, u, v, x, y, q - - ! Generate P = (u,v) uniform in rectangle enclosing acceptance region - - DO - CALL RANDOM_NUMBER(u) - CALL RANDOM_NUMBER(v) - v = 1.7156 * (v - half) - - ! Evaluate the quadratic form - x = u - s - y = ABS(v) - t - q = x**2 + y*(a*y - b*x) - - ! Accept P if inside inner ellipse - IF (q < r1) EXIT - ! Reject P if outside outer ellipse - IF (q > r2) CYCLE - ! Reject P if outside acceptance region - IF (v**2 < -4.0*LOG(u)*u**2) EXIT - END DO - - ! Return ratio of P coordinates as the normal deviate - fn_val = v/u - RETURN - - END FUNCTION random_normal - -!=============================================================== - - FUNCTION random_exponential() RESULT(fn_val) - - ! Adapted from Fortran 77 code from the book: - ! Dagpunar, J. 'Principles of random variate generation' - ! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - - ! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM - ! A NEGATIVE EXPONENTIAL DlSTRIBUTION WlTH DENSITY PROPORTIONAL - ! TO EXP(-random_exponential), USING INVERSION. - - REAL :: fn_val - - ! Local variable - REAL :: r - - DO - CALL RANDOM_NUMBER(r) - IF (r > zero) EXIT - END DO - - fn_val = -LOG(r) - RETURN - - END FUNCTION random_exponential - -!=============================================================== subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! @@ -6314,10 +5880,9 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! cp ! rvord .. rv/rd (1.6) - ! number of iterations niter=50 -! minimum difference +! minimum difference (usually converges in < 8 iterations with diff = 2e-5) diff=2.e-5 EXN=(P/p1000mb)**rcp @@ -6339,6 +5904,13 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) !THV=(THL+xlv/cp*QC).*(1+(1-rvovrd)*(QT-QC)-QC); THV=(THL+xlv/cp*QC)*(1.+QT*(rvovrd-1.)-rvovrd*QC) + +! IF (QC > 0.0) THEN +! PRINT*,"EDMF SAT, p:",p," iterations:",i +! PRINT*," T=",T," THL=",THL," THV=",THV +! PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs +! ENDIF + !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE !TH = THL + xlv/cp/EXN*QC !THV= TH*(1. + 0.608*QT) @@ -6523,828 +6095,6 @@ END FUNCTION xl_blend ! =================================================================== ! =================================================================== -! This is the mass flux part of the TEMF scheme from module_bl_temf.F, -! adapted for the MYNN context by Wayne Angevine June 2015. -! Variable strategy: TEMF external variables that have semantically -! comfortable counterparts in the MYNN-EDMF context have been changed to -! use those names. Otherwise the TEMF variable names have been kept but -! redefined as local variables. Only "moist" vars are used, whether -! updraft condenses or not. Some former local vars are replaced with -! externals. -! -! (Partial) list of conversions: -! wupd_temfx -> moist_w -! thup_temfx -> moist_thl -! qtup_temfx -> moist_qt -! qlup_temfx -> moist_qc -! cf3d_temfx -> cldfra_bl1d -! au -> moist_a - - SUBROUTINE temf_mf( & - & kts,kte,dt,zw,p,pi1d, & - & u,v,w,th,thl,thv,qt,qv,qc,& - & qke,ust,flt,flq,flqv,flqc,& - & hfx,qfx,tsk, & - & pblh,rho,dfh,dx,znt,ep_2, & - ! outputs - updraft properties - & edmf_a,edmf_w,edmf_qt, & - & edmf_thl,edmf_ent,edmf_qc,& - ! outputs - variables needed for solver - & s_aw,s_awthl,s_awqt, & - & s_awqv,s_awqc, & - & s_awu,s_awv,s_awqke, & -#if (WRF_CHEM == 1) - & nchem,chem,s_awchem, & -#endif - ! in/outputs - subgrid scale clouds - & qc_bl1d,cldfra_bl1d, & - ! inputs - flags for moist arrays - &F_QC,F_QI,psig, & - &spp_pbl,rstoch_col, & - &ii,jj,ids,ide,jds,jde) - - - ! inputs: - INTEGER, INTENT(IN) :: kts,kte,ii,jj,ids,ide,jds,jde - REAL,DIMENSION(kts:kte), INTENT(IN) :: u,v,w,th,thl,qt,qv,qc,thv,p,pi1d - REAL,DIMENSION(kts:kte), INTENT(IN) :: qke - REAL,DIMENSION(kts:kte+1), INTENT(IN) :: zw !height at full-sigma - REAL,DIMENSION(kts:kte), INTENT(IN) :: rho !density - REAL,DIMENSION(kts:kte), INTENT(IN) :: dfh !diffusivity for heat - REAL, INTENT(IN) :: dt,ust,flt,flq,flqv,flqc,hfx,qfx,tsk,pblh,dx,znt,ep_2,psig - LOGICAL, OPTIONAL :: f_qc,f_qi - - ! outputs - updraft properties - REAL,DIMENSION(kts:kte), INTENT(OUT) :: & - & edmf_a,edmf_w,edmf_qt, & - & edmf_thl,edmf_ent,edmf_qc - - ! outputs - variables needed for solver - REAL,DIMENSION(kts:kte+1) :: s_aw, & !sum ai*wis_awphi - s_awthl, & !sum ai*wi*phii - s_awqt, & - s_awqv, & - s_awqc, & - s_awu, & - s_awv, & - s_awqke -#if (WRF_CHEM == 1) - INTEGER, INTENT(IN) :: nchem - REAL,DIMENSION(kts:kte+1, nchem) :: chem - REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem - INTEGER :: ic -#endif - - REAL,DIMENSION(kts:kte), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d - -! Local variables -! -! EDMF constants - real, parameter :: CM = 0.03 ! Proportionality constant for subcloud MF - real, parameter :: Cdelt = 0.006 ! Prefactor for detrainment rate - real, parameter :: Cw = 0.5 ! Prefactor for surface wUPD - real, parameter :: Cc = 3.0 ! Prefactor for convective length scale - real, parameter :: lasymp = 200.0 ! Asymptotic length scale WA 11/20/09 - real, parameter :: hmax = 4000.0 ! Max hd,hct WA 11/20/09 - integer, parameter :: Nupd = 8 ! Number of updrafts -! - integer :: i, k, kt, nu ! Loop variable - integer:: h0idx - real:: h0 - real:: wstr, ang, wm - real, dimension( Nupd) :: hd,lcl,hct,ht - real:: convection_TKE_surface_src, sfcFTE - real:: sfcTHVF - real:: z0t - integer, dimension( Nupd) :: hdidx,lclidx,hctidx,htidx - integer:: hmax_idx - integer:: tval - real, dimension( kts:kte) :: zm, zt, dzm, dzt - real, dimension( kts:kte) :: thetal, qtot - real, dimension( kts:kte) :: u_temf, v_temf - real, dimension( kts:kte) :: rv, rl, rt - real, dimension( kts:kte) :: chi_poisson, gam - real, dimension( kts:kte) :: dthdz - real, dimension( kts:kte) :: lepsmin - real, dimension( kts:kte) :: thetav - real, dimension( kts:kte) :: dmoist_qtdz - real, dimension( kts:kte) :: B, Bmoist - real, dimension( kts:kte, Nupd) :: epsmf, deltmf, dMdz - real, dimension( kts:kte, Nupd) :: UUPD, VUPD - real, dimension( kts:kte, Nupd) :: thetavUPD, qlUPD, TEUPD - real, dimension( kts:kte, Nupd) :: thetavUPDmoist, wUPD_dry - real, dimension( kts:kte, Nupd) :: dthUPDdz, dwUPDdz - real, dimension( kts:kte, Nupd) :: dwUPDmoistdz - real, dimension( kts:kte, Nupd) :: dUUPDdz, dVUPDdz, dTEUPDdz - real, dimension( kts:kte, Nupd) :: TUPD, rstUPD, rUPD, rlUPD, qstUPD - real, dimension( kts:kte, Nupd) :: MUPD, wUPD, qtUPD, thlUPD, qcUPD - real, dimension( kts:kte, Nupd) :: aUPD, cldfraUPD, aUPDt - real, dimension( kts:kte) :: N2, S, Ri, beta, ftau, fth, ratio - real, dimension( kts:kte) :: TKE, TE2 - real, dimension( kts:kte) :: ustrtilde, linv, leps - real, dimension( kts:kte) :: km, kh - real, dimension( kts:kte) :: Fz, QFK, uwk, vwk - real, dimension( kts:kte) :: km_conv, kh_conv, lconv - real, dimension( kts:kte) :: alpha2, beta2 ! For thetav flux calculation - real, dimension( kts:kte) :: THVF, buoy_src, srcs - real, dimension( kts:kte) :: beta1 ! For saturation humidity calculations - real, dimension( kts:kte) :: MFCth - real Cepsmf ! Prefactor for entrainment rate - real red_fact ! for reducing MF components - real, dimension( kts:kte) :: edmf_u, edmf_v, edmf_qke ! Same format as registry vars, but not passed out - integer:: bdy_dist,taper_dist - real:: taper - - ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(kts:kte), INTENT(in) :: rstoch_col - -#if (WRF_CHEM == 1) - real,dimension( kts:kte+1, nchem, Nupd) :: chemUPD, dchemUPDdz - real,dimension( kts:kte+1, nchem) :: edmf_chem -#endif - - ! Used to be TEMF external variables, now local - real, dimension( kts:kte, Nupd) :: & - shf_temfx, qf_temfx, uw_temfx, vw_temfx , & - mf_temfx - real, dimension( Nupd) :: hd_temfx, lcl_temfx, hct_temfx, cfm_temfx - logical is_convective - ! Vars for cloud fraction calculation - real, dimension( kts:kte) :: sigq, qst, satdef - real :: sigq2, rst, cldfra_sum, psig_w, maxw - -!---------------------------------------------------------------------- -! Grid staggering: Matlab version has mass and turbulence levels. -! WRF has full levels (with w) and half levels (u,v,theta,q*). Both -! sets of levels use the same indices (kts:kte). See pbl_driver or -! WRF Physics doc for (a few) details. -! So *mass levels correspond to half levels.* -! WRF full levels are ignored, we define our own turbulence levels -! in order to put the first one below the first half level. -! Another difference is that -! the Matlab version (and the Mauritsen et al. paper) consider the -! first mass level to be at z0 (effectively the surface). WRF considers -! the first half level to be above the effective surface. The first half -! level, at k=1, has nonzero values of u,v for example. Here we convert -! all incoming variables to internal ones with the correct indexing -! in order to make the code consistent with the Matlab version. We -! already had to do this for thetal and qt anyway, so the only additional -! overhead is for u and v. -! I use suffixes m for mass and t for turbulence as in Matlab for things -! like indices. -! Note that zsrf is the terrain height ASL, from Registry variable ht. -! Translations (Matlab to WRF): -! dzt -> calculated below -! dzm -> not supplied, calculated below -! k -> karman -! z0 -> znt -! z0t -> not in WRF, calculated below -! zt -> calculated below -! zm -> zw but NOTE zm(1) is now z0 (znt) and zm(2) is zw(1) -! -! Other notes: -! - I have often used 1 instead of kts below, because the scheme demands -! to know where the surface is. It won't work if kts .NE. 1. - - IF ( debug_code ) THEN - print*,' MYNN; in TEMF_MF, beginning' - ENDIF - - !JOE-initialize s_aw* variables - s_aw = 0. - s_awthl= 0. - s_awqt = 0. - s_awqv = 0. - s_awqc = 0. - s_awu = 0. - s_awv = 0. - s_awqke= 0. - edmf_a = 0. - edmf_w = 0. - edmf_qt= 0. !qt - edmf_thl=0. !thl - edmf_ent=0. - edmf_qc= 0. !qc - edmf_u=0. - edmf_v=0. - edmf_qke=0. - - z0t = znt - - do k = kts,kte - rv(k) = qv(k) / (1.-qv(k)) ! Water vapor - rl(k) = qc(k) / (1.-qc(k)) ! Liquid water - rt(k) = qt(k) ! Total water (without ice) - thetal(k) = thl(k) - qtot(k) = qt(k) - thetav(k) = thv(k) - end do - - do k = kts,kte - u_temf(k) = u(k) - v_temf(k) = v(k) - end do - - !taper off MF scheme when significant resolved-scale motions are present - !This function needs to be asymetric... - k = 1 - maxw = 0.0 - DO WHILE (ZW(k) < pblh + 500.) - maxw = MAX(maxw,ABS(W(k))) - k = k+1 - ENDDO - maxw = MAX(0.,maxw - 0.5) ! do nothing for small w, but - Psig_w = MAX(0.0, 1.0 - maxw/0.5) ! linearly taper off for w > 0.5 m/s - Psig_w = MIN(Psig_w, Psig) - !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu - - ! Get delta height at half (mass) levels - zm(1) = znt - dzt(1) = zw(2) - zm(1) - ! Get height and delta at turbulence levels - zt(1) = (zw(2) - znt) / 2. - do kt = kts+1,kte - zm(kt) = zw(kt) ! Convert indexing from WRF to TEMF - zt(kt) = (zm(kt) + zw(kt+1)) / 2. - dzm(kt) = zt(kt) - zt(kt-1) - dzt(kt) = zw(kt+1) - zw(kt) - end do - dzm(1) = dzm(2) - - !print *,"In TEMF_MF zw = ", zw - !print *,"zm = ", zm - !print *,"zt = ", zt - !print *,"dzm = ", dzm - !print *,"dzt = ", dzt - - ! Gradients at first level - dthdz(1) = (thetal(2)-thetal(1)) / (zt(1) * log10(zm(2)/z0t)) - - !print *,"In TEMF_MF dthdz(1),thetal(2,1),tsk,zt(1),zm(2),z0t = ", & - ! dthdz(1),thetal(2),thetal(1),tsk,zt(1),zm(2),z0t - - ! Surface thetaV flux from Stull p.147 - sfcTHVF = hfx/(rho(1)*cp) * (1.+0.608*(qv(1)+qc(1))) + 0.608*thetav(1)*qfx - - ! WA use hd_temf to calculate w* instead of finding h0 here???? - ! Watch initialization! - h0idx = 1 - h0 = zm(1) - - lepsmin(kts) = 0. - - ! WA 2/11/13 find index just above hmax for use below - hmax_idx = kte-1 - - do k = kts+1,kte-1 - lepsmin(k) = 0. - - ! Mean gradients - dthdz(k) = (thetal(k+1) - thetal(k)) / dzt(k) - - ! Find h0 (should eventually be interpolated for smoothness) - if (thetav(k) > thetav(1) .AND. h0idx .EQ. 1) then - ! WA 9/28/11 limit h0 as for hd and hct - if (zm(k) < hmax) then - h0idx = k - h0 = zm(k) - else - h0idx = k - h0 = hmax - end if - end if - ! WA 2/11/13 find index just above hmax for use below - if (zm(k) > hmax) then - hmax_idx = min(hmax_idx,k) - end if - end do - - ! Gradients at top level - - dthdz(kte) = dthdz(kte-1) - - if ( hfx > 0.) then - wstr = (g * h0 / thetav(2) * hfx/(rho(1)*cp) ) ** (1./3.) - bdy_dist = min( min((ii-ids),(ide-ii)) , min((jj-jds),(jde-jj)) ) - taper_dist = 5 - ! JSK - linearly taper w-star near lateral boundaries (within 5 grid columns) - if (bdy_dist .LE. taper_dist) then - taper = max(0., min( 1., real(bdy_dist) / real(taper_dist) ) ) - wstr = wstr * taper - end if - else - wstr = 0. - end if - - !print *,"In TEMF_MF wstr,hfx,dthdz(1:2),h0 = ", wstr,hfx,dthdz(1),dthdz(2),h0 - IF ( debug_code ) THEN - print*,' MYNN; in TEMF_MF: wstr,hfx,dtdz1,dtdz2,h0:', wstr,hfx,dthdz(1),dthdz(2),h0 - ENDIF - - ! Set flag convective or not for use below - is_convective = wstr > 0. .AND. dthdz(1)<0. .AND. dthdz(2)<0. - ! WA 12/16/09 require two levels of negative (unstable) gradient - - !*** Mass flux block starts here *** - ! WA WFIP 11/13/15 allow multiple updrafts, deterministic for now - - if ( is_convective) then - - IF ( debug_code ) THEN - print *,"In TEMF_MF is_convective, wstr = ", wstr - ENDIF - - !Cepsmf = 2. / max(200.,h0) - Cepsmf = 1.0 / max(200.,h0) ! WA TEST reduce entrainment - ! Cepsmf = max(Cepsmf,0.002) - ! Cepsmf = max(Cepsmf,0.0015) ! WA TEST reduce max entrainment - ! Cepsmf = max(Cepsmf,0.0005) ! WA TEST reduce min entrainment - Cepsmf = max(Cepsmf,0.0010) ! WA TEST reduce min entrainment - - do nu = 1,Nupd - do k = kts,kte - ! Calculate lateral entrainment fraction for subcloud layer - ! epsilon and delta are defined on mass grid (half levels) - ! epsmf(k,nu) = Cepsmf * (1+0.2*(floor(nu - Nupd/2.))) ! WA for three updrafts - ! epsmf(k,nu) = Cepsmf * (1+0.05*(floor(nu - Nupd/2.))) ! WA for ten updrafts - ! epsmf(k,nu) = Cepsmf * (1+0.0625*(floor(nu - Nupd/2.))) ! WA for eight updrafts - ! epsmf(k,nu) = Cepsmf * (1+0.03*(floor(nu - Nupd/2.))) ! WA for eight updrafts, less spread - epsmf(k,nu) = Cepsmf * (1+0.25*(nu-1)) ! WA for eight updrafts, much more eps for some plumes, per Neggers 2015 fig. 15 - end do - - !IF ( debug_code ) THEN - print*,' MYNN; in TEMF_MF, Cepsmf, epsmf(1:13,nu)=', Cepsmf - print*," epsmf(1:13,nu)=",epsmf(1:13,nu) - !ENDIF - - ! Initialize updraft - thlUPD(1,nu) = thetal(1) + Cw*wstr - qtUPD(1,nu) = qtot(1) + 0.0*qfx/wstr - rUPD(1,nu) = qtUPD(1,nu) / (1. - qtUPD(1,nu)) - wUPD(1,nu) = Cw * wstr - wUPD_dry(1,nu) = Cw * wstr - UUPD(1,nu) = u_temf(1) - VUPD(1,nu) = v_temf(1) - thetavUPD(1,nu) = thlUPD(1,nu) * (1. + 0.608*qtUPD(1,nu)) ! WA Assumes no liquid - thetavUPDmoist(1,nu) = thetavUPD(1,nu) - TEUPD(1,nu) = qke(1) + g / thetav(1) * sfcTHVF - qlUPD(1,nu) = qc(1) ! WA allow environment liquid - TUPD(1,nu) = thlUPD(1,nu) * pi1d(1) - !rstUPD(1,nu) = rsat_temf(p(1),TUPD(1,nu),ep_2) - rstUPD(1,nu) = qsat_blend(TUPD(1,nu),p(1)) ! get saturation water vapor mixing ratio at tl and p - rlUPD(1,nu) = 0. -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - chemUPD(1,ic,nu) = chem(1,ic) - enddo - ENDIF -#endif - - ! Calculate updraft parameters counting up - do k = 2,kte - ! WA 2/11/13 use hmax index to prevent oddness high up - if ( k < hmax_idx) then - dthUPDdz(k-1,nu) = -epsmf(k,nu) * (thlUPD(k-1,nu) - thetal(k-1)) - thlUPD(k,nu) = thlUPD(k-1,nu) + dthUPDdz(k-1,nu) * dzm(k-1) - dmoist_qtdz(k-1) = -epsmf(k,nu) * (qtUPD(k-1,nu) - qtot(k-1)) - qtUPD(k,nu) = qtUPD(k-1,nu) + dmoist_qtdz(k-1) * dzm(k-1) - thetavUPD(k,nu) = thlUPD(k,nu) * (1. + 0.608*qtUPD(k,nu)) ! WA Assumes no liquid - B(k-1) = g * (thetavUPD(k,nu) - thetav(k)) / thetav(k) - if ( wUPD_dry(k-1,nu) < 1e-15 ) then - wUPD_dry(k,nu) = 0. - else - dwUPDdz(k-1,nu) = -2. *epsmf(k,nu)*wUPD_dry(k-1,nu) + 0.33*B(k-1)/wUPD_dry(k-1,nu) - wUPD_dry(k,nu) = wUPD_dry(k-1,nu) + dwUPDdz(k-1,nu) * dzm(k-1) - end if - dUUPDdz(k-1,nu) = -epsmf(k,nu) * (UUPD(k-1,nu) - u_temf(k-1)) - UUPD(k,nu) = UUPD(k-1,nu) + dUUPDdz(k-1,nu) * dzm(k-1) - dVUPDdz(k-1,nu) = -epsmf(k,nu) * (VUPD(k-1,nu) - v_temf(k-1)) - VUPD(k,nu) = VUPD(k-1,nu) + dVUPDdz(k-1,nu) * dzm(k-1) - dTEUPDdz(k-1,nu) = -epsmf(k,nu) * (TEUPD(k-1,nu) - qke(k-1)) - TEUPD(k,nu) = TEUPD(k-1,nu) + dTEUPDdz(k-1,nu) * dzm(k-1) - ! Alternative updraft velocity based on moist thetav - ! Need thetavUPDmoist, qlUPD - rUPD(k,nu) = qtUPD(k,nu) / (1. - qtUPD(k,nu)) - ! WA Updraft temperature assuming no liquid - TUPD(k,nu) = thlUPD(k,nu) * pi1d(k) - ! Updraft saturation mixing ratio - !rstUPD(k,nu) = rsat_temf(p(k-1),TUPD(k,nu),ep_2) - rstUPD(k,nu) = qsat_blend(TUPD(k,nu),p(k-1)) - ! Correct to actual temperature (Sommeria & Deardorff 1977) - beta1(k) = 0.622 * (xlv/(r_d*TUPD(k,nu))) * (xlv/(cp*TUPD(k,nu))) - rstUPD(k,nu) = rstUPD(k,nu) * (1.0+beta1(k)*rUPD(k,nu)) / (1.0+beta1(k)*rstUPD(k,nu)) - qstUPD(k,nu) = rstUPD(k,nu) / (1. + rstUPD(k,nu)) - if (rUPD(k,nu) > rstUPD(k,nu)) then - rlUPD(k,nu) = rUPD(k,nu) - rstUPD(k,nu) - qlUPD(k,nu) = rlUPD(k,nu) / (1. + rlUPD(k,nu)) - thetavUPDmoist(k,nu) = (thlUPD(k,nu) + ((xlv/cp)*qlUPD(k,nu)/pi1d(k))) * & - (1. + 0.608*qstUPD(k,nu) - qlUPD(k,nu)) - else - rlUPD(k,nu) = 0. - qlUPD(k,nu) = qc(k-1) ! WA 4/6/10 allow environment liquid - thetavUPDmoist(k,nu) = thlUPD(k,nu) * (1. + 0.608*qtUPD(k,nu)) - end if - Bmoist(k-1) = g * (thetavUPDmoist(k,nu) - thetav(k)) / thetav(k) - if ( wUPD(k-1,nu) < 1e-15 ) then - wUPD(k,nu) = 0. - else - dwUPDmoistdz(k-1,nu) = -2. *epsmf(k,nu)*wUPD(k-1,nu) + 0.33*Bmoist(k-1)/wUPD(k-1,nu) - wUPD(k,nu) = wUPD(k-1,nu) + dwUPDmoistdz(k-1,nu) * dzm(k-1) - end if -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - dchemUPDdz(k-1,ic,nu) = -epsmf(k,nu) * (chemUPD(k-1,ic,nu) - chem(k-1,ic)) - chemUPD(k,ic,nu) = chemUPD(k-1,ic,nu) + dchemUPDdz(k-1,ic,nu) * dzm(k-1) - enddo - ENDIF -#endif - else ! above hmax - thlUPD(k,nu) = thetal(k) - qtUPD(k,nu) = qtot(k) - wUPD_dry(k,nu) = 0. - UUPD(k,nu) = u_temf(k) - VUPD(k,nu) = v_temf(k) - TEUPD(k,nu) = qke(k) - qlUPD(k,nu) = qc(k-1) - wUPD(k,nu) = 0. -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - chemUPD(k,ic,nu) = chem(k-1,ic) - enddo - ENDIF -#endif - end if - - IF ( debug_code ) THEN - IF ( ABS(wUPD(k,nu))>10. ) THEN - print*,' MYNN, in TEMF_MF, huge w at (nu,k):', nu,k - print *," thlUPD(1:k,nu) = ", thlUPD(1:k,nu) - print *," wUPD(1:k,nu) = ", wUPD(1:k,nu) - print *," Bmoist(1:k-1) = ", Bmoist(1:k-1) - print *," epsmf(1:k,nu) = ", epsmf(1:k,nu) - ENDIF - ENDIF - - ENDDO !end-k - - ! Find hd based on wUPD - if (wUPD_dry(1,nu) == 0.) then - hdidx(nu) = 1 - else - hdidx(nu) = kte ! In case wUPD <= 0 not found - do k = 2,kte - if (wUPD_dry(k,nu) <= 0. .OR. zm(k) > hmax) then - hdidx(nu) = k - ! goto 100 ! FORTRAN made me do it! - exit - end if - end do - end if - 100 hd(nu) = zm(hdidx(nu)) - - ! Find LCL, hct, and ht - lclidx(nu) = kte ! In case LCL not found - do k = kts,kte - if ( k < hmax_idx .AND. rUPD(k,nu) > rstUPD(k,nu)) then - lclidx(nu) = k - ! goto 200 - exit - end if - end do - 200 lcl(nu) = zm(lclidx(nu)) - - if (hd(nu) > lcl(nu)) then ! Forced cloud (at least) occurs - ! Find hct based on wUPDmoist - if (wUPD(1,nu) == 0.) then - hctidx(nu) = 1 - else - hctidx(nu) = kte ! In case wUPD <= 0 not found - do k = 2,kte - if (wUPD(k,nu) <= 0. .OR. zm(k) > hmax) then - hctidx(nu) = k - ! goto 300 ! FORTRAN made me do it! - exit - end if - end do - end if - 300 hct(nu) = zm(hctidx(nu)) - if (hctidx(nu) <= hdidx(nu)+1) then ! No active cloud - hct(nu) = hd(nu) - hctidx(nu) = hdidx(nu) - else - end if - else ! No cloud - hct(nu) = hd(nu) - hctidx(nu) = hdidx(nu) - end if - ht(nu) = max(hd(nu),hct(nu)) - htidx(nu) = max(hdidx(nu),hctidx(nu)) - - ! Now truncate updraft at ht with taper - do k = 1,kte - if (zm(k) < 0.9*ht(nu)) then ! Below taper region - tval = 1 - else if (zm(k) >= 0.9*ht(nu) .AND. zm(k) <= 1.0*ht(nu)) then - ! Within taper region - tval = 1. - ((zm(k) - 0.9*ht(nu)) / (1.0*ht(nu) - 0.9*ht(nu))) - else ! Above taper region - tval = 0. - end if - thlUPD(k,nu) = tval * thlUPD(k,nu) + (1-tval)*thetal(k) - thetavUPD(k,nu) = tval * thetavUPD(k,nu) + (1-tval)*thetav(k) - qtUPD(k,nu) = tval * qtUPD(k,nu) + (1-tval) * qtot(k) - if (k > 1) then - qlUPD(k,nu) = tval * qlUPD(k,nu) + (1-tval) * qc(k-1) - end if - UUPD(k,nu) = tval * UUPD(k,nu) + (1-tval) * u_temf(k) - VUPD(k,nu) = tval * VUPD(k,nu) + (1-tval) * v_temf(k) - TEUPD(k,nu) = tval * TEUPD(k,nu) + (1-tval) * qke(k) - if (zm(k) > ht(nu)) then ! WA this is just for cleanliness - wUPD(k,nu) = 0. - dwUPDmoistdz(k,nu) = 0. - wUPD_dry(k,nu) = 0. - dwUPDdz(k,nu) = 0. - end if -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - chemUPD(k,ic,nu) = tval * chemUPD(k,ic,nu) + (1-tval) * chem(k,ic) - enddo - ENDIF -#endif - end do - - ! Calculate lateral detrainment rate for cloud layer - ! WA 8/5/15 constant detrainment - ! deltmf(1,nu) = Cepsmf - ! do k = 2,kte-1 - ! deltmf(k,nu) = deltmf(k-1,nu) - ! end do - ! deltmf(kte,nu) = Cepsmf - deltmf(:,nu) = epsmf(:,nu) ! WA TEST delt = eps everywhere - - ! Calculate mass flux (defined on turbulence levels) - mf_temfx(1,nu) = CM * wstr / Nupd - ! WA 3/2/16 limit max MF for stability - ! WA reduce the constant for improved numerical stability? - mf_temfx(1,nu) = min(mf_temfx(1,nu),0.2/Nupd) - do kt = 2,kte-1 - dMdz(kt,nu) = (epsmf(kt,nu) - deltmf(kt,nu)) * mf_temfx(kt-1,nu) * dzt(kt) - mf_temfx(kt,nu) = mf_temfx(kt-1,nu) + dMdz(kt,nu) - ! WA TEST 6/14/16 don't allow <0 - mf_temfx(kt,nu) = max(mf_temfx(kt,nu),0.0) - IF ( debug_code ) THEN - IF ( mf_temfx(kt,nu)>=0.2/NUPD ) THEN - print*,' MYNN, in TEMF_MF, huge MF at (nu,k):', nu,kt - print*," mf_temfx(1:kt,nu) = ", mf_temfx(1:kt,nu) - ENDIF - ENDIF - end do - mf_temfx(kte,nu) = 0. - - ! Calculate cloud fraction (on mass levels) - ! WA eventually replace this with the same saturation calculation - ! used in the MYNN code above for consistency. - ! WA TEST 6/14/16 make sure aUPD(1) is reasonable - aUPD(1,nu) = 0.06 / Nupd - do k = 2,kte - ! WA TEST 6/14/16 increase epsilon in test - ! if (wUPD(k-1,nu) >= 1.0e-15 .AND. wUPD(k,nu) >= 1.0e-15) then - if (wUPD(k-1,nu) >= 1.0e-5 .AND. wUPD(k,nu) >= 1.0e-5) then - aUPD(k,nu) = ((mf_temfx(k-1,nu)+mf_temfx(k,nu))/2.0) / & - ((wUPD(k-1,nu)+wUPD(k,nu))/2.0) ! WA average before divide, is that best? - else - aUPD(k,nu) = 0.0 - end if - sigq2 = aUPD(k,nu) * (qtUPD(k,nu)-qtot(k)) - if (sigq2 > 0.0) then - sigq(k) = sqrt(sigq2) - else - sigq(k) = 0.0 - end if - !rst = rsat_temf(p(k-1),th(k-1)*pi1d(k-1),ep_2) - rst = qsat_blend(th(k-1)*pi1d(k-1),p(k-1)) - qst(k) = rst / (1. + rst) - satdef(k) = qtot(k) - qst(k) - if (satdef(k) <= 0.0) then - if (sigq(k) > 1.0e-15) then - cldfraUPD(k,nu) = max(0.5 + 0.36 * atan(1.55*(satdef(k)/sigq(k))),0.0) / Nupd - else - cldfraUPD(k,nu) = 0.0 - end if - else - cldfraUPD(k,nu) = 1.0 / Nupd - end if - if (zm(k) < lcl(nu)) then - cldfraUPD(k,nu) = 0.0 - end if - end do - - end do ! loop over nu updrafts - - ! Add updraft areas into edmf_a, etc. - ! Add cloud fractions into cldfra_bl1d - !cldfra_bl1d(1) = 0.0 - cfm_temfx = 0.0 - do k = 2,kte - !cldfra_bl1d(k) = 0.0 - cldfra_sum = 0.0 - edmf_a(k) = 0.0 - edmf_w(k) = 0.0 - edmf_thl(k) = 0.0 - edmf_qt(k) = 0.0 - edmf_qc(k) = 0.0 - edmf_u(k) = 0.0 - edmf_v(k) = 0.0 - edmf_qke(k) = 0.0 - edmf_ent(k) = 0.0 -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - edmf_chem(k,ic) = 0.0 - enddo - ENDIF -#endif - do nu = 1,Nupd - ! WA 7/5/16 put area on turbulence levels for consistency - aUPDt(k,nu) = mf_temfx(k,nu) / wUPD(k,nu) - if (aUPDt(k,nu) >= 1.0e-3 .AND. wUPD(k,nu) >= 1.0e-5) then - edmf_a(k) = edmf_a(k) + aUPDt(k,nu) - edmf_w(k) = edmf_w(k) + aUPDt(k,nu)*wUPD(k,nu) - edmf_thl(k) = edmf_thl(k) + aUPDt(k,nu)*thlUPD(k,nu) - edmf_qt(k) = edmf_qt(k) + aUPDt(k,nu)*qtUPD(k,nu) - edmf_qc(k) = edmf_qc(k) + aUPDt(k,nu)*qlUPD(k,nu) - edmf_u(k) = edmf_u(k) + aUPDt(k,nu)*UUPD(k,nu) - edmf_v(k) = edmf_v(k) + aUPDt(k,nu)*VUPD(k,nu) - edmf_qke(k) = edmf_qke(k) + aUPDt(k,nu)*TEUPD(k,nu) - edmf_ent(k) = edmf_ent(k) + aUPDt(k,nu)*epsmf(k,nu) - cldfra_sum = cldfra_sum + cldfraUPD(k,nu) -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic) + aUPDt(k,nu)*chemUPD(k,ic,nu) - enddo - ENDIF -#endif - end if - end do - - IF ( debug_code ) THEN - ! print *,"In TEMF_MF edmf_w = ", edmf_w(1:10) - ! print *,"In TEMF_MF edmf_a = ", edmf_a(1:10) - ! print *,"In TEMF_MF edmf_thl = ", edmf_thl(1:10) - ! print *,"In TEMF_MF aUPD(2,:) = ", aUPD(2,:) - ! print *,"In TEMF_MF wUPD(2,:) = ", wUPD(2,:) - ! print *,"In TEMF_MF thlUPD(2,:) = ", thlUPD(2,:) - ENDIF - - ! WA TEST 6/14/16 don't divide by very small updrafts - !if (edmf_a(k)>0.) then - if (edmf_a(k)>1.e-3) then - edmf_w(k)=edmf_w(k)/edmf_a(k) - edmf_qt(k)=edmf_qt(k)/edmf_a(k) - edmf_thl(k)=edmf_thl(k)/edmf_a(k) - edmf_ent(k)=edmf_ent(k)/edmf_a(k) - edmf_qc(k)=edmf_qc(k)/edmf_a(k) - edmf_u(k)=edmf_u(k)/edmf_a(k) - edmf_v(k)=edmf_v(k)/edmf_a(k) - edmf_qke(k)=edmf_qke(k)/edmf_a(k) -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) - enddo - ENDIF -#endif - - if (edmf_qc(k) > 0.0) then - IF (cldfra_sum > edmf_a(k)) THEN - cldfra_bl1d(k) = cldfra_sum - qc_bl1d(k) = edmf_qc(k)*edmf_a(k)/cldfra_sum - ELSE - cldfra_bl1d(k)=edmf_a(k) - qc_bl1d(k) = edmf_qc(k) - ENDIF - endif - endif - - ! Put max value so far into cfm - if (zt(k) <= hmax) then - cfm_temfx = max(cldfra_bl1d(k),cfm_temfx) - end if - end do - - !cldfra_bl1d(kte) = 0.0 - - ! Computing variables needed for solver - - do k=kts,kte ! do these in loop above - ! WA TEST 6/14/16 don't use very small updrafts to be consistent - ! with block above - if (edmf_a(k)>1.0e-3) then - s_aw(k) = edmf_a(k)*edmf_w(k)*psig_w * (1.0+rstoch_col(k)) - s_awthl(k)= edmf_a(k)*edmf_w(k)*edmf_thl(k)*psig_w * (1.0+rstoch_col(k)) - s_awqt(k) = edmf_a(k)*edmf_w(k)*edmf_qt(k)*psig_w * (1.0+rstoch_col(k)) - s_awqc(k) = edmf_a(k)*edmf_w(k)*edmf_qc(k)*psig_w * (1.0+rstoch_col(k)) - s_awqv(k) = s_awqt(k) - s_awqc(k) - s_awu(k) = edmf_a(k)*edmf_w(k)*edmf_u(k)*psig_w * (1.0+rstoch_col(k)) - s_awv(k) = edmf_a(k)*edmf_w(k)*edmf_v(k)*psig_w * (1.0+rstoch_col(k)) - s_awqke(k) = edmf_a(k)*edmf_w(k)*edmf_qke(k)*psig_w * (1.0+rstoch_col(k)) -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - s_awchem(k,ic) = edmf_w(k)*edmf_chem(k,ic)*psig_w * (1.0+rstoch_col(k)) - enddo - ENDIF -#endif - endif - !now reduce diagnostic output array by psig - edmf_a(k)=edmf_a(k)*psig_w - enddo - - ! end if ! is_convective - ! Mass flux block ends here - else - edmf_a = 0. - edmf_w = 0. - edmf_qt = 0. - edmf_thl = 0. - edmf_ent = 0. - edmf_u = 0. - edmf_v = 0. - edmf_qke = 0. - s_aw = 0. - s_awthl= 0. - s_awqt = 0. - s_awqv = 0. - s_awqc = 0. - s_awu = 0. - s_awv = 0. - s_awqke= 0. - edmf_qc(1) = qc(1) - !qc_bl1d(1) = qc(1) - do k = kts+1,kte-1 - edmf_qc(k) = qc(k-1) - !qc_bl1d(k) = qc(k-1) - end do -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - s_awchem(:,ic) = 0. - enddo - ENDIF -#endif - end if - !edmf_qc(kte) = qc(kte) - !qc_bl1d(kte) = qc(kte) - - !IF ( debug_code ) THEN - ! print *,"After TEMF_MF, s_aw = ", s_aw(1:5) - ! print *,"After TEMF_MF, s_awthl = ", s_awthl(1:5) - ! print *,"After TEMF_MF, s_awqt = ", s_awqt(1:5) - ! print *,"After TEMF_MF, s_awqc = ", s_awqc(1:5) - ! print *,"After TEMF_MF, s_awqv = ", s_awqv(1:5) - ! print *,"After TEMF_MF, s_awu = ", s_awu(1:5) - ! print *,"After TEMF_MF, s_awv = ", s_awv(1:5) - ! print *,"After TEMF_MF, s_awqke = ", s_awqke(1:5) - !ENDIF - -END SUBROUTINE temf_mf - -!-------------------------------------------------------------------- -! - real function rsat_temf(p,T,ep2) - -! Calculates the saturation mixing ratio with respect to liquid water -! Arguments are pressure (Pa) and absolute temperature (K) -! Uses the formula from the ARM intercomparison setup. -! Converted from Matlab by WA 7/28/08 - -implicit none -real p, T, ep2 -real temp, x -real, parameter :: c0 = 0.6105851e+3 -real, parameter :: c1 = 0.4440316e+2 -real, parameter :: c2 = 0.1430341e+1 -real, parameter :: c3 = 0.2641412e-1 -real, parameter :: c4 = 0.2995057e-3 -real, parameter :: c5 = 0.2031998e-5 -real, parameter :: c6 = 0.6936113e-8 -real, parameter :: c7 = 0.2564861e-11 -real, parameter :: c8 = -0.3704404e-13 - -temp = T - 273.15 - -x =c0+temp*(c1+temp*(c2+temp*(c3+temp*(c4+temp*(c5+temp*(c6+temp*(c7+temp*c8))))))) -rsat_temf = ep2*x/(p-x) - -return -end function rsat_temf - -!================================================================= +! =================================================================== END MODULE module_bl_mynn From 5c8125e9ce7891a62e6dea54c7544e22d49e08dc Mon Sep 17 00:00:00 2001 From: climbfuji Date: Tue, 5 Mar 2019 08:09:36 -0700 Subject: [PATCH 15/15] physics/mp_thompson_hrrr_pre.F90: add sanitizer for initial values of tracers (hydrometeors, aerosols) used by Thompson scheme --- physics/mp_thompson_hrrr_pre.F90 | 50 ++++++++++++++++++++++++++++++-- 1 file changed, 47 insertions(+), 3 deletions(-) diff --git a/physics/mp_thompson_hrrr_pre.F90 b/physics/mp_thompson_hrrr_pre.F90 index 0167a952a..737f9c5d9 100644 --- a/physics/mp_thompson_hrrr_pre.F90 +++ b/physics/mp_thompson_hrrr_pre.F90 @@ -28,7 +28,16 @@ end subroutine mp_thompson_hrrr_pre_init !! | kdt | index_of_time_step | current forecast iteration | index | 0 | integer | | in | F | !! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | !! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | spechum | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qc | cloud_condensed_water_mixing_ratio_updated_by_physics | cloud water mixing ratio wrt dry+vapor (no condensates) | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qr | rain_water_mixing_ratio_updated_by_physics | rain water mixing ratio wrt dry+vapor (no condensates) | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qi | ice_water_mixing_ratio_updated_by_physics | ice water mixing ratio wrt dry+vapor (no condensates) | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qs | snow_water_mixing_ratio_updated_by_physics | snow water mixing ratio wrt dry+vapor (no condensates) | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qg | graupel_mixing_ratio_updated_by_physics | graupel mixing ratio wrt dry+vapor (no condensates) | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | ni | ice_number_concentration_updated_by_physics | ice number concentration | kg-1 | 2 | real | kind_phys | inout | F | +!! | nr | rain_number_concentration_updated_by_physics | rain number concentration | kg-1 | 2 | real | kind_phys | inout | F | !! | is_aerosol_aware| flag_for_aerosol_physics | flag for aerosol-aware physics | flag | 0 | logical | | in | F | +!! | nc | cloud_droplet_number_concentration_updated_by_physics | cloud droplet number concentration | kg-1 | 2 | real | kind_phys | inout | T | !! | nwfa | water_friendly_aerosol_number_concentration_updated_by_physics | number concentration of water-friendly aerosols | kg-1 | 2 | real | kind_phys | inout | T | !! | nifa | ice_friendly_aerosol_number_concentration_updated_by_physics | number concentration of ice-friendly aerosols | kg-1 | 2 | real | kind_phys | inout | T | !! | nwfa2d | tendency_of_water_friendly_aerosols_at_surface | instantaneous fake water-friendly surface aerosol source | kg-1 s-1 | 1 | real | kind_phys | inout | T | @@ -47,7 +56,8 @@ end subroutine mp_thompson_hrrr_pre_init !! #endif subroutine mp_thompson_hrrr_pre_run(ncol, nlev, kdt, con_g, con_rd, & - is_aerosol_aware, nwfa, nifa, nwfa2d, & + spechum, qc, qr, qi, qs, qg, ni, nr, & + is_aerosol_aware, nc, nwfa, nifa, nwfa2d, & nifa2d, tgrs, tgrs_save, prsl, phil, area, & mpicomm, mpirank, mpiroot, blkno, & errmsg, errflg) @@ -61,8 +71,18 @@ subroutine mp_thompson_hrrr_pre_run(ncol, nlev, kdt, con_g, con_rd, & integer, intent(in ) :: kdt real(kind_phys), intent(in ) :: con_g real(kind_phys), intent(in ) :: con_rd + ! Hydrometeors + real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qc(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qr(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qi(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qs(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qg(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: ni(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: nr(1:ncol,1:nlev) ! Aerosols logical, intent(in ) :: is_aerosol_aware + real(kind_phys), optional, intent(inout) :: nc(1:ncol,1:nlev) real(kind_phys), optional, intent(inout) :: nwfa(1:ncol,1:nlev) real(kind_phys), optional, intent(inout) :: nifa(1:ncol,1:nlev) real(kind_phys), optional, intent(inout) :: nwfa2d(1:ncol) @@ -97,20 +117,44 @@ subroutine mp_thompson_hrrr_pre_run(ncol, nlev, kdt, con_g, con_rd, & ! Return if not first timestep if (kdt > 1) return + ! Fix initial values of hydrometeors + where(spechum<0) spechum = 0.0 + where(qc<0) qc = 0.0 + where(qr<0) qr = 0.0 + where(qi<0) qi = 0.0 + where(qs<0) qs = 0.0 + where(qg<0) qg = 0.0 + where(ni<0) ni = 0.0 + where(nr<0) nr = 0.0 + ! If qi is in boundary conditions but ni is not, reset qi to zero (and vice versa) + if (maxval(qi)>0.0 .and. maxval(ni)==0.0) qi = 0.0 + if (maxval(ni)>0.0 .and. maxval(qi)==0.0) ni = 0.0 + ! If qr is in boundary conditions but nr is not, reset qr to zero (and vice versa) + if (maxval(qr)>0.0 .and. maxval(nr)==0.0) qr = 0.0 + if (maxval(nr)>0.0 .and. maxval(qr)==0.0) nr = 0.0 + ! Return if aerosol-aware option is not used if (.not. is_aerosol_aware) return - if (.not.present(nwfa2d) .or. & + if (.not.present(nc) .or. & + .not.present(nwfa2d) .or. & .not.present(nifa2d) .or. & .not.present(nwfa) .or. & .not.present(nifa) ) then write(errmsg,fmt='(*(a))') 'Logic error in mp_thompson_hrrr_pre_run:', & ' aerosol-aware microphysics require all of the following', & - ' optional arguments: nifa2d, nwfa2d, nwfa, nifa' + ' optional arguments: nc, nifa2d, nwfa2d, nwfa, nifa' errflg = 1 return end if + ! Fix initial values of aerosols + where(nc<0) nc = 0.0 + where(nwfa<0) nwfa = 0.0 + where(nifa<0) nifa = 0.0 + where(nwfa2d<0) nwfa2d = 0.0 + where(nifa2d<0) nifa2d = 0.0 + #ifdef DEBUG_AEROSOLS if (mpirank==mpiroot) then write(0,'(a,3e16.7)') "AEROSOL DEBUG mp_thompson_hrrr_pre_run before: nwfa2d min/mean/max =", &