diff --git a/.gitmodules b/.gitmodules index 8758980ec..24b9cf118 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,4 +1,7 @@ [submodule "physics/rte-rrtmgp"] - path = physics/rte-rrtmgp + path = physics/Radiation/RRTMGP/rte-rrtmgp url = https://github.com/earth-system-radiation/rte-rrtmgp branch = main +[submodule "physics/Radiation/RRTMGP/rte-rrtmgp"] + path = physics/Radiation/RRTMGP/rte-rrtmgp + url = https://github.com/earth-system-radiation/rte-rrtmgp diff --git a/CMakeLists.txt b/CMakeLists.txt index 97591a2ee..ee708d4c4 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -79,37 +79,37 @@ get_filename_component(LOCAL_CURRENT_SOURCE_DIR ${FULL_PATH_TO_CMAKELISTS} DIREC #------------------------------------------------------------------------------ # List of files that need to be compiled without OpenMP -set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_optics.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_string.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_fluxes_byband.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/solar_variability/mo_solar_variability.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_heating_rates.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_fluxes_bygpoint.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_compute_bc.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/cloud_optics/mo_cloud_sampling.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_config.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_source_functions.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_sw.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_fluxes.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_lw.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_util_array.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels/mo_optical_props_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_kind.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_optical_props.F90) +set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/mo_gas_optics.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_string.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/mo_fluxes_byband.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/solar_variability/mo_solar_variability.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/mo_heating_rates.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/mo_fluxes_bygpoint.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/mo_compute_bc.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/cloud_optics/mo_cloud_sampling.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_rte_config.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_source_functions.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_rte_sw.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_fluxes.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_rte_lw.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_rte_util_array.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/kernels/mo_optical_props_kernels.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_rte_kind.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_optical_props.F90) # List of files that need to be compiled with different precision set(SCHEMES_DYNAMICS) -if(${LOCAL_CURRENT_SOURCE_DIR}/physics/fv_sat_adj.F90 IN_LIST SCHEMES) - list(APPEND SCHEMES_DYNAMICS ${LOCAL_CURRENT_SOURCE_DIR}/physics/fv_sat_adj.F90) +if(${LOCAL_CURRENT_SOURCE_DIR}/physics/MP/GFDL/fv_sat_adj.F90 IN_LIST SCHEMES) + list(APPEND SCHEMES_DYNAMICS ${LOCAL_CURRENT_SOURCE_DIR}/physics/MP/GFDL/fv_sat_adj.F90) endif() # Remove files that need to be compiled with different precision diff --git a/physics/cu_c3_deep.F90 b/physics/CONV/C3/cu_c3_deep.F90 similarity index 94% rename from physics/cu_c3_deep.F90 rename to physics/CONV/C3/cu_c3_deep.F90 index c3a4b2c4e..b7cd5f62d 100644 --- a/physics/cu_c3_deep.F90 +++ b/physics/CONV/C3/cu_c3_deep.F90 @@ -97,6 +97,9 @@ subroutine cu_c3_deep_run( & ,tmf & ! instantanious tendency from turbulence ,qmicro & ! instantanious tendency from microphysics ,forceqv_spechum & !instantanious tendency from dynamics + ,betascu & ! Tuning parameter for shallow clouds + ,betamcu & ! Tuning parameter for mid-level clouds + ,betadcu & ! Tuning parameter for deep clouds ,sigmain & ! input area fraction after advection ,sigmaout & ! updated prognostic area fraction ,z1 & ! terrain @@ -159,12 +162,12 @@ subroutine cu_c3_deep_run( & nranflag,itf,ktf,its,ite, kts,kte,ipr,imid integer, intent (in ) :: & ichoice - real(kind=kind_phys), dimension (its:ite,4) & + real(kind=kind_phys), dimension (its:,:) & ,intent (in ) :: rand_clos - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: rand_mom,rand_vmas !$acc declare copyin(rand_clos,rand_mom,rand_vmas) - real(kind=kind_phys), intent(in), dimension (its:ite) :: ca_deep(:) + real(kind=kind_phys), intent(in), dimension (its:) :: ca_deep(:) integer, intent(in) :: do_capsuppress real(kind=kind_phys), intent(in), dimension(:) :: cap_suppress_j !$acc declare create(cap_suppress_j) @@ -177,28 +180,28 @@ subroutine cu_c3_deep_run( & ! outq = output q tendency (per s) ! outqc = output qc tendency (per s) ! pre = output precip - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout ) :: & cnvwt,outu,outv,outt,outq,outqc,cupclw - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & frh_out,rainevap - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & tmf, qmicro, sigmain, forceqv_spechum - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & pre,xmb_out !$acc declare copy(cnvwt,outu,outv,outt,outq,outqc,cupclw,frh_out,pre,xmb_out) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & hfx,qfx,xmbm_in,xmbs_in !$acc declare copyin(hfx,qfx,xmbm_in,xmbs_in) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout ) :: & kbcon,ktop !$acc declare copy(kbcon,ktop) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kpbl,tropics !$acc declare copyin(kpbl,tropics) @@ -207,34 +210,34 @@ subroutine cu_c3_deep_run( & ! 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) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & dhdt,rho,t,po,us,vs,tn,delp !$acc declare copyin(dhdt,rho,t,po,us,vs,tn) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout ) :: & omeg !$acc declare copy(omeg) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout) :: & q,qo,zuo,zdo,zdm !$acc declare sigmaout - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (out) :: & sigmaout - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & dx,z1,psur,xland !$acc declare copyin(dx,z1,psur,xland) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & mconv,ccn !$acc declare copy(mconv,ccn) real(kind=kind_phys) & - ,intent (in ) :: & - dtime,ccnclean,fv,r_d + ,intent (in ) :: & + dtime,ccnclean,fv,r_d,betascu,betamcu,betadcu ! @@ -372,8 +375,8 @@ subroutine cu_c3_deep_run( & !$acc kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & !$acc ktopdby,kbconx,ierr2,ierr3,kbmax) - integer, dimension (its:ite), intent(inout) :: ierr - integer, dimension (its:ite), intent(in) :: csum + integer, dimension (its:), intent(inout) :: ierr + integer, dimension (its:), intent(in) :: csum logical, intent(in) :: do_ca, progsigma logical, intent(in) :: flag_init, flag_restart !$acc declare copy(ierr) copyin(csum) @@ -386,13 +389,16 @@ subroutine cu_c3_deep_run( & real(kind=kind_phys), dimension (its:ite) :: pefc real(kind=kind_phys) entdo,dp,subin,detdo,entup, & detup,subdown,entdoj,entupk,detupk,totmas + real(kind=kind_phys) :: & + sigmind,sigminm,sigmins + parameter(sigmind=0.005,sigmins=0.03,sigminm=0.01) real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec !$acc declare create(lambau,flux_tun,zws,ztexec,zqexec) integer :: jprnt,jmini,start_k22 logical :: keep_going,flg(its:ite),cnvflg(its:ite) - logical :: flag_shallow + logical :: flag_shallow,flag_mid !$acc declare create(flg) @@ -421,7 +427,7 @@ subroutine cu_c3_deep_run( & !$acc tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl, & !$acc qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl, & !$acc gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl,xf_dicycle) - real(kind=kind_phys), intent(inout), dimension(its:ite,10) :: forcing + real(kind=kind_phys), intent(inout), dimension(its:,:) :: forcing !$acc declare copy(forcing) integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz @@ -1988,7 +1994,11 @@ subroutine cu_c3_deep_run( & ! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then + flag_mid = .false. flag_shallow = .false. + if(imid.eq.1)then + flag_mid = .true. + endif do k=kts,ktf do i=its,itf del(i,k) = delp(i,k)*0.001 @@ -2003,9 +2013,9 @@ subroutine cu_c3_deep_run( & endif enddo call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, & - del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,xlv,dtime, & - forceqv_spechum,kbcon,ktop,cnvflg, & - sigmain,sigmaout,sigmab) + flag_mid,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,xlv,dtime, & + forceqv_spechum,kbcon,ktop,cnvflg,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif !$acc end kernels @@ -2078,10 +2088,6 @@ subroutine cu_c3_deep_run( & !> - Call rain_evap_below_cloudbase() to calculate evaporation below cloud base - call rain_evap_below_cloudbase(itf,ktf,its,ite, & - kts,kte,ierr,kbcon,xmb,psur,xland,qo_cup, & - po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) - k=1 !$acc kernels do i=its,itf @@ -2137,7 +2143,7 @@ subroutine cu_c3_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.400.)then + if(k.gt.jmin(i))then if(flg(i))then q1=qo(i,k)+(outq(i,k))*dtime t1=tn(i,k)+(outt(i,k))*dtime @@ -2162,7 +2168,7 @@ subroutine cu_c3_deep_run( & pre(i)=max(pre(i),0.) delqev(i) = delqev(i) + .001*dp*qevap(i)/g endif - !endif ! 400mb + endif endif enddo ! pre(i)=1000.*rn(i)/dtime @@ -2418,16 +2424,16 @@ subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & integer ,intent(in) :: itf,ktf, its,ite, kts,kte - integer, dimension(its:ite) ,intent(in) :: ierr,kbcon - real(kind=kind_phys), dimension(its:ite) ,intent(in) ::psur,xland,pwavo,edto,pwevo,xmb - real(kind=kind_phys), dimension(its:ite,kts:kte),intent(in) :: po_cup,qo_cup,qes_cup - real(kind=kind_phys), dimension(its:ite) ,intent(inout) :: pre - real(kind=kind_phys), dimension(its:ite,kts:kte),intent(inout) :: outt,outq !,outbuoy + integer, dimension(its:) ,intent(in) :: ierr,kbcon + real(kind=kind_phys), dimension(its:) ,intent(in) ::psur,xland,pwavo,edto,pwevo,xmb + real(kind=kind_phys), dimension(its:,kts:),intent(in) :: po_cup,qo_cup,qes_cup + real(kind=kind_phys), dimension(its:) ,intent(inout) :: pre + real(kind=kind_phys), dimension(its:,kts:),intent(inout) :: outt,outq !,outbuoy !$acc declare copyin(ierr,kbcon,psur,xland,pwavo,edto,pwevo,xmb,po_cup,qo_cup,qes_cup) !$acc declare copy(pre,outt,outq) - !real, dimension(its:ite) ,intent(out) :: tot_evap_bcb - !real, dimension(its:ite,kts:kte),intent(out) :: evap_bcb,net_prec_bcb + !real, dimension(its:) ,intent(out) :: tot_evap_bcb + !real, dimension(its:,kts:),intent(out) :: evap_bcb,net_prec_bcb !-- locals integer :: i,k @@ -2511,30 +2517,30 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & ! ! ierr error value, maybe modified in this routine ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & rho,us,vs,z,p,pw - real(kind=kind_phys), dimension (its:ite,1) & + real(kind=kind_phys), dimension (its:,: ) & ,intent (out ) :: & edtc - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & pefc - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & edt - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & pwav,pwev,psum2,psumh,edtmax,edtmin - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & ktop,kbcon,xland1 real(kind=kind_phys), intent (in ) :: & !HCB ccnclean - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & ccn - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copyin(rho,us,vs,z,p,pw,pwav,pwev,psum2,psumh,edtmax,edtmin,ktop,kbcon) @@ -2671,7 +2677,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & ! pwev = total normalized integrated evaoprate (i2) ! entr= entrainment rate ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & zd,hes_cup,hcd,qes_cup,q_cup,z_cup, & dd_massentr,dd_massdetr,gamma_cup,q,he,p_cup @@ -2679,18 +2685,18 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & integer & ,intent (in ) :: & iloop - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & jmin !$acc declare copyin(jmin) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copy(ierr) - real(kind=kind_phys), dimension (its:ite,kts:kte)& + real(kind=kind_phys), dimension (its:,kts:)& ,intent (out ) :: & qcd,qrcd,pwd - real(kind=kind_phys), dimension (its:ite)& + real(kind=kind_phys), dimension (its:)& ,intent (out ) :: & pwev,bu !$acc declare copyout(qcd,qrcd,pwd,pwev,bu) @@ -2812,23 +2818,23 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & its,ite, kts,kte ! ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & p,t,q !$acc declare copyin(p,t,q) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (out ) :: & hes,qes !$acc declare copyout(hes,qes) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout) :: & he,z !$acc declare copy(he,z) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & psur,z1 !$acc declare copyin(psur,z1) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copy(ierr) @@ -2966,19 +2972,19 @@ subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & itf,ktf, & its,ite, kts,kte ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & qes,q,he,hes,z,p,t !$acc declare copyin(qes,q,he,hes,z,p,t) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (out ) :: & qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup !$acc declare copyout(qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & psur,z1 !$acc declare copyin(psur,z1) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copy(ierr) @@ -3077,33 +3083,33 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 ! k22 = updraft originating level ! ichoice = flag if only want one closure (usually set to zero!) ! - real(kind=kind_phys), dimension (its:ite,1:maxens3) & + real(kind=kind_phys), dimension (its:,1:) & ,intent (inout) :: & pr_ens - real(kind=kind_phys), dimension (its:ite,1:maxens3) & + real(kind=kind_phys), dimension (its:,1:) & ,intent (inout ) :: & xf_ens !$acc declare copy(pr_ens,xf_ens) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & zd,zu,p_cup,zdm - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & omeg - real(kind=kind_phys), dimension (its:ite,1) & + real(kind=kind_phys), dimension (its:,:) & ,intent (in ) :: & xaa0 - real(kind=kind_phys), dimension (its:ite,4) & + real(kind=kind_phys), dimension (its:,:) & ,intent (in ) :: & rand_clos - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & aa1,edt,edtm,omegac,sigmab - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & mconv,axx !$acc declare copyin(zd,zu,p_cup,zdm,omeg,xaa0,rand_clos,aa1,edt,edtm,mconv,axx) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout) :: & aa0,closure_n !$acc declare copy(aa0,closure_n) @@ -3113,13 +3119,13 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 real(kind=kind_phys) & ,intent (in ) :: & dtime - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout ) :: & k22,kbcon,ktop - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & xland - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr,ierr2,ierr3 !$acc declare copy(k22,kbcon,ktop,ierr,ierr2,ierr3) copyin(xland) @@ -3129,10 +3135,10 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 integer, intent(in) :: dicycle logical, intent (in) :: progsigma - real(kind=kind_phys), intent(in) , dimension (its:ite) :: aa1_bl,tau_ecmwf - real(kind=kind_phys), intent(inout), dimension (its:ite) :: xf_dicycle - real(kind=kind_phys), intent(out), dimension (its:ite) :: xf_progsigma - real(kind=kind_phys), intent(inout), dimension (its:ite,10) :: forcing + real(kind=kind_phys), intent(in) , dimension (its:) :: aa1_bl,tau_ecmwf + real(kind=kind_phys), intent(inout), dimension (its:) :: xf_dicycle + real(kind=kind_phys), intent(out), dimension (its:) :: xf_progsigma + real(kind=kind_phys), intent(inout), dimension (its:,:) :: forcing !$acc declare copyin(aa1_bl,tau_ecmwf) copy(xf_dicycle,forcing) !- local var real(kind=kind_phys) :: xff_dicycle @@ -3151,7 +3157,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 ! pcrit,acrit,acritt integer, dimension (its:ite) :: kloc real(kind=kind_phys) :: & - a1,a_ave,xff0,xomg,gravinv!,aclim1,aclim2,aclim3,aclim4 + a1,a_ave,xff0,xomg,gravinv real(kind=kind_phys), dimension (its:ite) :: ens_adj !$acc declare create(kloc,ens_adj) @@ -3487,31 +3493,31 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & ! ! ierr error value, maybe modified in this routine ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & he_cup,hes_cup,p_cup !$acc declare copyin(he_cup,hes_cup,p_cup) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & entr_rate,ztexec,zqexec,cap_inc,cap_max !$acc declare copyin(entr_rate,ztexec,zqexec,cap_inc,cap_max) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & hkb !,cap_max !$acc declare copy(hkb) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kbmax !$acc declare copyin(kbmax) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & kbcon,k22,ierr !$acc declare copy(kbcon,k22,ierr) integer & ,intent (in ) :: & iloop_in - character*50 :: ierrc(its:ite) - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: z_cup,heo + character*50 :: ierrc(its:) + real(kind=kind_phys), dimension (its:,kts:),intent (in) :: z_cup,heo !$acc declare copyin(z_cup,heo) integer, dimension (its:ite) :: iloop,start_level !$acc declare create(iloop,start_level) @@ -3645,18 +3651,18 @@ subroutine cup_maximi(array,ks,ke,maxx,ierr, & ! x output array with return values ! kt output array of levels ! ks,kend check-range - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & array !$acc declare copyin(array) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & ierr,ke !$acc declare copyin(ierr,ke) integer & ,intent (in ) :: & ks - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (out ) :: & maxx !$acc declare copyout(maxx) @@ -3708,15 +3714,15 @@ subroutine cup_minimi(array,ks,kend,kt,ierr, & ! x output array with return values ! kt output array of levels ! ks,kend check-range - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & array !$acc declare copyin(array) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & ierr,ks,kend !$acc declare copyin(ierr,ks,kend) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (out ) :: & kt !$acc declare copyout(kt) @@ -3771,10 +3777,10 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & ! z = heights of model levels ! ierr error value, maybe modified in this routine ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & z,zu,gamma_cup,t_cup,dby - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kbcon,ktop !$acc declare copyin(z,zu,gamma_cup,t_cup,dby,kbcon,ktop) @@ -3783,11 +3789,11 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & ! - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copy(ierr) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & aa0 !$acc declare copyout(aa0) @@ -3830,15 +3836,15 @@ 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 + integer, dimension (its: ), intent(in ) :: ktop - real(kind=kind_phys), dimension (its:ite,kts:kte ) , & + real(kind=kind_phys), dimension (its:,kts: ) , & intent(inout ) :: & outq,outt,outqc,outu,outv - real(kind=kind_phys), dimension (its:ite,kts:kte ) , & + real(kind=kind_phys), dimension (its:,kts: ) , & intent(inout ) :: & q - real(kind=kind_phys), dimension (its:ite ) , & + real(kind=kind_phys), dimension (its: ) , & intent(inout ) :: & pret !$acc declare copy(outq,outt,outqc,outu,outv,q,pret) @@ -3979,38 +3985,38 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! pw = pw -epsilon*pd (ensemble dependent) ! ierr error value, maybe modified in this routine ! - real(kind=kind_phys), dimension (its:ite,1:maxens3) & + real(kind=kind_phys), dimension (its:,:) & ,intent (inout) :: & xf_ens,pr_ens - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout ) :: & outtem,outq,outqc - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & zu,pwd,p_cup - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & sig,xmbm_in,xmbs_in,edt,sigmab,dx - real(kind=kind_phys), dimension (its:ite,2) & + real(kind=kind_phys), dimension (its:,:) & ,intent (in ) :: & xff_mid - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & pre,xmb - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & closure_n - real(kind=kind_phys), dimension (its:ite,kts:kte,1) & + real(kind=kind_phys), dimension (its:,kts:,:) & ,intent (in ) :: & dellat,dellaqc,dellaq,pw - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & ktop,xland1 - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr,ierr2,ierr3 integer, intent(in) :: dicycle - real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle, xf_progsigma + real(kind=kind_phys), intent(in), dimension (its:) :: xf_dicycle, xf_progsigma !$acc declare copyin(zu,pwd,p_cup,sig,xmbm_in,xmbs_in,edt,xff_mid,dellat,dellaqc,dellaq,pw,ktop,xland1,xf_dicycle) !$acc declare copy(xf_ens,pr_ens,outtem,outq,outqc,pre,xmb,closure_n,ierr,ierr2,ierr3) ! @@ -4248,15 +4254,15 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! zu = normalized updraft mass flux ! gamma_cup = gamma on model cloud levels ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,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) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & zqexec,c0 ! entr= entrainment rate - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kbcon,ktop,k22,xland1 !$acc declare copyin(p_cup,rho,q,zu,gamma_cup,qe_cup,up_massentr,up_massdetr,dby,qes_cup,z_cup,zqexec,c0,kbcon,ktop,k22,xland1) @@ -4268,7 +4274,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! ierr error value, maybe modified in this routine - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copy(ierr) @@ -4281,11 +4287,11 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! pwav = totan normalized integrated condensate (i1) ! c0 = conversion rate (cloud to rain) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (out ) :: & qc,qrc,pw,clw_all !$acc declare copy(qc,qrc,pw,clw_all) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout) :: & c1d !$acc declare copy(c1d) @@ -4295,11 +4301,11 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & real(kind=kind_phys), dimension (its:ite) :: & pwavh !$acc declare create(pwavh) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & pwav,psum,psumh !$acc declare copyout(pwav,psum,psumh) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & ccn !$acc declare copyin(ccn) @@ -4329,7 +4335,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & is_deep = (name == 'deep') !$acc kernels - prop_b(kts:kte)=0 + prop_b(kts:)=0 !$acc end kernels iall=0 clwdet=0.1 !0.02 @@ -4429,7 +4435,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! !now do the rest ! - kklev(i)=maxloc(zu(i,:),1) + kklev(i)=maxloc(zu(i,2:ktop(i)),1) !$acc loop seq do k=kbcon(i)+1,ktop(i) if(t(i,k) > 273.16) then @@ -4489,6 +4495,8 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & endif if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) if(k.gt.kbcon(i)+1)c1d_b(i,k)=clwdet*up_massdetr(i,k-1) + c1d(i,k)=0.005 + c1d_b(i,k)=0.005 if(autoconv.eq.2) then ! @@ -4646,11 +4654,11 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo 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 + real(kind=kind_phys), dimension (its:,kts:),intent (inout) :: entr_rate_2d,zuo + real(kind=kind_phys), dimension (its:,kts:),intent (in) ::p_cup, heo,heso_cup,z_cup + real(kind=kind_phys), dimension (its:),intent (in) :: hkbo,rand_vmas + integer, dimension (its:),intent (in) :: kstabi,k22,kpbl,csum,xland,pmin_lev + integer, dimension (its:),intent (inout) :: kbcon,ierr,ktop,ktopdby !$acc declare copy(entr_rate_2d,zuo,kbcon,ierr,ktop,ktopdby) & !$acc copyin(p_cup, heo,heso_cup,z_cup,hkbo,rand_vmas,kstabi,k22,kpbl,csum,xland,pmin_lev) @@ -4737,7 +4745,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo ktop(i)= 0 else call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,1,ierr(i),k22(i), & - kfinalzu+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + kfinalzu+1,zuo(i,kts:),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! end deep if ( is_mid ) then @@ -4748,7 +4756,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo kfinalzu=ktop(i) ktopdby(i)=ktop(i)+1 call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,3, & - ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! mid if ( is_shallow ) then @@ -4759,7 +4767,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo kfinalzu=ktop(i) ktopdby(i)=ktop(i)+1 call get_zu_zd_pdf_fim(kbcon(i),p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,2,ierr(i),k22(i), & - ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + ktopdby(i)+1,zuo(i,kts:),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! shal @@ -4782,8 +4790,8 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k 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), intent(inout) :: zu(kts:) + real(kind=kind_phys), intent(in) :: p(kts:) real(kind=kind_phys) :: trash,beta_deep,zuh(kts:kte),zuh2(1:40) integer, intent(inout) :: ierr integer, intent(in) ::draft @@ -5057,20 +5065,20 @@ subroutine cup_up_aa1bl(aa0,t,tn,q,qo,dtime, & ! z = heights of model levels ! ierr error value, maybe modified in this routine ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & z_cup,zu,gamma_cup,t_cup,dby,t,tn,q,qo - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kbcon,ktop real(kind=kind_phys), intent(in) :: dtime ! ! input and output ! - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & aa0 ! @@ -5107,14 +5115,14 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay implicit none integer ,intent (in ) :: itf,ktf,its,ite,kts,kte - integer, dimension (its:ite) ,intent (in ) :: ierr,kstart,kend + integer, dimension (its:) ,intent (in ) :: ierr,kstart,kend !$acc declare copyin(ierr,kstart,kend) integer, dimension (its:ite) :: kend_p3 !$acc declare create(kend_p3) - real(kind=kind_phys), dimension (its:ite,kts:kte), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup - real(kind=kind_phys), dimension (its:ite,kts:kte), intent (out) :: dtempdz - integer, dimension (its:ite,kts:kte), intent (out) :: k_inv_layers + real(kind=kind_phys), dimension (its:,kts:), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup + real(kind=kind_phys), dimension (its:,kts:), intent (out) :: dtempdz + integer, dimension (its:,kts:), intent (out) :: k_inv_layers !$acc declare copyin(p_cup,t_cup,z_cup,qo_cup,qeso_cup) !$acc declare copyout(dtempdz,k_inv_layers) !-local vars @@ -5308,15 +5316,15 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte implicit none integer, intent (in) :: draft integer, intent(in):: itf,ktf, its,ite, kts,kte - integer, intent(in) , dimension(its:ite) :: ierr,ktop,kbcon,k22 + integer, intent(in) , dimension(its:) :: ierr,ktop,kbcon,k22 !$acc declare copyin(ierr,ktop,kbcon,k22) - !real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau - real(kind=kind_phys), intent(inout), optional , dimension(its:ite):: lambau - real(kind=kind_phys), intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo - real(kind=kind_phys), intent(inout), dimension(its:ite,kts:kte) :: cd,entr_rate_2d - real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte) :: up_massentro, up_massdetro & + !real(kind=kind_phys), intent(in), optional , dimension(its:):: lambau + real(kind=kind_phys), intent(inout), optional , dimension(its:):: lambau + real(kind=kind_phys), intent(in) , dimension(its:,kts:) :: zo_cup,zuo + real(kind=kind_phys), intent(inout), dimension(its:,kts:) :: cd,entr_rate_2d + real(kind=kind_phys), intent( out), dimension(its:,kts:) :: up_massentro, up_massdetro & ,up_massentr, up_massdetr - real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte), optional :: & + real(kind=kind_phys), intent( out), dimension(its:,kts:), optional :: & up_massentru,up_massdetru !$acc declare copy(lambau,cd,entr_rate_2d) copyin(zo_cup,zuo) copyout(up_massentro, up_massdetro,up_massentr, up_massdetr) !$acc declare copyout(up_massentro, up_massdetro,up_massentr, up_massdetr, up_massentru,up_massdetru) @@ -5437,10 +5445,10 @@ subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer 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 + real(kind=kind_phys), intent (in ), dimension(its:,kts:) :: tn,po_cup + real(kind=kind_phys), intent (inout), dimension(its:,kts:) :: p_liq_ice,melting_layer !$acc declare copyin(tn,po_cup) copy(p_liq_ice,melting_layer) - integer , intent (in ), dimension(its:ite) :: ierr + integer , intent (in ), dimension(its:) :: ierr !$acc declare copyin(ierr) integer :: i,k real(kind=kind_phys) :: dp @@ -5539,11 +5547,11 @@ subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco 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 & + integer ,intent (in ), dimension(its:) :: ierr + real(kind=kind_phys) ,intent (in ), dimension(its:) :: edto + real(kind=kind_phys) ,intent (in ), dimension(its:,kts:) :: tn_cup,po_cup,qrco,pwo & ,pwdo,p_liq_ice,melting_layer - real(kind=kind_phys) ,intent (inout), dimension(its:ite,kts:kte) :: melting + real(kind=kind_phys) ,intent (inout), dimension(its:,kts:) :: melting !$acc declare copyin(ierr,edto,tn_cup,po_cup,qrco,pwo,pwdo,p_liq_ice,melting_layer,melting) integer :: i,k real(kind=kind_phys) :: dp @@ -5615,13 +5623,13 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c 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:,kts:),intent (inout) :: entr_rate_2d,zuo + real(kind=kind_phys), dimension (its:,kts:),intent (in) ::p_cup, heo,heso_cup,z_cup + real(kind=kind_phys), dimension (its:),intent (in) :: hkbo + integer, dimension (its:),intent (in) :: kstabi,k22,kbcon,kpbl,klcl + integer, dimension (its:),intent (inout) :: ierr,ktop !$acc declare copy(entr_rate_2d,zuo,ierr,ktop) copyin(p_cup, heo,heso_cup,z_cup,hkbo,kstabi,k22,kbcon,kpbl,klcl) - real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot + real(kind=kind_phys), dimension (its:,kts:) :: hcot !$acc declare create(hcot) character *(*), intent (in) :: name real(kind=kind_phys) :: dz,dh, dbythresh @@ -5644,7 +5652,7 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c kfinalzu=ktf-2 ktop(i)=kfinalzu if(ierr(i).eq.0)then - dby (kts:kte)=0.0 + dby (kts:)=0.0 start_level(i)=kbcon(i) !-- hcot below kbcon @@ -5704,16 +5712,16 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, implicit none logical, intent(in) :: progsigma integer, intent(in) :: itf,its,ktf,ite,kts,kte - integer, dimension (its:ite), intent(inout) :: ierr - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: zo,entr_rate_2d, & + integer, dimension (its:), intent(inout) :: ierr + real(kind=kind_phys), dimension (its:,kts:),intent (in) :: zo,entr_rate_2d, & cd,po,qeso,to,qo,dbyo,clw_all,qlk,delp,zu - integer, dimension (its:ite),intent(in) :: k22,kbcon,ktcon + integer, dimension (its:),intent(in) :: k22,kbcon,ktcon real(kind=kind_phys), dimension (its:ite) :: sumx real(kind=kind_phys) ,intent (in) :: fv,rd,el2orc real(kind=kind_phys), dimension (its:ite,kts:kte) :: drag, buo, zi, del - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (out) :: wu2,omega_u, & + real(kind=kind_phys), dimension (its:,kts:),intent (out) :: wu2,omega_u, & zeta,zdqca - real(kind=kind_phys), dimension (its:ite),intent(out) :: wc,omegac + real(kind=kind_phys), dimension (its:),intent(out) :: wc,omegac real(kind=kind_phys) :: rho,bb1,bb2,dz,dp,ptem,tem1,ptem1,tem,rfact,gamma,val integer :: i,k diff --git a/physics/cu_c3_driver.F90 b/physics/CONV/C3/cu_c3_driver.F90 similarity index 94% rename from physics/cu_c3_driver.F90 rename to physics/CONV/C3/cu_c3_driver.F90 index fd4d37b0b..c911ff5e4 100644 --- a/physics/cu_c3_driver.F90 +++ b/physics/CONV/C3/cu_c3_driver.F90 @@ -30,7 +30,8 @@ module cu_c3_driver !! \htmlinclude cu_c3_driver_init.html !! subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, & - imfdeepcnv_c3,mpirank, mpiroot, errmsg, errflg) + imfdeepcnv_c3,progsigma, cnx, mpirank, mpiroot, & + errmsg, errflg) implicit none @@ -38,6 +39,8 @@ subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, & integer, intent(in) :: imfdeepcnv, imfdeepcnv_c3 integer, intent(in) :: mpirank integer, intent(in) :: mpiroot + integer, intent(in) :: cnx + logical, intent(inout) :: progsigma character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -45,6 +48,13 @@ subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, & errmsg = '' errflg = 0 + if(progsigma)then + if(cnx < 384)then + progsigma=.false. + write(*,*)'Forcing prognostic closure to .false. due to coarse resolution' + endif + endif + end subroutine cu_c3_driver_init ! @@ -60,7 +70,8 @@ end subroutine cu_c3_driver_init subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& do_ca,progsigma,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, & forceqv_spechum,phil,delp,raincv,tmf,qmicro,sigmain, & - qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & + betascu,betamcu,betadcu,qv_spechum,t,cld1d,us,vs,t2di,w, & + qv2di_spechum,p2di,psuri, & hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw,ca_deep,rainevap,& pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & @@ -96,10 +107,10 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & - do_ca,progsigma - real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v + do_ca + real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v,betascu,betamcu,betadcu logical, intent(in ) :: ldiag3d - + logical, intent(in ) :: progsigma real(kind=kind_phys), intent(inout) :: dtend(:,:,:) !$acc declare copy(dtend) integer, intent(in) :: dtidx(:,:), & @@ -340,8 +351,8 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! !> - Set tuning constants for radiation coupling ! - tun_rad_shall(:)=.01 - tun_rad_mid(:)=.3 !.02 + tun_rad_shall(:)=.012 + tun_rad_mid(:)=.15 !.02 tun_rad_deep(:)=.3 !.065 edt(:)=0. edtm(:)=0. @@ -587,7 +598,7 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& hfx(i)=hfx2(i)*cp*rhoi(i,1) qfx(i)=qfx2(i)*xlv*rhoi(i,1) dx(i) = sqrt(garea(i)) - enddo + enddo do i=its,itf do k=kts,kpbli(i) @@ -644,7 +655,6 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& enddo !$acc end kernels if (dx(its)<6500.) then - ichoice=10 imid_gf=0 endif ! @@ -670,7 +680,8 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & ! Prog closure flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, & - forceqv_spechum,sigmain,sigmaout,progsigma,dx, & + forceqv_spechum,betascu,betamcu,betadcu,sigmain, & + sigmaout,progsigma,dx, & ! output tendencies outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & ! dimesnional variables @@ -680,10 +691,6 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& do i=its,itf if(xmbs(i).gt.0.)then cutens(i)=1. - if (dx(i)<6500.) then - ierrm(i)=555 - ierr (i)=555 - endif endif enddo !$acc end kernels @@ -719,6 +726,9 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,tmfq & ,qmicro & ,forceqv_spechum & + ,betascu & + ,betamcu & + ,betadcu & ,sigmain & ,sigmaout & ,ter11 & @@ -810,6 +820,9 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,tmfq & ,qmicro & ,forceqv_spechum & + ,betascu & + ,betamcu & + ,betadcu & ,sigmain & ,sigmaout & ,ter11 & @@ -954,38 +967,6 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !gdc(i,k,8)=(outq(i,k))*86400.*xlv/cp gdc(i,k,8)=(outqm(i,k)+outqs(i,k)+outq(i,k))*86400.*xlv/cp gdc(i,k,9)=gdc(i,k,2)+gdc(i,k,3)+gdc(i,k,4) -! -!> - Calculate subsidence effect on clw -! -! dsubclw=0. -! dsubclwm=0. -! dsubclws=0. -! dp=100.*(p2d(i,k)-p2d(i,k+1)) -! if (clcw(i,k) .gt. -999.0 .and. clcw(i,k+1) .gt. -999.0 )then -! clwtot = cliw(i,k) + clcw(i,k) -! clwtot1= cliw(i,k+1) + clcw(i,k+1) -! dsubclw=((-edt(i)*zd(i,k+1)+zu(i,k+1))*clwtot1 & -! -(-edt(i)*zd(i,k) +zu(i,k)) *clwtot )*g/dp -! dsubclwm=((-edtm(i)*zdm(i,k+1)+zum(i,k+1))*clwtot1 & -! -(-edtm(i)*zdm(i,k) +zum(i,k)) *clwtot )*g/dp -! dsubclws=(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp -! dsubclw=dsubclw+(zu(i,k+1)*clwtot1-zu(i,k)*clwtot)*g/dp -! dsubclwm=dsubclwm+(zum(i,k+1)*clwtot1-zum(i,k)*clwtot)*g/dp -! dsubclws=dsubclws+(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp -! endif -! tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & -! +outqcm(i,k)*cutenm(i) & -! +dsubclw*xmb(i)+dsubclws*xmbs(i)+dsubclwm*xmbm(i) & -! ) -! tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) -! if (clcw(i,k) .gt. -999.0) then -! cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice -! clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water -! else -! cliw(i,k) = max(0.,cliw(i,k) + tem) -! endif -! -! enddo !> - FCT treats subsidence effect to cloud ice/water (begin) dp=100.*(p2d(i,k)-p2d(i,k+1)) @@ -1041,8 +1022,8 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc(i,16,10)=pret(i)*3600. maxupmf(i)=0. - if(forcing(i,6).gt.0.)then - maxupmf(i)=maxval(xmb(i)*zu(i,kts:ktf)/forcing(i,6)) + if(forcing2(i,6).gt.0.)then + maxupmf(i)=maxval(xmb(i)*zu(i,kts:ktf)/forcing2(i,6)) endif if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) diff --git a/physics/cu_c3_driver.meta b/physics/CONV/C3/cu_c3_driver.meta similarity index 94% rename from physics/cu_c3_driver.meta rename to physics/CONV/C3/cu_c3_driver.meta index 999b5c2bc..5677cdd32 100644 --- a/physics/cu_c3_driver.meta +++ b/physics/CONV/C3/cu_c3_driver.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = cu_c3_driver type = scheme - dependencies = cu_c3_deep.F90,cu_c3_sh.F90,machine.F,physcons.F90,progsigma_calc.f90 + dependencies = ../../hooks/machine.F + dependencies = cu_c3_deep.F90,cu_c3_sh.F90,../progsigma_calc.f90 ######################################################################## [ccpp-arg-table] @@ -49,6 +50,20 @@ dimensions = () type = integer intent = in +[progsigma] + standard_name = do_prognostic_updraft_area_fraction + long_name = flag for prognostic sigma in cumuls scheme + units = flag + dimensions = () + type = logical + intent = inout +[cnx] + standard_name = number_of_x_points_for_current_cubed_sphere_tile + long_name = number of points in x direction for this cubed sphere face + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -244,6 +259,29 @@ type = real kind = kind_phys intent = out +[betascu] + standard_name = tuning_param_for_shallow_cu + long_name = tuning param for shallow cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betamcu] + standard_name = tuning_param_for_midlevel_cu + long_name = tuning param for midlevel cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betadcu] + standard_name = tuning_param_for_deep_cu + long_name = tuning param for deep cu in case prognostic closure is used + units = none + dimensions = () + type = real + intent = in [phil] standard_name = geopotential long_name = layer geopotential diff --git a/physics/cu_c3_driver_post.F90 b/physics/CONV/C3/cu_c3_driver_post.F90 similarity index 92% rename from physics/cu_c3_driver_post.F90 rename to physics/CONV/C3/cu_c3_driver_post.F90 index 74957a6b2..d5d2dee3b 100644 --- a/physics/cu_c3_driver_post.F90 +++ b/physics/CONV/C3/cu_c3_driver_post.F90 @@ -66,20 +66,19 @@ subroutine cu_c3_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m conv_act_m(i)=0.0 endif ! reflectivity parameterization for parameterized convection (reference:Unipost MDLFLD.f) - if(sqrt(garea(i)).lt.6500.)then ze = 0.0 ze_conv = 0.0 dbz_sum = 0.0 - cuprate = raincv(i) * 3600.0 / dt ! cu precip rate (mm/h) - ze_conv = 300.0 * cuprate**1.4 - if (maxupmf(i).gt.0.05) then + cuprate = 1.e3*raincv(i) * 3600.0 / dt ! cu precip rate (mm/h) + if(cuprate .lt. 0.05) cuprate=0. + ze_conv = 300.0 * cuprate**1.5 + if (maxupmf(i).gt.0.1 .and. cuprate.gt.0.) then do k = 1, km ze = 10._kind_phys ** (0.1 * refl_10cm(i,k)) dbz_sum = max(dbzmin, 10.0 * log10(ze + ze_conv)) refl_10cm(i,k) = dbz_sum enddo endif - endif enddo !$acc end kernels diff --git a/physics/cu_c3_driver_post.meta b/physics/CONV/C3/cu_c3_driver_post.meta similarity index 98% rename from physics/cu_c3_driver_post.meta rename to physics/CONV/C3/cu_c3_driver_post.meta index c53972f09..78dca2ed4 100644 --- a/physics/cu_c3_driver_post.meta +++ b/physics/CONV/C3/cu_c3_driver_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_c3_driver_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_c3_driver_pre.F90 b/physics/CONV/C3/cu_c3_driver_pre.F90 similarity index 100% rename from physics/cu_c3_driver_pre.F90 rename to physics/CONV/C3/cu_c3_driver_pre.F90 diff --git a/physics/cu_c3_driver_pre.meta b/physics/CONV/C3/cu_c3_driver_pre.meta similarity index 98% rename from physics/cu_c3_driver_pre.meta rename to physics/CONV/C3/cu_c3_driver_pre.meta index c018bee9f..a022cf743 100644 --- a/physics/cu_c3_driver_pre.meta +++ b/physics/CONV/C3/cu_c3_driver_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_c3_driver_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_c3_sh.F90 b/physics/CONV/C3/cu_c3_sh.F90 similarity index 95% rename from physics/cu_c3_sh.F90 rename to physics/CONV/C3/cu_c3_sh.F90 index 0ea0f28ae..736292092 100644 --- a/physics/cu_c3_sh.F90 +++ b/physics/CONV/C3/cu_c3_sh.F90 @@ -6,12 +6,12 @@ module cu_c3_sh use progsigma, only : progsigma_calc !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 - real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 real(kind=kind_phys), parameter:: g =9.81 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) :: c0_shal=.004 + real(kind=kind_phys) :: c1_shal=0. !0.005! .0005 real(kind=kind_phys), parameter:: fluxtune=1.5 contains @@ -68,7 +68,8 @@ subroutine cu_c3_sh_run ( & hfx,qfx,xland,ichoice,tcrit,dtime, & zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & - forceqv_spechum,sigmain,sigmaout,progsigma,dx, & + forceqv_spechum,betascu,betamcu,betadcu,sigmain,& + sigmaout,progsigma,dx, & outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! output tendencies itf,ktf,its,ite, kts,kte,ipr,tropics) ! dimesnional variables ! @@ -95,23 +96,23 @@ subroutine cu_c3_sh_run ( & ! outq = output q tendency (per s) ! outqc = output qc tendency (per s) ! pre = output precip - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout ) :: & cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv !$acc declare copy(cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & tmf, qmicro, sigmain, forceqv_spechum - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & xmb_out - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout ) :: & ierr - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (out ) :: & kbcon,ktop,k22 - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kpbl,tropics !$acc declare copyout(xmb_out,kbcon,ktop,k22) copyin(kpbl,tropics) copy(ierr) @@ -119,21 +120,21 @@ subroutine cu_c3_sh_run ( & ! 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) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & t,po,tn,dhdt,rho,us,vs,delp - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout) :: & q,qo - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & xland,z1,psur,hfx,qfx,dx real(kind=kind_phys) & ,intent (in ) :: & - dtime,tcrit,fv,r_d + dtime,tcrit,fv,r_d,betascu,betamcu,betadcu !$acc declare sigmaout - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (out) :: & sigmaout @@ -234,18 +235,21 @@ subroutine cu_c3_sh_run ( & !$acc cap_max_increment,lambau, & !$acc kstabi,xland1,kbmax,ktopx) - logical :: flag_shallow + logical :: flag_shallow,flag_mid logical, dimension(its:ite) :: cnvflg integer :: & kstart,i,k,ki - real(kind=kind_phys) :: & + real(kind=kind_phys) :: & dz,mbdt,zkbmax, & cap_maxs,trash,trash2,frh,el2orc,gravinv - real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas + real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas + real(kind=kind_phys) :: & + sigmind,sigminm,sigmins + parameter(sigmind=0.005,sigmins=0.03,sigminm=0.01) real(kind=kind_phys) xff_shal(3),blqe,xkshal - character*50 :: ierrc(its:ite) + character*50 :: ierrc(its:) real(kind=kind_phys), dimension (its:ite,kts:kte) :: & up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru !$acc declare create(up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru) @@ -274,6 +278,8 @@ subroutine cu_c3_sh_run ( & ktopx(i)=0 if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then xland1(i)=0 + c0_shal=.001 + c1_shal=.001 ! ierr(i)=100 endif pre(i)=0. @@ -669,14 +675,14 @@ subroutine cu_c3_sh_run ( & if(qco(i,k)>=trash ) then dz=z_cup(i,k)-z_cup(i,k-1) ! cloud liquid water - c1d(i,k)=.02*up_massdetr(i,k-1) + c1d(i,k)=c1_shal! 0. !.02*up_massdetr(i,k-1) + clw_all(i,k)=max(0._kind_phys,qco(i,k)-trash) qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1d(i,k))*dz) if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 qrco(i,k)=0. - c1d(i,k)=0. + !c1d(i,k)=0. endif pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) - clw_all(i,k)=qco(i,k)-trash !LB total cloud before rain and detrain ! cloud water vapor qco (i,k)= trash+qrco(i,k) @@ -958,6 +964,7 @@ subroutine cu_c3_sh_run ( & ! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then flag_shallow = .true. + flag_mid = .false. do k=kts,ktf do i=its,itf del(i,k) = delp(i,k)*0.001 @@ -972,9 +979,9 @@ subroutine cu_c3_sh_run ( & endif enddo call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, & - del,tmf,qmicro,dbyo,zdqca,omega_u,zeta,xlv,dtime, & - forceqv_spechum,kbcon,ktop,cnvflg, & - sigmain,sigmaout,sigmab) + flag_mid,del,tmf,qmicro,dbyo,zdqca,omega_u,zeta,xlv,dtime, & + forceqv_spechum,kbcon,ktop,cnvflg,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif diff --git a/physics/cs_conv.F90 b/physics/CONV/Chikira_Sugiyama/cs_conv.F90 similarity index 100% rename from physics/cs_conv.F90 rename to physics/CONV/Chikira_Sugiyama/cs_conv.F90 diff --git a/physics/cs_conv.meta b/physics/CONV/Chikira_Sugiyama/cs_conv.meta similarity index 99% rename from physics/cs_conv.meta rename to physics/CONV/Chikira_Sugiyama/cs_conv.meta index fae1c91fe..49e460ed6 100644 --- a/physics/cs_conv.meta +++ b/physics/CONV/Chikira_Sugiyama/cs_conv.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = cs_conv type = scheme - dependencies = funcphys.f90,machine.F,physcons.F90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/cs_conv_aw_adj.F90 b/physics/CONV/Chikira_Sugiyama/cs_conv_aw_adj.F90 similarity index 100% rename from physics/cs_conv_aw_adj.F90 rename to physics/CONV/Chikira_Sugiyama/cs_conv_aw_adj.F90 diff --git a/physics/cs_conv_aw_adj.meta b/physics/CONV/Chikira_Sugiyama/cs_conv_aw_adj.meta similarity index 99% rename from physics/cs_conv_aw_adj.meta rename to physics/CONV/Chikira_Sugiyama/cs_conv_aw_adj.meta index 0dada0fd5..54350dbac 100644 --- a/physics/cs_conv_aw_adj.meta +++ b/physics/CONV/Chikira_Sugiyama/cs_conv_aw_adj.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cs_conv_aw_adj type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cs_conv_post.F90 b/physics/CONV/Chikira_Sugiyama/cs_conv_post.F90 similarity index 100% rename from physics/cs_conv_post.F90 rename to physics/CONV/Chikira_Sugiyama/cs_conv_post.F90 diff --git a/physics/cs_conv_post.meta b/physics/CONV/Chikira_Sugiyama/cs_conv_post.meta similarity index 97% rename from physics/cs_conv_post.meta rename to physics/CONV/Chikira_Sugiyama/cs_conv_post.meta index 116ffbef4..75de3fca7 100644 --- a/physics/cs_conv_post.meta +++ b/physics/CONV/Chikira_Sugiyama/cs_conv_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = cs_conv_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cs_conv_pre.F90 b/physics/CONV/Chikira_Sugiyama/cs_conv_pre.F90 similarity index 100% rename from physics/cs_conv_pre.F90 rename to physics/CONV/Chikira_Sugiyama/cs_conv_pre.F90 diff --git a/physics/cs_conv_pre.meta b/physics/CONV/Chikira_Sugiyama/cs_conv_pre.meta similarity index 99% rename from physics/cs_conv_pre.meta rename to physics/CONV/Chikira_Sugiyama/cs_conv_pre.meta index 2decd5f8b..7ce80496b 100644 --- a/physics/cs_conv_pre.meta +++ b/physics/CONV/Chikira_Sugiyama/cs_conv_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cs_conv_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_gf_deep.F90 b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 similarity index 96% rename from physics/cu_gf_deep.F90 rename to physics/CONV/Grell_Freitas/cu_gf_deep.F90 index 1b30063bd..a1bca36c9 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 @@ -3,6 +3,7 @@ module cu_gf_deep use machine , only : kind_phys + use physcons, only : qamin real(kind=kind_phys), parameter::g=9.81 real(kind=kind_phys), parameter:: cp=1004. real(kind=kind_phys), parameter:: xlv=2.5e6 @@ -124,6 +125,11 @@ subroutine cu_gf_deep_run( & ,frh_out & ! fractional coverage ,ierr & ! ierr flags are error flags, used for debugging ,ierrc & ! the following should be set to zero if not available + ,nchem & + ,fscav & + ,chem3d & + ,wetdpc_deep & + ,do_smoke_transport & ,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 @@ -144,7 +150,7 @@ subroutine cu_gf_deep_run( & ,intent (in ) :: & nranflag,itf,ktf,its,ite, kts,kte,ipr,imid integer, intent (in ) :: & - ichoice + ichoice,nchem real(kind=kind_phys), dimension (its:ite,4) & ,intent (in ) :: rand_clos real(kind=kind_phys), dimension (its:ite) & @@ -163,17 +169,17 @@ subroutine cu_gf_deep_run( & ! outq = output q tendency (per s) ! outqc = output qc tendency (per s) ! pre = output precip - real(kind=kind_phys), dimension (its:ite,kts:kte) & + 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) & + real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & frh_out - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & pre,xmb_out !$acc declare copy(cnvwt,outu,outv,outt,outq,outqc,cupclw,frh_out,pre,xmb_out) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & hfx,qfx,xmbm_in,xmbs_in !$acc declare copyin(hfx,qfx,xmbm_in,xmbs_in) @@ -190,29 +196,36 @@ subroutine cu_gf_deep_run( & ! 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) & + real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & dhdt,rho,t,po,us,vs,tn !$acc declare copyin(dhdt,rho,t,po,us,vs,tn) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & omeg !$acc declare copy(omeg) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & q,qo,zuo,zdo,zdm !$acc declare copy(q,qo,zuo,zdo,zdm) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & dx,z1,psur,xland !$acc declare copyin(dx,z1,psur,xland) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & mconv,ccn !$acc declare copy(mconv,ccn) - - - real(kind=kind_phys) & + real(kind=kind_phys), dimension (:,:,:) & + ,intent (inout) :: & + chem3d + logical, intent (in) :: do_smoke_transport + real(kind=kind_phys), dimension (:,:) & + , intent (out) :: wetdpc_deep + real(kind=kind_phys), intent (in) :: fscav(:) +!$acc declare copy(chem3d) copyout(wetdpc_deep) copyin(fscav) + + real(kind=kind_phys) & ,intent (in ) :: & dtime,ccnclean @@ -220,11 +233,11 @@ subroutine cu_gf_deep_run( & ! ! local ensemble dependent variables in this routine ! - real(kind=kind_phys), dimension (its:ite,1) :: & + real(kind=kind_phys), dimension (its:ite,1) :: & xaa0_ens - real(kind=kind_phys), dimension (its:ite,1) :: & + real(kind=kind_phys), dimension (its:ite,1) :: & edtc - real(kind=kind_phys), dimension (its:ite,kts:kte,1) :: & + real(kind=kind_phys), dimension (its:ite,kts:kte,1) :: & dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens !$acc declare create(xaa0_ens,edtc,dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens) ! @@ -292,8 +305,20 @@ subroutine cu_gf_deep_run( & ! 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) :: & + real(kind=kind_phys), dimension (its:ite,kts:kte,nchem) :: & + chem + real(kind=kind_phys), dimension (its:ite,kts:kte,nchem) :: & + chem_cup,chem_up,chem_down,dellac,dellac2,chem_c,chem_pw,chem_pwd + real(kind=kind_phys), dimension (its:ite,nchem) :: & + chem_pwav,chem_psum + real(kind=kind_phys):: dtime_max,sum1,sum2 + real(kind=kind_phys), dimension (kts:kte) :: trac,trcflx_in,trcflx_out,trc,trco + real(kind=kind_phys), dimension (its:ite,kts:kte) :: pwdper, massflx + integer :: nv +!$acc declare create(chem,chem_cup,chem_up,chem_down,dellac,dellac2,chem_c,chem_pw,chem_pwd, & +!$acc chem_pwav,chem_psum,pwdper,massflux) + + 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, & @@ -330,13 +355,13 @@ subroutine cu_gf_deep_run( & ! 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, & + real(kind=kind_phys), dimension (its:ite) :: & + edt,edto,edtm,aa1,aa0,xaa0,hkb, & hkbo,xhkb, & xmb,pwavo,ccnloss, & pwevo,bu,bud,cap_max, & cap_max_increment,closure_n,psum,psumh,sig,sigd - real(kind=kind_phys), dimension (its:ite) :: & + real(kind=kind_phys), dimension (its:ite) :: & axx,edtmax,edtmin,entr_rate integer, dimension (its:ite) :: & kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & @@ -372,10 +397,10 @@ subroutine cu_gf_deep_run( & character*50 :: ierrc(its:ite) character*4 :: cumulus - real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + 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) :: & + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & up_massentru,up_massdetru,dd_massentru,dd_massdetru !$acc declare create(up_massentr,up_massdetr,c1d,up_massentro,up_massdetro,dd_massentro,dd_massdetro, & !$acc up_massentru,up_massdetru,dd_massentru,dd_massdetru) @@ -401,7 +426,8 @@ subroutine cu_gf_deep_run( & real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers real(kind=kind_phys), dimension (its:ite) :: c0 ! HCB -!$acc declare create(pmin_lev,start_level,ktopkeep,dtempdz,k_inv_layers,c0) + real(kind=kind_phys), dimension (its:ite,kts:kte) :: c0t3d ! hli for smoke/dust wet scavenging +!$acc declare create(pmin_lev,start_level,ktopkeep,dtempdz,k_inv_layers,c0,c0t3d) ! rainevap from sas real(kind=kind_phys) zuh2(40) @@ -1058,14 +1084,14 @@ subroutine cu_gf_deep_run( & if(imid.eq.1)then call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & p_cup,kbcon,ktop,dbyo,clw_all,xland1, & - qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0,c0t3d, & zqexec,ccn,ccnclean,rho,c1d,tn_cup,autoconv,up_massentr,up_massdetr,psum,psumh, & 1,itf,ktf, & its,ite, kts,kte) else call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & p_cup,kbcon,ktop,dbyo,clw_all,xland1, & - qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0,c0t3d, & zqexec,ccn,ccnclean,rho,c1d,tn_cup,autoconv,up_massentr,up_massdetr,psum,psumh, & 1,itf,ktf, & its,ite, kts,kte) @@ -2013,6 +2039,186 @@ subroutine cu_gf_deep_run( & kts,kte,ierr,kbcon,xmb,psur,xland,qo_cup, & po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) +! +! +!>- atmospheric composition tracers +! +!> ## Determine whether to perform aerosol transport + if (do_smoke_transport .and. nchem > 0) then +! +! initialize tracers if they exist +! + chem (:,:,:) = 0. +!$acc kernels + do nv = 1,nchem + do k = 1, ktf + do i = 1, itf + chem(i,k,nv) = max(qamin, chem3d(i,k,nv)) + enddo + enddo + enddo + + wetdpc_deep = 0. + + chem_pwav(:,:) = 0. + chem_psum(:,:) = 0. + chem_pw (:,:,:) = 0. + chem_pwd (:,:,:) = 0. + pwdper (:,:) = 0. + chem_down(:,:,:) = 0. + chem_up (:,:,:) = 0. + chem_c (:,:,:) = 0. + chem_cup (:,:,:) = 0. + + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,jmin(i) + if(pwavo(i).ne.0.) pwdper(i,k)=-edtc(i,1)*pwdo(i,k)/pwavo(i) + enddo + pwdper(i,:)=0. + do nv=1,nchem + do k=kts+1,ktf + chem_cup(i,k,nv)=.5*(chem(i,k-1,nv)+chem(i,k,nv)) + enddo + chem_cup(i,kts,nv)=chem(i,kts,nv) +! +! in updraft +! + do k=1,k22(i) + chem_up(i,k,nv)=chem_cup(i,k,nv) + enddo + do k=k22(i)+1,ktop(i) + chem_up(i,k,nv)=(chem_up(i,k-1,nv)*zuo(i,k-1) & + -.5*up_massdetr(i,k-1)*chem_up(i,k-1,nv)+ & + up_massentr(i,k-1)*chem(i,k-1,nv)) / & + (zuo(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + chem_c(i,k,nv)=fscav(nv)*chem_up(i,k,nv) + dz=zo_cup(i,K)-zo_cup(i,K-1) + trash2=chem_up(i,k,nv)-chem_c(i,k,nv) + trash=chem_c(i,k,nv)/(1.+c0t3d(i,k)*dz) + chem_pw=c0t3d(i,k)*dz*trash*zuo(i,k) + chem_up(i,k,nv)=trash2+trash + chem_pwav(i,nv)=chem_pwav(i,nv)+chem_pw(i,k,nv)! *g/dp + enddo + do k=ktop(i)+1,ktf + chem_up(i,k,nv)=chem_cup(i,k,nv) + enddo +! +! in downdraft +! + chem_down(i,jmin(i)+1,nv)=chem_cup(i,jmin(i)+1,nv) + chem_psum(i,nv)=0. + do ki=jmin(i),2,-1 + dp=100.*(po_cup(i,ki)-po_cup(i,ki+1)) + chem_down(i,ki,nv)=(chem_down(i,ki+1,nv)*zdo(i,ki+1) & + -.5_kind_phys*dd_massdetro(i,ki)*chem_down(i,ki+1,nv)+ & + dd_massentro(i,ki)*chem(i,ki,nv)) / & + (zdo(i,ki+1)-.5_kind_phys*dd_massdetro(i,ki)+dd_massentro(i,ki)) + chem_down(i,ki,nv)=chem_down(i,ki,nv)+pwdper(i,ki)*chem_pwav(i,nv) + chem_pwd(i,ki,nv)=max(0._kind_phys,pwdper(i,ki)*chem_pwav(i,nv)) + enddo +! total wet deposition + do k=1,ktf-1 + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + chem_psum(i,nv)=chem_psum(i,nv)+chem_pw(i,k,nv)*g !/dp + enddo + chem_psum(i,nv)=chem_psum(i,nv)*xmb(i)*dtime +! + enddo ! nchem + endif ! ierr=0 + enddo ! i + + dellac(:,:,:)=0. + + do nv=1,nchem + do i=its,itf + if(ierr(i).eq.0)then + dp=100.*(po_cup(i,1)-po_cup(i,2)) + dellac(i,1,nv)=dellac(i,1,nv)+(edto(i)*zdo(i,2)*chem_down(i,2,nv))*g/dp*xmb(i) + if(k22(i).eq.2)then + entupk=zuo(i,2) + dellac(i,1,nv)=dellac(i,1,nv)-entupk*chem_cup(i,2,nv)*g/dp*xmb(i) + endif + do k=kts+1,ktop(i)-1 + detup=0. + detdo=0. + entup=0. + entdo=0. + entdoj=0. + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + ! entrainment/detrainment for updraft + entdo=edto(i)*dd_massentro(i,k)*chem(i,k,nv) + detdo=edto(i)*dd_massdetro(i,k)*.5*(chem_down(i,k+1,nv)+chem_down(i,k,nv)) + entup=up_massentro(i,k)*chem(i,k,nv) + detup=up_massdetro(i,k)*.5*(chem_up(i,k+1,nv)+chem_up(i,k,nv)) + ! special levels + if(k == k22(i)-1) then + entup=zuo(i,k+1)*chem_cup(i,k+1,nv) + detup=0. + endif + if(k.eq.jmin(i))entdoj=edto(i)*zdo(i,k)*chem_cup(i,k,nv) +! mass budget + dellac(i,k,nv) =dellac(i,k,nv) + (detup+detdo-entdo-entup-entdoj)*g/dp*xmb(i) + enddo + dellac(i,ktop(i),nv)=zuo(i,ktop(i))*chem_up(i,ktop(i),nv)*g/dp*xmb(i) + endif ! ierr + enddo ! i + enddo ! nchem loop + +! fct for subsidence + dellac2(:,:,:)=0. + massflx(:,:)=0. + do nv=1,nchem +!$acc loop private(trcflx_in) + do i=its,itf + if(ierr(i).eq.0)then + trcflx_in(:)=0. + dtime_max=dtime + +! initialize fct routine + do k=kts,ktop(i) + dp=100._kind_phys*(po_cup(i,k)-po_cup(i,k+1)) + dtime_max=min(dtime_max,.5_kind_phys*dp) + massflx(i,k)=-xmb(i)*(zuo(i,k)-edto(i)*zdo(i,k)) + trcflx_in(k)=massflx(i,k)*chem_cup(i,k,nv) + enddo + trcflx_in(1)=0. + massflx(i,1)=0. + call fct1d3(ktop(i),kte,dtime_max,po_cup(i,:),chem(i,:,nv),massflx(i,:), & + trcflx_in,dellac2(i,:,nv),g) + do k=kts,ktop(i) + trash=chem (i,k,nv) + chem (i,k,nv)=chem (i,k,nv) + (dellac(i,k,nv)+dellac2(i,k,nv))*dtime + if(chem(i,k,nv).lt.qamin)then + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + wetdpc_deep(i,nv)=wetdpc_deep(i,nv)+(qamin-chem(i,k,nv))*dp/g/dtime + chem(i,k,nv)=qamin + endif + enddo + endif + + enddo ! i + enddo ! nchem loop + +!> - Store aerosol concentrations if present + do nv = 1, nchem + do i = 1, itf + do k = 1, ktf + if(ierr(i).eq.0) then + if (k <= ktop(i)) then + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + wetdpc_deep(i,nv)=wetdpc_deep(i,nv) + ((chem3d(i,k,nv)-chem(i,k,nv))*dp/(g*dtime)) + chem3d(i,k,nv) = chem(i,k,nv) + endif + endif + enddo + wetdpc_deep(i,nv)=max(wetdpc_deep(i,nv),qamin) + enddo + enddo +!$acc end kernels + + endif ! nchem > 0 + k=1 !$acc kernels do i=its,itf @@ -4101,7 +4307,7 @@ end subroutine cup_output_ens_3d !> Calculates moisture properties of the updraft. subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & p_cup,kbcon,ktop,dby,clw_all,xland1, & - q,gamma_cup,zu,qes_cup,k22,qe_cup,c0, & + q,gamma_cup,zu,qes_cup,k22,qe_cup,c0,c0t3d, & zqexec,ccn,ccnclean,rho,c1d,t,autoconv, & up_massentr,up_massdetr,psum,psumh, & itest,itf,ktf, & @@ -4137,11 +4343,13 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & zqexec,c0 + real(kind=kind_phys), dimension (its:ite,kts:kte), intent (out) :: c0t3d ! entr= entrainment rate integer, dimension (its:ite) & ,intent (in ) :: & kbcon,ktop,k22,xland1 !$acc declare copyin(p_cup,rho,q,zu,gamma_cup,qe_cup,up_massentr,up_massdetr,dby,qes_cup,z_cup,zqexec,c0,kbcon,ktop,k22,xland1) +!$acc declare copy(c0t3d) real(kind=kind_phys), intent (in ) :: & ! HCB ccnclean ! @@ -4218,6 +4426,9 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & c0_iceconv=0.01 c1d_b=c1d bdsp(:)=bdispm +!$acc kernels + c0t3d = 0. +!$acc end kernels ! !--- no precip for small clouds @@ -4288,6 +4499,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & else c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) endif + c0t3d(i,k)=c0t 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)) @@ -4320,6 +4532,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) endif if(is_mid)c0t=0.004 + c0t3d(i,k)=c0t if(autoconv .gt.1) c0t=c0(i) denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) @@ -4708,11 +4921,10 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(draft == 1) then lev_start=min(.9,.1+csum*.013) kb_adj=max(kb,2) - tunning=max(p(kklev+1),.5*(p(kpbli)+p(kt))) - tunning=p(kklev) -! tunning=p(kklev+1) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start -! tunning=.5*(p(kb_adj)+p(kt)) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +! trash is the depth of the cloud trash=-p(kt)+p(kb_adj) + tunning=p(kklev) + if(rand_vmas.ne.0.) tunning=p(kklev-1)+.1*rand_vmas*trash 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) diff --git a/physics/cu_gf_driver.F90 b/physics/CONV/Grell_Freitas/cu_gf_driver.F90 similarity index 94% rename from physics/cu_gf_driver.F90 rename to physics/CONV/Grell_Freitas/cu_gf_driver.F90 index f82569b99..92f8760b0 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_driver.F90 @@ -67,7 +67,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & maxupmf,maxMF,do_mynnedmf,ichoice_in,ichoicem_in,ichoice_s_in, & - errmsg,errflg) + spp_cu_deep,spp_wts_cu_deep,nchem,chem3d,fscav,wetdpc_deep, & + do_smoke_transport,errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -80,8 +81,12 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: ichoice=0 ! 0 2 5 13 8 integer :: ichoicem=13 ! 0 2 5 13 integer :: ichoice_s=3 ! 0 1 2 3 + integer, intent(in) :: spp_cu_deep ! flag for using SPP perturbations + real(kind_phys), dimension(:,:), intent(in) :: & + & spp_wts_cu_deep + real(kind=kind_phys) :: spp_wts_cu_deep_tmp - logical, intent(in) :: do_cap_suppress + logical, intent(in) :: do_cap_suppress, do_smoke_transport real(kind=kind_phys), parameter :: aodc0=0.14 real(kind=kind_phys), parameter :: aodreturn=30. real(kind=kind_phys) :: dts,fpi,fp @@ -90,7 +95,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: ishallow_g3 ! depend on imfshalcnv !------------------------------------------------------------- integer :: its,ite, jts,jte, kts,kte - integer, intent(in ) :: im,km,ntracer + integer, intent(in ) :: im,km,ntracer, nchem integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend @@ -149,7 +154,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, intent(in ) :: imfshalcnv integer, dimension(:), intent(inout) :: cactiv,cactiv_m -!$acc declare copy(cactiv,cactiv_m) + real(kind_phys), dimension(:), intent(in) :: fscav +!$acc declare copyin(fscav) + real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind_phys), dimension(:,:), intent(inout) :: wetdpc_deep +!$acc declare copy(cactiv,cactiv_m,chem3d,wetdpc_deep) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -174,19 +183,20 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& 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 + real(kind=kind_phys), dimension (im,nchem) :: wetdpc_mid integer, dimension (im) :: kbcon, ktop,ierr,ierrs,ierrm,kpbli integer, dimension (im) :: k22s,kbcons,ktops,k22,jmin,jminm integer, dimension (im) :: kbconm,ktopm,k22m !$acc declare create(k22_shallow,kbcon_shallow,ktop_shallow,rand_mom,rand_vmas, & -!$acc rand_clos,gdc,gdc2,ht,ccn_gf,ccn_m,dx,frhm,frhd, & +!$acc rand_clos,gdc,gdc2,ht,ccn_gf,ccn_m,dx,frhm,frhd,wetdpc_mid, & !$acc outt,outq,outqc,phh,subm,cupclw,cupclws, & !$acc dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm, & !$acc outts,outqs,outqcs,outu,outv,outus,outvs, & !$acc outtm,outqm,outqcm,submm,cupclwm, & !$acc cnvwt,cnvwts,cnvwtm,hco,hcdo,zdo,zdd,hcom,hcdom,zdom, & !$acc tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi, & -!$acc pret,prets,pretm,hexec,forcing,forcing2, & +!$acc pret,prets,pretm,hexec,forcing,forcing2,wetdpc_mid, & !$acc kbcon, ktop,ierr,ierrs,ierrm,kpbli, & !$acc k22s,kbcons,ktops,k22,jmin,jminm,kbconm,ktopm,k22m) @@ -313,9 +323,18 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! these should be coming in from outside ! ! cactiv(:) = 0 - rand_mom(:) = 0. - rand_vmas(:) = 0. - rand_clos(:,:) = 0. + if (spp_cu_deep == 0) then + rand_mom(:) = 0. + rand_vmas(:) = 0. + rand_clos(:,:) = 0. + else + do i=1,im + spp_wts_cu_deep_tmp=min(max(-1.0_kind_phys, spp_wts_cu_deep(i,1)),1.0_kind_phys) + rand_mom(i) = spp_wts_cu_deep_tmp + rand_vmas(i) = spp_wts_cu_deep_tmp + rand_clos(i,:) = spp_wts_cu_deep_tmp + end do + end if !$acc end kernels ! its=1 @@ -630,7 +649,6 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& enddo !$acc end kernels if (dx(its)<6500.) then - ichoice=10 imid_gf=0 endif ! @@ -730,11 +748,16 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,frhm & ,ierrm & ,ierrcm & + ,nchem & + ,fscav & + ,chem3d & + ,wetdpc_mid & + ,do_smoke_transport & ! 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 + ,spp_cu_deep & ! flag to what you want perturbed ! 1 = momentum transport ! 2 = normalized vertical mass flux profile ! 3 = closures @@ -812,11 +835,16 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,frhd & ,ierr & ,ierrc & + ,nchem & + ,fscav & + ,chem3d & + ,wetdpc_deep & + ,do_smoke_transport & ! 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 + ,spp_cu_deep & ! flag to what you want perturbed ! 1 = momentum transport ! 2 = normalized vertical mass flux profile ! 3 = closures @@ -914,38 +942,6 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !gdc(i,k,8)=(outq(i,k))*86400.*xlv/cp gdc(i,k,8)=(outqm(i,k)+outqs(i,k)+outq(i,k))*86400.*xlv/cp gdc(i,k,9)=gdc(i,k,2)+gdc(i,k,3)+gdc(i,k,4) -! -!> - Calculate subsidence effect on clw -! -! dsubclw=0. -! dsubclwm=0. -! dsubclws=0. -! dp=100.*(p2d(i,k)-p2d(i,k+1)) -! if (clcw(i,k) .gt. -999.0 .and. clcw(i,k+1) .gt. -999.0 )then -! clwtot = cliw(i,k) + clcw(i,k) -! clwtot1= cliw(i,k+1) + clcw(i,k+1) -! dsubclw=((-edt(i)*zd(i,k+1)+zu(i,k+1))*clwtot1 & -! -(-edt(i)*zd(i,k) +zu(i,k)) *clwtot )*g/dp -! dsubclwm=((-edtm(i)*zdm(i,k+1)+zum(i,k+1))*clwtot1 & -! -(-edtm(i)*zdm(i,k) +zum(i,k)) *clwtot )*g/dp -! dsubclws=(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp -! dsubclw=dsubclw+(zu(i,k+1)*clwtot1-zu(i,k)*clwtot)*g/dp -! dsubclwm=dsubclwm+(zum(i,k+1)*clwtot1-zum(i,k)*clwtot)*g/dp -! dsubclws=dsubclws+(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp -! endif -! tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & -! +outqcm(i,k)*cutenm(i) & -! +dsubclw*xmb(i)+dsubclws*xmbs(i)+dsubclwm*xmbm(i) & -! ) -! tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) -! if (clcw(i,k) .gt. -999.0) then -! cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice -! clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water -! else -! cliw(i,k) = max(0.,cliw(i,k) + tem) -! endif -! -! enddo !> - FCT treats subsidence effect to cloud ice/water (begin) dp=100.*(p2d(i,k)-p2d(i,k+1)) @@ -1001,8 +997,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc(i,16,10)=pret(i)*3600. maxupmf(i)=0. - if(forcing(i,6).gt.0.)then - maxupmf(i)=maxval(xmb(i)*zu(i,kts:ktf)/forcing(i,6)) + if(forcing2(i,6).gt.0.)then + maxupmf(i)=maxval(xmb(i)*zu(i,kts:ktf)/forcing2(i,6)) endif if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) diff --git a/physics/cu_gf_driver.meta b/physics/CONV/Grell_Freitas/cu_gf_driver.meta similarity index 91% rename from physics/cu_gf_driver.meta rename to physics/CONV/Grell_Freitas/cu_gf_driver.meta index 8b1a46e2d..fe9b4c375 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/CONV/Grell_Freitas/cu_gf_driver.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = cu_gf_driver type = scheme - dependencies = cu_gf_deep.F90,cu_gf_sh.F90,machine.F,physcons.F90 + dependencies = ../../hooks/machine.F + dependencies = cu_gf_deep.F90,cu_gf_sh.F90 ######################################################################## [ccpp-arg-table] @@ -597,6 +598,59 @@ dimensions = () type = integer intent = in +[spp_wts_cu_deep] + standard_name = spp_weights_for_cu_deep_scheme + long_name = spp weights for cu deep scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spp_cu_deep] + standard_name = control_for_deep_convection_spp_perturbations + long_name = control for deep convection spp perturbations + units = count + dimensions = () + type = integer + intent = in +[nchem] + standard_name = number_of_chemical_species_vertically_mixed + long_name = number of chemical species vertically mixed + units = count + dimensions = () + type = integer + intent = in +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_chemical_species_vertically_mixed) + type = real + kind = kind_phys + intent = inout +[fscav] + standard_name = smoke_dust_conv_wet_coef + long_name = smoke dust convetive wet scavanging coefficents + units = none + dimensions = (3) + type = real + kind = kind_phys + intent = in +[do_smoke_transport] + standard_name = do_smoke_conv_transport + long_name = flag for rrfs smoke convective transport + units = flag + dimensions = () + type = logical + intent = in +[wetdpc_deep] + standard_name = conv_wet_deposition_smoke_dust + long_name = convective wet removal of smoke and dust + units = kg kg-1 + dimensions = (horizontal_loop_extent,number_of_chemical_species_vertically_mixed) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cu_gf_driver_post.F90 b/physics/CONV/Grell_Freitas/cu_gf_driver_post.F90 similarity index 61% rename from physics/cu_gf_driver_post.F90 rename to physics/CONV/Grell_Freitas/cu_gf_driver_post.F90 index 56da0feba..6ed1321bc 100644 --- a/physics/cu_gf_driver_post.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_driver_post.F90 @@ -15,7 +15,7 @@ module cu_gf_driver_post !> \section arg_table_cu_gf_driver_post_run Argument Table !! \htmlinclude cu_gf_driver_post_run.html !! - subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m,dt, garea, raincv, maxupmf, refl_10cm, errmsg, errflg) + subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, rrfs_sd, ntsmoke, ntdust, ntcoarsepm, chem3d, gq0, errmsg, errflg) use machine, only: kind_phys @@ -25,25 +25,20 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m integer, intent(in) :: im, km real(kind_phys), intent(in) :: t(:,:) real(kind_phys), intent(in) :: q(:,:) - real(kind_phys), dimension(:),intent(in) :: garea real(kind_phys), intent(out) :: prevst(:,:) real(kind_phys), intent(out) :: prevsq(:,:) integer, intent(in) :: cactiv(:) integer, intent(in) :: cactiv_m(:) real(kind_phys), intent(out) :: conv_act(:) real(kind_phys), intent(out) :: conv_act_m(:) - ! for Radar reflectivity - real(kind_phys), intent(in) :: dt - real(kind_phys), intent(in) :: raincv(:), maxupmf(:) - real(kind_phys), intent(inout) :: refl_10cm(:,:) + logical, intent(in) :: rrfs_sd + integer, intent(in) :: ntsmoke, ntdust, ntcoarsepm + real(kind_phys), intent(inout) :: chem3d(:,:,:), gq0(:,:,:) character(len=*), intent(out) :: errmsg -!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) +!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m,chem3d,gq0) integer, intent(out) :: errflg ! Local variables - real(kind_phys), parameter :: dbzmin=-10.0 - real(kind_phys) :: cuprate - real(kind_phys) :: ze, ze_conv, dbz_sum integer :: i, k ! Initialize CCPP error handling variables @@ -65,22 +60,13 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m else conv_act_m(i)=0.0 endif - ! reflectivity parameterization for parameterized convection (reference:Unipost MDLFLD.f) - if(sqrt(garea(i)).lt.6500.)then - ze = 0.0 - ze_conv = 0.0 - dbz_sum = 0.0 - cuprate = raincv(i) * 3600.0 / dt ! cu precip rate (mm/h) - ze_conv = 300.0 * cuprate**1.4 - if (maxupmf(i).gt.0.05) then - do k = 1, km - ze = 10._kind_phys ** (0.1 * refl_10cm(i,k)) - dbz_sum = max(dbzmin, 10.0 * log10(ze + ze_conv)) - refl_10cm(i,k) = dbz_sum - enddo - endif - endif enddo + + if (rrfs_sd) then + gq0(:,:,ntsmoke ) = chem3d(:,:,1) + gq0(:,:,ntdust ) = chem3d(:,:,2) + gq0(:,:,ntcoarsepm) = chem3d(:,:,3) + endif !$acc end kernels end subroutine cu_gf_driver_post_run diff --git a/physics/cu_gf_driver_post.meta b/physics/CONV/Grell_Freitas/cu_gf_driver_post.meta similarity index 70% rename from physics/cu_gf_driver_post.meta rename to physics/CONV/Grell_Freitas/cu_gf_driver_post.meta index 48e762cb4..478d48987 100644 --- a/physics/cu_gf_driver_post.meta +++ b/physics/CONV/Grell_Freitas/cu_gf_driver_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_gf_driver_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -83,46 +83,34 @@ type = real kind = kind_phys intent = out -[dt] - standard_name = timestep_for_physics - long_name = physics time step - units = s +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection + units = flag dimensions = () - type = real - kind = kind_phys + type = logical intent = in -[garea] - standard_name = cell_area - long_name = grid cell area - units = m2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys +[ntsmoke] + standard_name = index_for_smoke_in_tracer_concentration_array + long_name = tracer index for smoke + units = index + dimensions = () + type = integer intent = in -[raincv] - standard_name = lwe_thickness_of_deep_convective_precipitation_amount - long_name = deep convective rainfall amount on physics timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys +[ntdust] + standard_name = index_for_dust_in_tracer_concentration_array + long_name = tracer index for dust + units = index + dimensions = () + type = integer intent = in -[maxupmf] - standard_name = maximum_convective_updraft_mass_flux - long_name = maximum convective updraft mass flux within a column - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys +[ntcoarsepm] + standard_name = index_for_coarse_particulate_matter_in_tracer_concentration_array + long_name = tracer index for coarse particulate matter + units = index + dimensions = () + type = integer intent = in -[refl_10cm] - standard_name = radar_reflectivity_10cm - long_name = instantaneous refl_10cm - units = dBZ - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -131,6 +119,22 @@ type = character kind = len=* intent = out +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_chemical_species_vertically_mixed) + type = real + kind = kind_phys + intent = inout +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout [errflg] standard_name = ccpp_error_code long_name = error code for error handling in CCPP diff --git a/physics/cu_gf_driver_pre.F90 b/physics/CONV/Grell_Freitas/cu_gf_driver_pre.F90 similarity index 83% rename from physics/cu_gf_driver_pre.F90 rename to physics/CONV/Grell_Freitas/cu_gf_driver_pre.F90 index 98cc76b95..7ff66be21 100644 --- a/physics/cu_gf_driver_pre.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_driver_pre.F90 @@ -17,6 +17,7 @@ module cu_gf_driver_pre !! subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & forcet, forceq, cactiv, cactiv_m, conv_act, conv_act_m, & + rrfs_sd, ntsmoke, ntdust, ntcoarsepm, chem3d, gq0, & errmsg, errflg) use machine, only: kind_phys @@ -25,6 +26,7 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, logical, intent(in) :: flag_init logical, intent(in) :: flag_restart + logical, intent(in) :: rrfs_sd integer, intent(in) :: kdt real(kind_phys), intent(in) :: fhour real(kind_phys), intent(in) :: dtp @@ -37,10 +39,12 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, real(kind_phys), intent(out) :: forceq(:,:) integer, intent(out) :: cactiv(:) integer, intent(out) :: cactiv_m(:) + integer, intent(in) :: ntsmoke, ntdust, ntcoarsepm !$acc declare copyout(forcet,forceq,cactiv,cactiv_m) real(kind_phys), intent(in) :: conv_act(:) real(kind_phys), intent(in) :: conv_act_m(:) -!$acc declare copyin(conv_act,conv_act_m) + real(kind_phys), intent(inout) :: chem3d(:,:,:), gq0(:,:,:) +!$acc declare copyin(conv_act,conv_act_m) copy(chem3d,gq0) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -77,6 +81,12 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, !$acc kernels cactiv(:)=nint(conv_act(:)) cactiv_m(:)=nint(conv_act_m(:)) + + if (rrfs_sd) then + chem3d(:,:,1) = gq0(:,:,ntsmoke) + chem3d(:,:,2) = gq0(:,:,ntdust) + chem3d(:,:,3) = gq0(:,:,ntcoarsepm) + endif !$acc end kernels end subroutine cu_gf_driver_pre_run diff --git a/physics/cu_gf_driver_pre.meta b/physics/CONV/Grell_Freitas/cu_gf_driver_pre.meta similarity index 73% rename from physics/cu_gf_driver_pre.meta rename to physics/CONV/Grell_Freitas/cu_gf_driver_pre.meta index 7fd66d19b..ff22f1583 100644 --- a/physics/cu_gf_driver_pre.meta +++ b/physics/CONV/Grell_Freitas/cu_gf_driver_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_gf_driver_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -122,6 +122,50 @@ type = real kind = kind_phys intent = in +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection + units = flag + dimensions = () + type = logical + intent = in +[ntsmoke] + standard_name = index_for_smoke_in_tracer_concentration_array + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust_in_tracer_concentration_array + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[ntcoarsepm] + standard_name = index_for_coarse_particulate_matter_in_tracer_concentration_array + long_name = tracer index for coarse particulate matter + units = index + dimensions = () + type = integer + intent = in +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_chemical_species_vertically_mixed) + type = real + kind = kind_phys + intent = inout +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cu_gf_sh.F90 b/physics/CONV/Grell_Freitas/cu_gf_sh.F90 similarity index 100% rename from physics/cu_gf_sh.F90 rename to physics/CONV/Grell_Freitas/cu_gf_sh.F90 diff --git a/physics/rascnv.F90 b/physics/CONV/RAS/rascnv.F90 similarity index 100% rename from physics/rascnv.F90 rename to physics/CONV/RAS/rascnv.F90 diff --git a/physics/rascnv.meta b/physics/CONV/RAS/rascnv.meta similarity index 99% rename from physics/rascnv.meta rename to physics/CONV/RAS/rascnv.meta index 5285c830f..f5a707ded 100644 --- a/physics/rascnv.meta +++ b/physics/CONV/RAS/rascnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rascnv type = scheme - dependencies = funcphys.f90,machine.F + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/samfaerosols.F b/physics/CONV/SAMF/samfaerosols.F similarity index 100% rename from physics/samfaerosols.F rename to physics/CONV/SAMF/samfaerosols.F diff --git a/physics/samfdeepcnv.f b/physics/CONV/SAMF/samfdeepcnv.f similarity index 99% rename from physics/samfdeepcnv.f rename to physics/CONV/SAMF/samfdeepcnv.f index 8a36fe34c..5853254c0 100644 --- a/physics/samfdeepcnv.f +++ b/physics/CONV/SAMF/samfdeepcnv.f @@ -83,7 +83,8 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys,mp_phys_mg,& & clam,c0s,c1,betal,betas,evef,pgcon,asolfac, & & do_ca, ca_closure, ca_entr, ca_trigger, nthresh,ca_deep, & - & rainevap,sigmain, sigmaout, errmsg,errflg) + & rainevap,sigmain,sigmaout,betadcu,betamcu,betascu, & + & maxMF, do_mynnedmf,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -99,15 +100,16 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:) real(kind=kind_phys), dimension(:), intent(in) :: fscav logical, intent(in) :: first_time_step,restart,hwrf_samfdeep, & - & progsigma - real(kind=kind_phys), intent(in) :: nthresh + & progsigma,do_mynnedmf + real(kind=kind_phys), intent(in) :: nthresh,betadcu,betamcu, & + & betascu real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & & tmf(:,:,:),q(:,:), prevsq(:,:) + real(kind=kind_phys), dimension (:), intent(in) :: maxMF real(kind=kind_phys), intent(out) :: rainevap(:) real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger - integer, intent(inout) :: kcnv(:) ! DH* TODO - check dimensions of qtr, ntr+2 correct? *DH real(kind=kind_phys), intent(inout) :: qtr(:,:,:), & @@ -213,8 +215,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! parameters for prognostic sigma closure real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km) - real(kind=kind_phys) gravinv,invdelt - logical flag_shallow + real(kind=kind_phys) gravinv,invdelt,sigmind,sigminm,sigmins + parameter(sigmind=0.01,sigmins=0.03,sigminm=0.01) + logical flag_shallow, flag_mid c physical parameters ! parameter(grav=grav,asolfac=0.958) ! parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) @@ -347,6 +350,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! do i=1,im cnvflg(i) = .true. + if(do_mynnedmf) then + if(maxMF(i).gt.0.)cnvflg(i)=.false. + endif sfcpbl(i) = sfclfac * hpbl(i) rn(i)=0. mbdt(i)=10. @@ -2930,10 +2936,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & enddo flag_shallow = .false. + flag_mid = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & qadv,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab) + & flag_mid,del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, + & delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu, + & sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. diff --git a/physics/samfdeepcnv.meta b/physics/CONV/SAMF/samfdeepcnv.meta similarity index 94% rename from physics/samfdeepcnv.meta rename to physics/CONV/SAMF/samfdeepcnv.meta index bed4d655d..2dbd4407c 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/CONV/SAMF/samfdeepcnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = samfdeepcnv type = scheme - dependencies = funcphys.f90,machine.F,samfaerosols.F,progsigma_calc.f90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,samfaerosols.F,../progsigma_calc.f90 ######################################################################## [ccpp-arg-table] @@ -450,6 +450,44 @@ type = real kind = kind_phys intent = out +[betascu] + standard_name = tuning_param_for_shallow_cu + long_name = tuning param for shallow cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betamcu] + standard_name = tuning_param_for_midlevel_cu + long_name = tuning param for midlevel cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betadcu] + standard_name = tuning_param_for_deep_cu + long_name = tuning param for deep cu in case prognostic closure is used + units = none + dimensions = () + type = real + intent = in +[maxMF] + standard_name = maximum_mass_flux + long_name = maximum mass flux within a column + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in [qlcn] standard_name = mass_fraction_of_convective_cloud_liquid_water long_name = mass fraction of convective cloud liquid water diff --git a/physics/samfshalcnv.f b/physics/CONV/SAMF/samfshalcnv.f similarity index 99% rename from physics/samfshalcnv.f rename to physics/CONV/SAMF/samfshalcnv.f index a7682342f..3869ea6ea 100644 --- a/physics/samfshalcnv.f +++ b/physics/CONV/SAMF/samfshalcnv.f @@ -57,7 +57,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & rn,kbot,ktop,kcnv,islimsk,garea, & & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, & & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal, & - & sigmain,sigmaout,errmsg,errflg) + & sigmain,sigmaout,betadcu,betamcu,betascu,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -67,7 +67,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & integer, intent(in) :: im, km, itc, ntc, ntk, ntr, ncloud integer, intent(in) :: islimsk(:) real(kind=kind_phys), intent(in) :: cliq, cp, cvap, & - & eps, epsm1, fv, grav, hvap, rd, rv, t0c + & eps, epsm1, fv, grav, hvap, rd, rv, t0c, betascu, betadcu, & + & betamcu real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), & @@ -159,8 +160,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km), & sigmab(im),qadv(im,km) - real(kind=kind_phys) gravinv,dxcrtas,invdelt - logical flag_shallow + real(kind=kind_phys) gravinv,dxcrtas,invdelt,sigmind,sigmins, + & sigminm + logical flag_shallow,flag_mid c physical parameters ! parameter(g=grav,asolfac=0.89) ! parameter(g=grav) @@ -194,7 +196,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & parameter(betaw=.03,dxcrtc0=9.e3) parameter(h1=0.33333333) ! progsigma - parameter(dxcrtas=30.e3) + parameter(dxcrtas=30.e3,sigmind=0.01,sigmins=0.03,sigminm=0.01) c local variables and arrays real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), & uo(im,km), vo(im,km), qeso(im,km), @@ -1974,10 +1976,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo flag_shallow = .true. + flag_mid = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & qadv,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab) + & flag_mid,del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, + & delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu, + & sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity. diff --git a/physics/samfshalcnv.meta b/physics/CONV/SAMF/samfshalcnv.meta similarity index 94% rename from physics/samfshalcnv.meta rename to physics/CONV/SAMF/samfshalcnv.meta index c1fffef58..4b913a05d 100644 --- a/physics/samfshalcnv.meta +++ b/physics/CONV/SAMF/samfshalcnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = samfshalcnv type = scheme - dependencies = funcphys.f90,machine.F,samfaerosols.F,progsigma_calc.f90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,samfaerosols.F,../progsigma_calc.f90 ######################################################################## [ccpp-arg-table] @@ -482,6 +482,29 @@ type = real kind = kind_phys intent = out +[betascu] + standard_name = tuning_param_for_shallow_cu + long_name = tuning param for shallow cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betamcu] + standard_name = tuning_param_for_midlevel_cu + long_name = tuning param for midlevel cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betadcu] + standard_name = tuning_param_for_deep_cu + long_name = tuning param for deep cu in case prognostic closure is used + units = none + dimensions = () + type = real + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sascnvn.F b/physics/CONV/SAS/sascnvn.F similarity index 100% rename from physics/sascnvn.F rename to physics/CONV/SAS/sascnvn.F diff --git a/physics/sascnvn.meta b/physics/CONV/SAS/sascnvn.meta similarity index 99% rename from physics/sascnvn.meta rename to physics/CONV/SAS/sascnvn.meta index 66e5161ad..fefa2823a 100644 --- a/physics/sascnvn.meta +++ b/physics/CONV/SAS/sascnvn.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = sascnvn type = scheme - dependencies = funcphys.f90,machine.F + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/shalcnv.F b/physics/CONV/SAS/shalcnv.F similarity index 100% rename from physics/shalcnv.F rename to physics/CONV/SAS/shalcnv.F diff --git a/physics/shalcnv.meta b/physics/CONV/SAS/shalcnv.meta similarity index 99% rename from physics/shalcnv.meta rename to physics/CONV/SAS/shalcnv.meta index f554201c5..15324ed08 100644 --- a/physics/shalcnv.meta +++ b/physics/CONV/SAS/shalcnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = shalcnv type = scheme - dependencies = funcphys.f90,machine.F + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_ntiedtke.F90 b/physics/CONV/nTiedtke/cu_ntiedtke.F90 similarity index 100% rename from physics/cu_ntiedtke.F90 rename to physics/CONV/nTiedtke/cu_ntiedtke.F90 diff --git a/physics/cu_ntiedtke.meta b/physics/CONV/nTiedtke/cu_ntiedtke.meta similarity index 99% rename from physics/cu_ntiedtke.meta rename to physics/CONV/nTiedtke/cu_ntiedtke.meta index dded8fb20..b425a80ad 100644 --- a/physics/cu_ntiedtke.meta +++ b/physics/CONV/nTiedtke/cu_ntiedtke.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_ntiedtke type = scheme - dependencies = machine.F,physcons.F90 + dependencies = ../../hooks/machine.F,../../hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_ntiedtke_post.F90 b/physics/CONV/nTiedtke/cu_ntiedtke_post.F90 similarity index 100% rename from physics/cu_ntiedtke_post.F90 rename to physics/CONV/nTiedtke/cu_ntiedtke_post.F90 diff --git a/physics/cu_ntiedtke_post.meta b/physics/CONV/nTiedtke/cu_ntiedtke_post.meta similarity index 97% rename from physics/cu_ntiedtke_post.meta rename to physics/CONV/nTiedtke/cu_ntiedtke_post.meta index 703d32b90..9960b6b77 100644 --- a/physics/cu_ntiedtke_post.meta +++ b/physics/CONV/nTiedtke/cu_ntiedtke_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_ntiedtke_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_ntiedtke_pre.F90 b/physics/CONV/nTiedtke/cu_ntiedtke_pre.F90 similarity index 100% rename from physics/cu_ntiedtke_pre.F90 rename to physics/CONV/nTiedtke/cu_ntiedtke_pre.F90 diff --git a/physics/cu_ntiedtke_pre.meta b/physics/CONV/nTiedtke/cu_ntiedtke_pre.meta similarity index 98% rename from physics/cu_ntiedtke_pre.meta rename to physics/CONV/nTiedtke/cu_ntiedtke_pre.meta index ccb9b7f48..26392f0e6 100644 --- a/physics/cu_ntiedtke_pre.meta +++ b/physics/CONV/nTiedtke/cu_ntiedtke_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_ntiedtke_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/progsigma_calc.f90 b/physics/CONV/progsigma_calc.f90 similarity index 88% rename from physics/progsigma_calc.f90 rename to physics/CONV/progsigma_calc.f90 index c87308602..469df49f6 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/CONV/progsigma_calc.f90 @@ -19,10 +19,10 @@ module progsigma !! This subroutine computes a prognostic updraft area fracftion !! used in the closure computations in the samfshalcnv. scheme !!\section gen_progsigma progsigma_calc General Algorithm - subroutine progsigma_calc (im,km,flag_init,flag_restart, & - flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & - delt,qadv,kbcon1,ktcon,cnvflg,sigmain,sigmaout, & - sigmab) + subroutine progsigma_calc (im,km,flag_init,flag_restart,flag_shallow,& + flag_mid,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & + delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) ! ! use machine, only : kind_phys @@ -32,11 +32,12 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent in integer, intent(in) :: im,km,kbcon1(im),ktcon(im) - real(kind=kind_phys), intent(in) :: hvap,delt + real(kind=kind_phys), intent(in) :: hvap,delt,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins real(kind=kind_phys), intent(in) :: qadv(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km) - logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow + logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow,flag_mid real(kind=kind_phys), intent(in) :: sigmain(im,km) ! intent out @@ -53,15 +54,13 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & fdqb,dtdyn,dxlim,rmulacvg,tem, & - DEN,betascu,betadcu,dp1,invdelt + DEN,dp1,invdelt !Parameters gcvalmx = 0.1 rmulacvg=10. epsilon=1.E-11 km1=km-1 - betadcu = 2.0 - betascu = 8.0 invdelt = 1./delt !Initialization 2D @@ -206,17 +205,27 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do i= 1, im if(cnvflg(i)) then sigmab(i)=sigmab(i)/betascu - sigmab(i)=MAX(0.03,sigmab(i)) + sigmab(i)=MAX(sigmins,sigmab(i)) + endif + enddo + elseif(flag_mid)then + do i= 1, im + if(cnvflg(i)) then + sigmab(i)=sigmab(i)/betamcu + sigmab(i)=MAX(sigminm,sigmab(i)) endif enddo else do i= 1, im if(cnvflg(i)) then sigmab(i)=sigmab(i)/betadcu - sigmab(i)=MAX(0.01,sigmab(i)) + sigmab(i)=MAX(sigmind,sigmab(i)) endif enddo endif + do i= 1, im + sigmab(i) = MIN(0.95,sigmab(i)) + enddo end subroutine progsigma_calc diff --git a/physics/GFS_suite_stateout_update.F90 b/physics/GFS_suite_stateout_update.F90 deleted file mode 100644 index 2771c3e82..000000000 --- a/physics/GFS_suite_stateout_update.F90 +++ /dev/null @@ -1,63 +0,0 @@ -!> \file GFS_suite_stateout_update.f90 -!! Contains code to update the state variables due to process-split physics from accumulated tendencies during that phase. -!! Also, set bounds on the mass-weighted rime factor when using Ferrier-Aligo microphysics. - - module GFS_suite_stateout_update - - contains - -!> \section arg_table_GFS_suite_stateout_update_run Argument Table -!! \htmlinclude GFS_suite_stateout_update_run.html -!! - subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & - tgrs, ugrs, vgrs, qgrs, dudt, dvdt, dtdt, dqdt, & - gt0, gu0, gv0, gq0, ntiw, nqrimef, imp_physics, & - imp_physics_fer_hires, epsq, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in ) :: im - integer, intent(in ) :: levs - integer, intent(in ) :: ntrac - integer, intent(in ) :: imp_physics,imp_physics_fer_hires - integer, intent(in ) :: ntiw, nqrimef - real(kind=kind_phys), intent(in ) :: dtp, epsq - - real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs - real(kind=kind_phys), intent(in ), dimension(:,:) :: dudt, dvdt, dtdt - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: dqdt - real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0 - real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp - gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp - gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp - gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp - - if (imp_physics == imp_physics_fer_hires) then - do k=1,levs - do i=1,im - if(gq0(i,k,ntiw) > epsq) then - gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) - else - gq0(i,k,nqrimef) = 1. - end if - end do - end do - end if - - end subroutine GFS_suite_stateout_update_run - - end module GFS_suite_stateout_update \ No newline at end of file diff --git a/physics/cires_orowam2017.f b/physics/GWD/cires_orowam2017.f similarity index 100% rename from physics/cires_orowam2017.f rename to physics/GWD/cires_orowam2017.f diff --git a/physics/cires_tauamf_data.F90 b/physics/GWD/cires_tauamf_data.F90 similarity index 100% rename from physics/cires_tauamf_data.F90 rename to physics/GWD/cires_tauamf_data.F90 diff --git a/physics/cires_ugwp.F90 b/physics/GWD/cires_ugwp.F90 similarity index 100% rename from physics/cires_ugwp.F90 rename to physics/GWD/cires_ugwp.F90 diff --git a/physics/cires_ugwp.meta b/physics/GWD/cires_ugwp.meta similarity index 99% rename from physics/cires_ugwp.meta rename to physics/GWD/cires_ugwp.meta index d944a635e..cd0192ca7 100644 --- a/physics/cires_ugwp.meta +++ b/physics/GWD/cires_ugwp.meta @@ -3,7 +3,7 @@ type = scheme # DH* 20200804 - this is a result of the nasty hack to call gwdps from within ugwp-v0! dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 - dependencies=cires_orowam2017.f,cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F + dependencies=cires_orowam2017.f,cires_ugwp_module.F90,gwdps.f,../hooks/machine.F,ugwp_driver_v0.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cires_ugwp_initialize.F90 b/physics/GWD/cires_ugwp_initialize.F90 similarity index 100% rename from physics/cires_ugwp_initialize.F90 rename to physics/GWD/cires_ugwp_initialize.F90 diff --git a/physics/cires_ugwp_module.F90 b/physics/GWD/cires_ugwp_module.F90 similarity index 100% rename from physics/cires_ugwp_module.F90 rename to physics/GWD/cires_ugwp_module.F90 diff --git a/physics/cires_ugwp_post.F90 b/physics/GWD/cires_ugwp_post.F90 similarity index 100% rename from physics/cires_ugwp_post.F90 rename to physics/GWD/cires_ugwp_post.F90 diff --git a/physics/cires_ugwp_post.meta b/physics/GWD/cires_ugwp_post.meta similarity index 99% rename from physics/cires_ugwp_post.meta rename to physics/GWD/cires_ugwp_post.meta index 5add9d43f..dabc40082 100644 --- a/physics/cires_ugwp_post.meta +++ b/physics/GWD/cires_ugwp_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cires_ugwp_post type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cires_ugwp_triggers.F90 b/physics/GWD/cires_ugwp_triggers.F90 similarity index 100% rename from physics/cires_ugwp_triggers.F90 rename to physics/GWD/cires_ugwp_triggers.F90 diff --git a/physics/cires_ugwpv1_initialize.F90 b/physics/GWD/cires_ugwpv1_initialize.F90 similarity index 100% rename from physics/cires_ugwpv1_initialize.F90 rename to physics/GWD/cires_ugwpv1_initialize.F90 diff --git a/physics/cires_ugwpv1_module.F90 b/physics/GWD/cires_ugwpv1_module.F90 similarity index 100% rename from physics/cires_ugwpv1_module.F90 rename to physics/GWD/cires_ugwpv1_module.F90 diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/GWD/cires_ugwpv1_oro.F90 similarity index 100% rename from physics/cires_ugwpv1_oro.F90 rename to physics/GWD/cires_ugwpv1_oro.F90 diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/GWD/cires_ugwpv1_solv2.F90 similarity index 100% rename from physics/cires_ugwpv1_solv2.F90 rename to physics/GWD/cires_ugwpv1_solv2.F90 diff --git a/physics/cires_ugwpv1_sporo.F90 b/physics/GWD/cires_ugwpv1_sporo.F90 similarity index 100% rename from physics/cires_ugwpv1_sporo.F90 rename to physics/GWD/cires_ugwpv1_sporo.F90 diff --git a/physics/cires_ugwpv1_triggers.F90 b/physics/GWD/cires_ugwpv1_triggers.F90 similarity index 100% rename from physics/cires_ugwpv1_triggers.F90 rename to physics/GWD/cires_ugwpv1_triggers.F90 diff --git a/physics/drag_suite.F90 b/physics/GWD/drag_suite.F90 similarity index 97% rename from physics/drag_suite.F90 rename to physics/GWD/drag_suite.F90 index 22f122e71..ff68f4216 100644 --- a/physics/drag_suite.F90 +++ b/physics/GWD/drag_suite.F90 @@ -460,6 +460,8 @@ subroutine drag_suite_run( & real(kind=kind_phys), parameter :: ce = 0.8 real(kind=kind_phys), parameter :: cg = 0.5 real(kind=kind_phys), parameter :: sgmalolev = 0.5 ! max sigma lvl for dtfac + real(kind=kind_phys), parameter :: plolevmeso = 70.0 ! pres lvl for mesosphere OGWD reduction (Pa) + real(kind=kind_phys), parameter :: facmeso = 0.5 ! fractional velocity reduction for OGWD integer,parameter :: kpblmin = 2 ! @@ -472,7 +474,7 @@ subroutine drag_suite_run( & rcsks,wdir,ti,rdz,tem2,dw2,shr2, & bvf2,rdelks,wtkbj,tem,gfobnv,hd,fro, & rim,temc,tem1,efact,temv,dtaux,dtauy, & - dtauxb,dtauyb,eng0,eng1 + dtauxb,dtauyb,eng0,eng1,ksmax,dtfac_meso ! logical :: ldrag(im),icrilv(im), & flag(im),kloop1(im) @@ -887,6 +889,14 @@ subroutine drag_suite_run( & ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 ldrag(i) = ldrag(i) .or. var_stoch(i) .le. 0.0 +! Check if mesoscale gravity waves will propagate vertically or be evanescent +! and not impart a drag force -- consider the maximum sub-grid horizontal +! topographic wavelength to be one-half the horizontal grid spacing -- calculate +! ksmax accordingly + ksmax = 4.0*pi/dx(i) ! based on wavelength = 0.5*dx(i) + if ( bnv2(i,1).gt.0.0 ) then + ldrag(i) = ldrag(i) .or. sqrt(bnv2(i,1))*rulow(i).lt.ksmax + endif ! ! set all ri low level values to the low level value ! @@ -1106,7 +1116,19 @@ subroutine drag_suite_run( & enddo ! do k = kts,km - taud_ms(i,k) = taud_ms(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i)) + + ! Check if well into mesosphere -- if so, perform similar reduction of + ! velocity tendency due to mesoscale GWD to prevent sudden reversal of + ! wind direction (similar to above) + dtfac_meso = 1.0 + if (prsl(i,k).le.plolevmeso) then + if (taud_ms(i,k).ne.0.) & + dtfac_meso = min(dtfac_meso,facmeso*abs(velco(i,k) & + /(deltim*rcs*taud_ms(i,k)))) + end if + + taud_ms(i,k) = taud_ms(i,k)*dtfac(i)*dtfac_meso* & + ls_taper(i) *(1.-rstoch(i)) taud_bl(i,k) = taud_bl(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i)) dtaux = taud_ms(i,k) * xn(i) diff --git a/physics/drag_suite.meta b/physics/GWD/drag_suite.meta similarity index 99% rename from physics/drag_suite.meta rename to physics/GWD/drag_suite.meta index 66f320b98..94dddcc93 100644 --- a/physics/drag_suite.meta +++ b/physics/GWD/drag_suite.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = drag_suite type = scheme - dependencies = + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gwdc.f b/physics/GWD/gwdc.f similarity index 100% rename from physics/gwdc.f rename to physics/GWD/gwdc.f diff --git a/physics/gwdc.meta b/physics/GWD/gwdc.meta similarity index 99% rename from physics/gwdc.meta rename to physics/GWD/gwdc.meta index 341879b0b..9884d8a62 100644 --- a/physics/gwdc.meta +++ b/physics/GWD/gwdc.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = gwdc type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gwdc_post.f b/physics/GWD/gwdc_post.f similarity index 100% rename from physics/gwdc_post.f rename to physics/GWD/gwdc_post.f diff --git a/physics/gwdc_post.meta b/physics/GWD/gwdc_post.meta similarity index 99% rename from physics/gwdc_post.meta rename to physics/GWD/gwdc_post.meta index 25415b888..97649d4cf 100644 --- a/physics/gwdc_post.meta +++ b/physics/GWD/gwdc_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = gwdc_post type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gwdc_pre.f b/physics/GWD/gwdc_pre.f similarity index 100% rename from physics/gwdc_pre.f rename to physics/GWD/gwdc_pre.f diff --git a/physics/gwdc_pre.meta b/physics/GWD/gwdc_pre.meta similarity index 99% rename from physics/gwdc_pre.meta rename to physics/GWD/gwdc_pre.meta index 63df59cfa..55b0054bd 100644 --- a/physics/gwdc_pre.meta +++ b/physics/GWD/gwdc_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = gwdc_pre type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gwdps.f b/physics/GWD/gwdps.f similarity index 100% rename from physics/gwdps.f rename to physics/GWD/gwdps.f diff --git a/physics/gwdps.meta b/physics/GWD/gwdps.meta similarity index 99% rename from physics/gwdps.meta rename to physics/GWD/gwdps.meta index af60886ab..bbe7569d0 100644 --- a/physics/gwdps.meta +++ b/physics/GWD/gwdps.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = gwdps type = scheme - dependencies = + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/rayleigh_damp.f b/physics/GWD/rayleigh_damp.f similarity index 100% rename from physics/rayleigh_damp.f rename to physics/GWD/rayleigh_damp.f diff --git a/physics/rayleigh_damp.meta b/physics/GWD/rayleigh_damp.meta similarity index 99% rename from physics/rayleigh_damp.meta rename to physics/GWD/rayleigh_damp.meta index 63025bcff..525acbe8b 100644 --- a/physics/rayleigh_damp.meta +++ b/physics/GWD/rayleigh_damp.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rayleigh_damp type = scheme - dependencies = + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/ugwp_driver_v0.F b/physics/GWD/ugwp_driver_v0.F similarity index 100% rename from physics/ugwp_driver_v0.F rename to physics/GWD/ugwp_driver_v0.F diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/GWD/ugwpv1_gsldrag.F90 similarity index 100% rename from physics/ugwpv1_gsldrag.F90 rename to physics/GWD/ugwpv1_gsldrag.F90 diff --git a/physics/ugwpv1_gsldrag.meta b/physics/GWD/ugwpv1_gsldrag.meta similarity index 99% rename from physics/ugwpv1_gsldrag.meta rename to physics/GWD/ugwpv1_gsldrag.meta index 82caa8832..73d7eee1c 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/GWD/ugwpv1_gsldrag.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = ugwpv1_gsldrag type = scheme - dependencies = machine.F,drag_suite.F90 + dependencies = ../hooks/machine.F,drag_suite.F90 dependencies = cires_ugwpv1_module.F90,cires_ugwpv1_triggers.F90,cires_ugwpv1_initialize.F90,cires_ugwpv1_solv2.F90 dependencies = cires_ugwpv1_sporo.F90,cires_ugwpv1_oro.F90 ######################################################################## diff --git a/physics/ugwpv1_gsldrag_post.F90 b/physics/GWD/ugwpv1_gsldrag_post.F90 similarity index 100% rename from physics/ugwpv1_gsldrag_post.F90 rename to physics/GWD/ugwpv1_gsldrag_post.F90 diff --git a/physics/ugwpv1_gsldrag_post.meta b/physics/GWD/ugwpv1_gsldrag_post.meta similarity index 99% rename from physics/ugwpv1_gsldrag_post.meta rename to physics/GWD/ugwpv1_gsldrag_post.meta index f8766060c..e1c63102d 100644 --- a/physics/ugwpv1_gsldrag_post.meta +++ b/physics/GWD/ugwpv1_gsldrag_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = ugwpv1_gsldrag_post type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/unified_ugwp.F90 b/physics/GWD/unified_ugwp.F90 similarity index 100% rename from physics/unified_ugwp.F90 rename to physics/GWD/unified_ugwp.F90 diff --git a/physics/unified_ugwp.meta b/physics/GWD/unified_ugwp.meta similarity index 99% rename from physics/unified_ugwp.meta rename to physics/GWD/unified_ugwp.meta index 8af99957a..a08ee3960 100644 --- a/physics/unified_ugwp.meta +++ b/physics/GWD/unified_ugwp.meta @@ -1,10 +1,10 @@ [ccpp-table-properties] name = unified_ugwp type = scheme - - dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 - dependencies=cires_orowam2017.f, cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F - dependencies=drag_suite.F90 + dependencies = ../hooks/machine.F + dependencies = cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 + dependencies = cires_orowam2017.f,cires_ugwp_module.F90,gwdps.f,ugwp_driver_v0.F + dependencies = drag_suite.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/unified_ugwp_post.F90 b/physics/GWD/unified_ugwp_post.F90 similarity index 100% rename from physics/unified_ugwp_post.F90 rename to physics/GWD/unified_ugwp_post.F90 diff --git a/physics/unified_ugwp_post.meta b/physics/GWD/unified_ugwp_post.meta similarity index 99% rename from physics/unified_ugwp_post.meta rename to physics/GWD/unified_ugwp_post.meta index 6da6342df..7784c28ec 100644 --- a/physics/unified_ugwp_post.meta +++ b/physics/GWD/unified_ugwp_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = unified_ugwp_post type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_DCNV_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.F90 similarity index 95% rename from physics/GFS_DCNV_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.F90 index 51a228122..3b69849a7 100644 --- a/physics/GFS_DCNV_generic_post.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.F90 @@ -15,7 +15,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gq0, save_q, & cnvw, cnvc, cnvw_phy_f3d, cnvc_phy_f3d, flag_for_dcnv_generic_tend, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv, ntsigma, ntrac,clw, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrz, ntgz, nthz, ntsigma, ntrac,clw, & satmedmf, trans_trac, errmsg, errflg) @@ -44,8 +44,9 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & real(kind=kind_phys), dimension(:,:,:), intent(inout) :: dtend integer, intent(in) :: dtidx(:,:), index_of_process_dcnv, index_of_temperature, & index_of_x_wind, index_of_y_wind, ntqv - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv, ntsigma, ntrac + integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrz, ntgz, nthz, & + ntsigma, ntrac real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -112,6 +113,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntrz .and. n /= ntgz .and. n /= nthz .and. & n /= ntgv .and. n /= ntsigma) then tracers = tracers + 1 idtend = dtidx(100+n,index_of_process_dcnv) diff --git a/physics/GFS_DCNV_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.meta similarity index 95% rename from physics/GFS_DCNV_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.meta index 8428752ce..ab8982e11 100644 --- a/physics/GFS_DCNV_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_DCNV_generic_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -454,6 +454,27 @@ dimensions = () type = integer intent = in +[ntrz] + standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array + long_name = tracer index for rain reflectivity + units = index + dimensions = () + type = integer + intent = in +[ntgz] + standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel reflectivity + units = index + dimensions = () + type = integer + intent = in +[nthz] + standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array + long_name = tracer index for hail reflectivity + units = index + dimensions = () + type = integer + intent = in [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers diff --git a/physics/GFS_DCNV_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.F90 similarity index 93% rename from physics/GFS_DCNV_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.F90 index b31daf5d6..1dd3aafc7 100644 --- a/physics/GFS_DCNV_generic_pre.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.F90 @@ -13,7 +13,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc gu0, gv0, gt0, gq0, nsamftrac, ntqv, & save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv,ntsigma, & + ntgnc, nthl, nthnc, nthv, ntgv, & + ntrz, ntgz, nthz, ntsigma, & cscnv, satmedmf, trans_trac, ras, ntrac, & dtidx, index_of_process_dcnv, errmsg, errflg) @@ -22,7 +23,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc implicit none integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv,ntsigma + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv, & + ntrz, ntgz, nthz, ntsigma logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 @@ -68,6 +70,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntrz .and. n /= ntgz .and. n /= nthz .and. & n /= ntgv .and. n/= ntsigma) then tracers = tracers + 1 if(dtidx(100+n,index_of_process_dcnv)>0) then diff --git a/physics/GFS_DCNV_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.meta similarity index 93% rename from physics/GFS_DCNV_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.meta index ee2050926..ec1c59810 100644 --- a/physics/GFS_DCNV_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_DCNV_generic_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -267,6 +267,27 @@ dimensions = () type = integer intent = in +[ntrz] + standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array + long_name = tracer index for rain reflectivity + units = index + dimensions = () + type = integer + intent = in +[ntgz] + standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel reflectivity + units = index + dimensions = () + type = integer + intent = in +[nthz] + standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array + long_name = tracer index for hail reflectivity + units = index + dimensions = () + type = integer + intent = in [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers diff --git a/physics/GFS_GWD_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_post.F90 similarity index 100% rename from physics/GFS_GWD_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_post.F90 diff --git a/physics/GFS_GWD_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_post.meta similarity index 99% rename from physics/GFS_GWD_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_post.meta index 204c16c84..beca39282 100644 --- a/physics/GFS_GWD_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_GWD_generic_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_GWD_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_pre.F90 similarity index 100% rename from physics/GFS_GWD_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_pre.F90 diff --git a/physics/GFS_GWD_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_pre.meta similarity index 99% rename from physics/GFS_GWD_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_pre.meta index 9bcc03300..dbbfc261d 100644 --- a/physics/GFS_GWD_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_GWD_generic_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_MP_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 similarity index 90% rename from physics/GFS_MP_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 index 201c0e817..d9d30fb90 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 @@ -21,7 +21,8 @@ module GFS_MP_generic_post subroutine GFS_MP_generic_post_run( & im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_nssl, & imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rhowater, rainmin, dtf, & - frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, & + frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, phil, htop, refl_10cm, & + imfshalcnv,imfshalcnv_gf,imfdeepcnv,imfdeepcnv_gf,imfdeepcnv_samf, con_t0c, snow, graupel, save_t, save_q, & rain0, ice0, snow0, graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp,& totprcp, totice, totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, & pwat, frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, exticeden, & @@ -40,12 +41,13 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: imp_physics_nssl, iopt_lake_clm, iopt_lake, lkm logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, cpllnd, progsigma, exticeden integer, intent(in) :: index_of_temperature,index_of_process_mp,use_lake_model(:) - + integer, intent(in) :: imfshalcnv,imfshalcnv_gf,imfdeepcnv,imfdeepcnv_gf,imfdeepcnv_samf + integer, dimension (:), intent(in) :: htop integer :: dfi_radar_max_intervals - real(kind=kind_phys), intent(in) :: fh_dfi_radar(:), fhour + real(kind=kind_phys), intent(in) :: fh_dfi_radar(:), fhour, con_t0c real(kind=kind_phys), intent(in) :: radar_tten_limits(:) integer :: ix_dfi_radar(:) - real(kind=kind_phys), dimension(:,:), intent(inout) :: gt0 + real(kind=kind_phys), dimension(:,:), intent(inout) :: gt0,refl_10cm real(kind=kind_phys), intent(in) :: dtf, frain, con_g, rainmin, rhowater real(kind=kind_phys), dimension(:), intent(in) :: rain1, xlat, xlon, tsfc @@ -53,7 +55,7 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:), intent(in) :: rain0, ice0, snow0, graupel0 real(kind=kind_phys), dimension(:,:), intent(in) :: rann real(kind=kind_phys), dimension(:,:), intent(in) :: prsl, save_t, del - real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, phii + real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, phii,phil real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0, save_q real(kind=kind_phys), dimension(:,:,:), intent(in) :: dfi_radar_tten @@ -112,6 +114,17 @@ subroutine GFS_MP_generic_post_run( real :: snowrat,grauprat,icerat,curat,prcpncfr,prcpcufr real :: rhonewsnow,rhoprcpice,rhonewgr,rhonewice + real(kind_phys), parameter :: dbzmin=-20.0 + real(kind_phys) :: cuprate + real(kind_phys) :: ze, ze_conv, dbz_sum + + real(kind_phys), dimension(1:im,1:levs) :: zo + real(kind_phys), dimension(1:im) :: zfrz + real(kind_phys), dimension(1:im) :: factor + real(kind_phys) ze_mp, fctz, delz + logical :: lfrz + + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -121,6 +134,52 @@ subroutine GFS_MP_generic_post_run( do i = 1, im rain(i) = rainc(i) + frain * rain1(i) ! time-step convective plus explicit enddo +! +! Combine convective reflectivity with MP reflectivity for selected +! parameterizations. + if ( (imp_physics==imp_physics_thompson .or. imp_physics==imp_physics_nssl) .and. & + (imfdeepcnv==imfdeepcnv_samf .or. imfdeepcnv==imfdeepcnv_gf .or. imfshalcnv==imfshalcnv_gf) ) then + do i=1,im + factor(i) = 0.0 + lfrz = .true. + zfrz(i) = phil(i,1)*onebg + do k = levs, 1, -1 + zo(i,k) = phil(i,k)*onebg + if (gt0(i,k) >= con_t0c .and. lfrz) then + zfrz(i) = zo(i,k) + lfrz = .false. + endif + enddo + enddo +! + do i=1,im + if(rainc (i) > 0.0 .and. htop(i) > 0) then + factor(i) = -2./max(1000., zo(i,htop(i)) - zfrz(i)) + endif + enddo + +! combine the reflectivity from both Thompson MP and samfdeep convection + + do k=1,levs + do i=1,im + if(rainc(i) > 0. .and. k <= htop(i)) then + fctz = 0.0 + delz = zo(i,k) - zfrz(i) + if(delz <0.0) then + fctz = 1. ! wrong + else + fctz = 10.**(factor(i)*delz) + endif + cuprate = rainc(i) * 3.6e6 / dtp ! cu precip rate (mm/h) + ze_conv = 300.0 * cuprate**1.4 + ze_conv = fctz * ze_conv + ze_mp = 10._kind_phys ** (0.1 * refl_10cm(i,k)) + dbz_sum = max(DBZmin, 10.*log10(ze_mp + ze_conv)) + refl_10cm(i,k) = dbz_sum + endif + enddo + enddo + endif ! compute surface snowfall, graupel/sleet, freezing rain and precip ice density if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl ) then diff --git a/physics/GFS_MP_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta similarity index 93% rename from physics/GFS_MP_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta index 7cd2ca4b5..7f67aa925 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_MP_generic_post type = scheme - dependencies = calpreciptype.f90,machine.F + dependencies = ../../MP/calpreciptype.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -254,6 +254,72 @@ type = real kind = kind_phys intent = in +[phil] + standard_name = geopotential + long_name = layer geopotential + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[htop] + standard_name = vertical_index_at_cloud_top + long_name = index for cloud top + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[refl_10cm] + standard_name = radar_reflectivity_10cm + long_name = instantaneous refl_10cm + units = dBZ + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[imfshalcnv] + standard_name = control_for_shallow_convection_scheme + long_name = flag for mass-flux shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfshalcnv_gf] + standard_name = identifier_for_grell_freitas_shallow_convection + long_name = flag for Grell-Freitas shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_gf] + standard_name = identifier_for_grell_freitas_deep_convection + long_name = flag for Grell-Freitas deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [tsfc] standard_name = surface_skin_temperature long_name = surface skin temperature diff --git a/physics/GFS_MP_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_pre.F90 similarity index 100% rename from physics/GFS_MP_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_pre.F90 diff --git a/physics/GFS_MP_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_pre.meta similarity index 98% rename from physics/GFS_MP_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_pre.meta index a2a4947ef..6d5fd1538 100644 --- a/physics/GFS_MP_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_MP_generic_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_PBL_generic_common.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_common.F90 similarity index 100% rename from physics/GFS_PBL_generic_common.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_common.F90 diff --git a/physics/GFS_PBL_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.F90 similarity index 95% rename from physics/GFS_PBL_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.F90 index 0d13dc5d8..a4e5f172a 100644 --- a/physics/GFS_PBL_generic_post.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.F90 @@ -10,9 +10,9 @@ module GFS_PBL_generic_post !! subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev,nqrimef, & - trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, & + trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, & - imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, ltaerosol, mraerosol, nssl_hail_on, & + imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, ltaerosol, mraerosol, nssl_hail_on, nssl_3moment, & cplflx, cplaqm, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, & shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, & dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & @@ -30,12 +30,12 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, integer, parameter :: kp = kind_phys integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm, kdt integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef - integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: nssl_ccn_on, nssl_hail_on + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_3moment logical, intent(in) :: ltaerosol, cplflx, cplaqm, cplchm, lssav, ldiag3d, lsidea, use_med_flux, mraerosol logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu @@ -270,8 +270,16 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntgv) = dvdftra(i,k,14) dqdt(i,k,nthv) = dvdftra(i,k,15) dqdt(i,k,ntoz) = dvdftra(i,k,16) + n = 16 IF ( nssl_ccn_on ) THEN - dqdt(i,k,ntccn) = dvdftra(i,k,17) + dqdt(i,k,ntccn) = dvdftra(i,k,n+1) + n = n+1 + ENDIF + IF ( nssl_3moment ) THEN + dqdt(i,k,ntrz) = dvdftra(i,k,n+1) + dqdt(i,k,ntgz) = dvdftra(i,k,n+2) + dqdt(i,k,nthz) = dvdftra(i,k,n+3) + n = n+3 ENDIF enddo enddo @@ -292,9 +300,16 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntsnc) = dvdftra(i,k,10) dqdt(i,k,ntgnc) = dvdftra(i,k,11) dqdt(i,k,ntgv) = dvdftra(i,k,12) - dqdt(i,k,ntoz) = dvdftra(i,k,13) + dqdt(i,k,ntoz) = dvdftra(i,k,13) + n = 13 IF ( nssl_ccn_on ) THEN - dqdt(i,k,ntccn) = dvdftra(i,k,14) + dqdt(i,k,ntccn) = dvdftra(i,k,n+1) + n = n+1 + ENDIF + IF ( nssl_3moment ) THEN + dqdt(i,k,ntrz) = dvdftra(i,k,n+1) + dqdt(i,k,ntgz) = dvdftra(i,k,n+2) + n = n+2 ENDIF enddo enddo diff --git a/physics/GFS_PBL_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.meta similarity index 97% rename from physics/GFS_PBL_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.meta index b20142991..d49a885c5 100644 --- a/physics/GFS_PBL_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_PBL_generic_post type = scheme - dependencies = GFS_PBL_generic_common.F90,machine.F + dependencies = GFS_PBL_generic_common.F90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -211,6 +211,27 @@ dimensions = () type = integer intent = in +[ntrz] + standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array + long_name = tracer index for rain reflectivity + units = index + dimensions = () + type = integer + intent = in +[ntgz] + standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel reflectivity + units = index + dimensions = () + type = integer + intent = in +[nthz] + standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array + long_name = tracer index for hail reflectivity + units = index + dimensions = () + type = integer + intent = in [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -295,6 +316,13 @@ dimensions = () type = logical intent = in +[nssl_3moment] + standard_name = nssl_3moment + long_name = 3-moment activation flag in NSSL microphysics scheme + units = flag + dimensions = () + type = logical + intent = in [cplflx] standard_name = flag_for_surface_flux_coupling long_name = flag controlling cplflx collection (default off) diff --git a/physics/GFS_PBL_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.F90 similarity index 88% rename from physics/GFS_PBL_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.F90 index b9f7bb880..d8ed0f8fc 100644 --- a/physics/GFS_PBL_generic_pre.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.F90 @@ -12,10 +12,10 @@ module GFS_PBL_generic_pre subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & - ntccn, nthl, nthnc, ntgv, nthv, & + ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, imp_physics_nssl, & - ltaerosol, mraerosol, nssl_ccn_on, nssl_hail_on, & + ltaerosol, mraerosol, nssl_ccn_on, nssl_hail_on, nssl_3moment, & hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) @@ -29,13 +29,13 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, integer, intent(in) :: im, levs, nvdiff, ntrac integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm - integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz logical, intent(in) :: trans_aero, ldiag3d, qdiag3d, lssav integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend, mraerosol integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: nssl_hail_on, nssl_ccn_on + logical, intent(in) :: nssl_hail_on, nssl_ccn_on, nssl_3moment real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -215,15 +215,23 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, vdftra(i,k,7) = qgrs(i,k,nthl) vdftra(i,k,8) = qgrs(i,k,ntlnc) vdftra(i,k,9) = qgrs(i,k,ntinc) - vdftra(i,k,10) = qgrs(i,k,ntrnc) - vdftra(i,k,11) = qgrs(i,k,ntsnc) - vdftra(i,k,12) = qgrs(i,k,ntgnc) - vdftra(i,k,13) = qgrs(i,k,nthnc) - vdftra(i,k,14) = qgrs(i,k,ntgv) - vdftra(i,k,15) = qgrs(i,k,nthv) - vdftra(i,k,16) = qgrs(i,k,ntoz) + vdftra(i,k,10) = qgrs(i,k,ntrnc) + vdftra(i,k,11) = qgrs(i,k,ntsnc) + vdftra(i,k,12) = qgrs(i,k,ntgnc) + vdftra(i,k,13) = qgrs(i,k,nthnc) + vdftra(i,k,14) = qgrs(i,k,ntgv) + vdftra(i,k,15) = qgrs(i,k,nthv) + vdftra(i,k,16) = qgrs(i,k,ntoz) + n = 16 IF ( nssl_ccn_on ) THEN - vdftra(i,k,17) = qgrs(i,k,ntccn) + vdftra(i,k,n+1) = qgrs(i,k,ntccn) + n = n+1 + ENDIF + IF ( nssl_3moment ) THEN + vdftra(i,k,n+1) = qgrs(i,k,ntrz) + vdftra(i,k,n+2) = qgrs(i,k,ntgz) + vdftra(i,k,n+3) = qgrs(i,k,nthz) + n = n+3 ENDIF enddo enddo @@ -241,12 +249,19 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, vdftra(i,k,7) = qgrs(i,k,ntlnc) vdftra(i,k,8) = qgrs(i,k,ntinc) vdftra(i,k,9) = qgrs(i,k,ntrnc) - vdftra(i,k,10) = qgrs(i,k,ntsnc) - vdftra(i,k,11) = qgrs(i,k,ntgnc) - vdftra(i,k,12) = qgrs(i,k,ntgv) - vdftra(i,k,13) = qgrs(i,k,ntoz) + vdftra(i,k,10) = qgrs(i,k,ntsnc) + vdftra(i,k,11) = qgrs(i,k,ntgnc) + vdftra(i,k,12) = qgrs(i,k,ntgv) + vdftra(i,k,13) = qgrs(i,k,ntoz) + n = 13 IF ( nssl_ccn_on ) THEN - vdftra(i,k,14) = qgrs(i,k,ntccn) + vdftra(i,k,n+1) = qgrs(i,k,ntccn) + n = n+1 + ENDIF + IF ( nssl_3moment ) THEN + vdftra(i,k,n+1) = qgrs(i,k,ntrz) + vdftra(i,k,n+2) = qgrs(i,k,ntgz) + n = n+2 ENDIF enddo enddo diff --git a/physics/GFS_PBL_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.meta similarity index 93% rename from physics/GFS_PBL_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.meta index a09b34b48..7a8e72bba 100644 --- a/physics/GFS_PBL_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_PBL_generic_pre type = scheme - dependencies = GFS_PBL_generic_common.F90,machine.F + dependencies = GFS_PBL_generic_common.F90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -217,6 +217,27 @@ dimensions = () type = integer intent = in +[ntrz] + standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array + long_name = tracer index for rain reflectivity + units = index + dimensions = () + type = integer + intent = in +[ntgz] + standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel reflectivity + units = index + dimensions = () + type = integer + intent = in +[nthz] + standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array + long_name = tracer index for hail reflectivity + units = index + dimensions = () + type = integer + intent = in [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -301,6 +322,13 @@ dimensions = () type = logical intent = in +[nssl_3moment] + standard_name = nssl_3moment + long_name = 3-moment activation flag in NSSL microphysics scheme + units = flag + dimensions = () + type = logical + intent = in [hybedmf] standard_name = flag_for_hybrid_edmf_pbl_scheme long_name = flag for hybrid edmf pbl scheme (moninedmf) diff --git a/physics/GFS_SCNV_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_post.F90 similarity index 100% rename from physics/GFS_SCNV_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_post.F90 diff --git a/physics/GFS_SCNV_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_post.meta similarity index 99% rename from physics/GFS_SCNV_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_post.meta index bf6ba394f..963ad4a81 100644 --- a/physics/GFS_SCNV_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_SCNV_generic_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_SCNV_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_pre.F90 similarity index 100% rename from physics/GFS_SCNV_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_pre.F90 diff --git a/physics/GFS_SCNV_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_pre.meta similarity index 99% rename from physics/GFS_SCNV_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_pre.meta index eccd547a1..fbd9e47d8 100644 --- a/physics/GFS_SCNV_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_SCNV_generic_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.F90 similarity index 100% rename from physics/GFS_cloud_diagnostics.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.F90 diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.meta similarity index 98% rename from physics/GFS_cloud_diagnostics.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.meta index 53d1552e6..576c66463 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_cloud_diagnostics type = scheme - dependencies = machine.F,radiation_clouds.f + relative_path = ../../ + dependencies = hooks/machine.F,Radiation/radiation_clouds.f ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_debug.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.F90 similarity index 99% rename from physics/GFS_debug.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.F90 index fe63c1cea..ed26b795f 100644 --- a/physics/GFS_debug.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.F90 @@ -747,9 +747,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%det_thl ', Diag%det_thl) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%det_sqv ', Diag%det_sqv) end if - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%nupdraft ', Diag%nupdraft) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%maxwidth ', Diag%maxwidth) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%maxMF ', Diag%maxMF) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%ktop_plume ', Diag%ktop_plume) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%ztop_plume ', Diag%ztop_plume) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_h ', Diag%exch_h) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_m ', Diag%exch_m) end if diff --git a/physics/GFS_debug.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.meta similarity index 99% rename from physics/GFS_debug.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.meta index 1ad24e1d6..10eb43671 100644 --- a/physics/GFS_debug.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_diagtoscreen type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -200,7 +200,7 @@ [ccpp-table-properties] name = GFS_interstitialtoscreen type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -399,7 +399,7 @@ [ccpp-table-properties] name = GFS_abort type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -439,7 +439,7 @@ [ccpp-table-properties] name = GFS_checkland type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -698,7 +698,7 @@ [ccpp-table-properties] name = GFS_checktracers type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90 similarity index 89% rename from physics/GFS_phys_time_vary.fv3.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90 index a10c10d1b..f53ab3928 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90 @@ -2,7 +2,7 @@ !! Contains code related to GFS physics suite setup (physics part of time_vary_step) !>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update -!! This module contains GFS physics time vary subroutines including ozone, stratospheric water vapor, +!! This module contains GFS physics time vary subroutines including stratospheric water vapor, !! aerosol, IN&CCN and surface properties updates. module GFS_phys_time_vary @@ -10,12 +10,11 @@ module GFS_phys_time_vary use omp_lib #endif - use machine, only : kind_phys + use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec use mersenne_twister, only: random_setseed, random_number - use ozne_def, only : levozp, oz_coeff, oz_lat, oz_pres, oz_time, ozplin - use ozinterp, only : read_o3data, setindxoz, ozinterpol + use module_ozphys, only: ty_ozphys use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol @@ -61,6 +60,22 @@ module GFS_phys_time_vary contains + subroutine copy_error(myerrmsg, myerrflg, errmsg, errflg) + implicit none + character(*), intent(in) :: myerrmsg + integer, intent(in) :: myerrflg + character(*), intent(out) :: errmsg + integer, intent(inout) :: errflg + if(myerrflg /= 0 .and. errflg == 0) then + !$OMP CRITICAL + if(errflg == 0) then + errmsg = myerrmsg + errflg = myerrflg + endif + !$OMP END CRITICAL + endif + end subroutine copy_error + !> \section arg_table_GFS_phys_time_vary_init Argument Table !! \htmlinclude GFS_phys_time_vary_init.html !! @@ -69,7 +84,7 @@ module GFS_phys_time_vary subroutine GFS_phys_time_vary_init ( & me, master, ntoz, h2o_phys, iaerclm, iccn, iaermdl, iflip, im, levs, & nx, ny, idate, xlat_d, xlon_d, & - jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & + jindx1_o3, jindx2_o3, ddy_o3, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & @@ -82,7 +97,7 @@ subroutine GFS_phys_time_vary_init ( smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, lsm_cold_start, nthrds, & lkm, use_lake_model, lakefrac, lakedepth, iopt_lake, iopt_lake_clm, iopt_lake_flake, & - lakefrac_threshold, lakedepth_threshold, errmsg, errflg) + lakefrac_threshold, lakedepth_threshold, ozphys, errmsg, errflg) implicit none @@ -99,7 +114,8 @@ subroutine GFS_phys_time_vary_init ( integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:) - real(kind_phys), intent(in) :: ozpl(:,:,:), h2opl(:,:,:) + real(kind_phys), intent(in) :: h2opl(:,:,:) + integer, intent(inout) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) real(kind_phys), intent(inout) :: ddy_aer(:), ddx_aer(:) real(kind_phys), intent(out) :: aer_nm(:,:,:) @@ -116,6 +132,7 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(in) :: min_seaice, fice(:) real(kind_phys), intent(in) :: landfrac(:) real(kind_phys), intent(inout) :: weasd(:) + type(ty_ozphys), intent(in) :: ozphys ! NoahMP - only allocated when NoahMP is used integer, intent(in) :: lsoil, lsnow_lsm_lbound, lsnow_lsm_ubound @@ -192,6 +209,9 @@ subroutine GFS_phys_time_vary_init ( real(kind=kind_phys), dimension(:), allocatable :: dzsno real(kind=kind_phys), dimension(:), allocatable :: dzsnso + integer :: myerrflg + character(len=255) :: myerrmsg + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -202,69 +222,37 @@ subroutine GFS_phys_time_vary_init ( jamin=999 jamax=-999 -!$OMP parallel num_threads(nthrds) default(none) & -!$OMP shared (me,master,ntoz,h2o_phys,im,nx,ny,levs,idate) & -!$OMP shared (xlat_d,xlon_d,imap,jmap,errmsg,errflg) & -!$OMP shared (levozp,oz_coeff,oz_pres,ozpl) & -!$OMP shared (levh2o,h2o_coeff,h2o_pres,h2opl) & -!$OMP shared (iamin, iamax, jamin, jamax) & -!$OMP shared (iaerclm,iaermdl,ntrcaer,aer_nm,iflip,iccn) & -!$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & -!$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & -!$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & -!$OMP shared (do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau,ddy_j2tau) & -!$OMP shared (isot,ivegsrc,nlunit,sncovr,sncovr_ice,lsm,lsm_ruc) & -!$OMP shared (min_seaice,fice,landfrac,vtype,weasd,snupx,salp_data) & -!$OMP private (ix,i,j,rsnow,vegtyp) - -!$OMP sections - -!$OMP section -!> - Call read_o3data() to read ozone data - call read_o3data (ntoz, me, master) - - ! Consistency check that the hardcoded values for levozp and - ! oz_coeff in GFS_typedefs.F90 match what is set by read_o3data - ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff)) - if (size(ozpl, dim=2).ne.levozp) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "levozp from read_o3data does not match value in GFS_typedefs.F90: ", & - levozp, " /= ", size(ozpl, dim=2) - errflg = 1 - end if - if (size(ozpl, dim=3).ne.oz_coeff) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "oz_coeff from read_o3data does not match value in GFS_typedefs.F90: ", & - oz_coeff, " /= ", size(ozpl, dim=3) - errflg = 1 - end if - -!$OMP section !> - Call read_h2odata() to read stratospheric water vapor data + need_h2odata: if(h2o_phys) then call read_h2odata (h2o_phys, me, master) ! Consistency check that the hardcoded values for levh2o and - ! h2o_coeff in GFS_typedefs.F90 match what is set by read_o3data + ! h2o_coeff in GFS_typedefs.F90 match what is set by read_h2odata ! in GFS_typedefs.F90: allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) if (size(h2opl, dim=2).ne.levh2o) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + write(myerrmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "levh2o from read_h2odata does not match value in GFS_typedefs.F90: ", & levh2o, " /= ", size(h2opl, dim=2) - errflg = 1 + myerrflg = 1 + call copy_error(myerrmsg, myerrflg, errmsg, errflg) end if if (size(h2opl, dim=3).ne.h2o_coeff) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + write(myerrmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "h2o_coeff from read_h2odata does not match value in GFS_typedefs.F90: ", & h2o_coeff, " /= ", size(h2opl, dim=3) - errflg = 1 + myerrflg = 1 + call copy_error(myerrmsg, myerrflg, errmsg, errflg) end if + endif need_h2odata -!$OMP section !> - Call read_aerdata() to read aerosol climatology, Anning added coupled !> added coupled gocart and radiation option to initializing aer_nm if (iaerclm) then ntrcaer = ntrcaerm - call read_aerdata (me,master,iflip,idate,errmsg,errflg) + myerrflg = 0 + myerrmsg = 'read_aerdata failed without a message' + call read_aerdata (me,master,iflip,idate,myerrmsg,myerrflg) + call copy_error(myerrmsg, myerrflg, errmsg, errflg) else if(iaermdl ==2 ) then do ix=1,ntrcaerm do j=1,levs @@ -278,7 +266,6 @@ subroutine GFS_phys_time_vary_init ( ntrcaer = 1 endif -!$OMP section !> - Call read_cidata() to read IN and CCN data if (iccn == 1) then call read_cidata (me,master) @@ -286,39 +273,41 @@ subroutine GFS_phys_time_vary_init ( ! hardcoded in module iccn_def.F and GFS_typedefs.F90 endif -!$OMP section !> - Call tau_amf dats for ugwp_v1 if (do_ugwp_v1) then - call read_tau_amf(me, master, errmsg, errflg) + myerrflg = 0 + myerrmsg = 'read_tau_amf failed without a message' + call read_tau_amf(me, master, myerrmsg, myerrflg) + call copy_error(myerrmsg, myerrflg, errmsg, errflg) endif -!$OMP section !> - Initialize soil vegetation (needed for sncovr calculation further down) - call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) + myerrflg = 0 + myerrmsg = 'set_soilveg failed without a message' + call set_soilveg(me, isot, ivegsrc, nlunit, myerrmsg, myerrflg) + call copy_error(myerrmsg, myerrflg, errmsg, errflg) -!$OMP section !> - read in NoahMP table (needed for NoahMP init) - call read_mp_table_parameters(errmsg, errflg) + if(lsm == lsm_noahmp) then + myerrflg = 0 + myerrmsg = 'read_mp_table_parameters failed without a message' + call read_mp_table_parameters(myerrmsg, myerrflg) + call copy_error(myerrmsg, myerrflg, errmsg, errflg) + endif -!$OMP end sections ! Need an OpenMP barrier here (implicit in "end sections") -!$OMP sections - -!$OMP section -!> - Call setindxoz() to initialize ozone data +!> - Setup spatial interpolation indices for ozone physics. if (ntoz > 0) then - call setindxoz (im, xlat_d, jindx1_o3, jindx2_o3, ddy_o3) + call ozphys%setup_o3prog(xlat_d, jindx1_o3, jindx2_o3, ddy_o3) endif -!$OMP section !> - Call setindxh2o() to initialize stratospheric water vapor data if (h2o_phys) then call setindxh2o (im, xlat_d, jindx1_h, jindx2_h, ddy_h) endif -!$OMP section !> - Call setindxaer() to initialize aerosols data if (iaerclm) then call setindxaer (im, xlat_d, jindx1_aer, & @@ -331,7 +320,6 @@ subroutine GFS_phys_time_vary_init ( jamax = max(maxval(jindx2_aer), jamax) endif -!$OMP section !> - Call setindxci() to initialize IN and CCN data if (iccn == 1) then call setindxci (im, xlat_d, jindx1_ci, & @@ -339,14 +327,12 @@ subroutine GFS_phys_time_vary_init ( iindx1_ci, iindx2_ci, ddx_ci) endif -!$OMP section !> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that can resolve GWs if (do_ugwp_v1) then call cires_indx_ugwp (im, me, master, xlat_d, jindx1_tau, jindx2_tau, & ddy_j1tau, ddy_j2tau) endif -!$OMP section !--- initial calculation of maps local ix -> global i and j ix = 0 do j = 1,ny @@ -357,7 +343,6 @@ subroutine GFS_phys_time_vary_init ( enddo enddo -!$OMP section !--- if sncovr does not exist in the restart, need to create it if (all(sncovr < zero)) then if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' @@ -386,14 +371,12 @@ subroutine GFS_phys_time_vary_init ( endif endif -!$OMP end sections - -!$OMP end parallel - if (errflg/=0) return if (iaerclm) then + ! This call is outside the OpenMP section, so it should access errmsg & errflg directly. call read_aerdataf (me, master, iflip, idate, fhour, errmsg, errflg) + ! If it is moved to an OpenMP section, it must use myerrmsg, myerrflg, and copy_error. if (errflg/=0) return end if @@ -479,7 +462,8 @@ subroutine GFS_phys_time_vary_init ( !$omp shared(dwsat_table,dksat_table,psisat_table,smoiseq) & !$OMP shared(smcwtdxy,deeprechxy,rechxy,errmsg,errflg) & !$OMP private(vegtyp,masslai,masssai,snd,dzsno,dzsnso,isnow) & -!$OMP private(soiltyp,bexp,smcmax,smcwlt,dwsat,dksat,psisat,ddz) +!$OMP private(soiltyp,bexp,smcmax,smcwlt,dwsat,dksat,psisat) & +!$OMP private(myerrmsg,myerrflg,ddz) do ix=1,im if (landfrac(ix) >= drythresh) then tvxy(ix) = tsfcl(ix) @@ -594,8 +578,9 @@ subroutine GFS_phys_time_vary_init ( dzsno(-1) = 0.20_kind_phys dzsno(0) = snd - 0.05_kind_phys - 0.20_kind_phys else - errmsg = 'Error in GFS_phys_time_vary.fv3.F90: Problem with the logic assigning snow layers in Noah MP initialization' - errflg = 1 + myerrmsg = 'Error in GFS_phys_time_vary.fv3.F90: Problem with the logic assigning snow layers in Noah MP initialization' + myerrflg = 1 + call copy_error(myerrmsg, myerrflg, errmsg, errflg) endif ! Now we have the snowxy field @@ -749,7 +734,7 @@ subroutine GFS_phys_time_vary_timestep_init ( lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype,scolor, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, & + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, ozphys, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) implicit none @@ -779,6 +764,7 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(in) :: jindx1_tau(:), jindx2_tau(:) real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) real(kind_phys), intent(inout) :: tau_amf(:) + type(ty_ozphys), intent(in) :: ozphys ! For gcycle only integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil @@ -801,10 +787,13 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(out) :: errflg ! Local variables - integer :: i, j, k, iseed, iskip, ix - real(kind=kind_phys) :: wrk(1) - real(kind=kind_phys) :: rannie(cny) - real(kind=kind_phys) :: rndval(cnx*cny*nrcm) + integer :: i, j, k, iseed, iskip, ix, idat(8), jdat(8), iday, j1, j2, nc, n1, n2, jdow, & + jdoy, jday, w3kindreal, w3kindint + real(kind_phys) :: wrk(1), tem, tx1, tx2, rjday + real(kind_phys) :: rannie(cny) + real(kind_phys) :: rndval(cnx*cny*nrcm) + real(kind_dbl_prec) :: rinc(5) + real(kind_sngl_prec) :: rinc4(5) ! Initialize CCPP error handling variables errmsg = '' @@ -824,7 +813,8 @@ subroutine GFS_phys_time_vary_timestep_init ( !$OMP shared(ozpl,ddy_o3,h2o_phys,jindx1_h,jindx2_h,h2opl,ddy_h,iaerclm,master) & !$OMP shared(levs,prsl,iccn,jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci) & !$OMP shared(ddx_ci,in_nm,ccn_nm,do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau) & -!$OMP shared(ddy_j2tau,tau_amf,iflip) & +!$OMP shared(ddy_j2tau,tau_amf,iflip,ozphys,rjday,n1,n2,idat,jdat,rinc,rinc4) & +!$OMP shared(w3kindreal,w3kindint,jdow,jdoy,jday) & !$OMP private(iseed,iskip,i,j,k) !$OMP sections @@ -875,11 +865,41 @@ subroutine GFS_phys_time_vary_timestep_init ( endif ! imfdeepcnv, cal_re, random_clds !$OMP section -!> - Call ozinterpol() to make ozone interpolation + !> - Compute temporal interpolation indices for updating gas concentrations. + idat=0 + idat(1)=idate(4) + idat(2)=idate(2) + idat(3)=idate(3) + idat(5)=idate(1) + rinc=0. + rinc(2)=fhour + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4=rinc + CALL w3movdat(rinc4,idat,jdat) + else + CALL w3movdat(rinc,idat,jdat) + endif + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + if (rjday < ozphys%time(1)) rjday = rjday + 365. + + n2 = ozphys%ntime + 1 + do j=2,ozphys%ntime + if (rjday < ozphys%time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime + +!> - Update ozone concentration. if (ntoz > 0) then - call ozinterpol (me, im, idate, fhour, & - jindx1_o3, jindx2_o3, & - ozpl, ddy_o3) + call ozphys%update_o3prog(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) endif !$OMP section @@ -979,12 +999,6 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg) if (.not.is_initialized) return - ! Deallocate ozone arrays - if (allocated(oz_lat) ) deallocate(oz_lat) - if (allocated(oz_pres) ) deallocate(oz_pres) - if (allocated(oz_time) ) deallocate(oz_time) - if (allocated(ozplin) ) deallocate(ozplin) - ! Deallocate h2o arrays if (allocated(h2o_lat) ) deallocate(h2o_lat) if (allocated(h2o_pres)) deallocate(h2o_pres) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.meta similarity index 98% rename from physics/GFS_phys_time_vary.fv3.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.meta index 363469e91..a1990ed43 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.meta @@ -1,8 +1,16 @@ [ccpp-table-properties] name = GFS_phys_time_vary type = scheme - dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f - dependencies = namelist_soilveg.f,set_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F,cires_tauamf_data.F90,noahmp_tables.f90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Interstitials/UFS_SCM_NEPTUNE/gcycle.F90,Interstitials/UFS_SCM_NEPTUNE/iccn_def.F + dependencies = Interstitials/UFS_SCM_NEPTUNE/iccninterp.F90,Interstitials/UFS_SCM_NEPTUNE/sfcsub.F + dependencies = Radiation/mersenne_twister.f + dependencies = MP/Morrison_Gettelman/aerclm_def.F,MP/Morrison_Gettelman/aerinterp.F90 + dependencies = SFC_Models/Land/Noah/namelist_soilveg.f,SFC_Models/Land/Noah/set_soilveg.f,SFC_Models/Land/Noahmp/noahmp_tables.f90 + dependencies = photochem/module_ozphys.F90 + dependencies = photochem/h2o_def.f,photochem/h2ointerp.f90 + dependencies = GWD/cires_tauamf_data.F90 ######################################################################## [ccpp-arg-table] @@ -138,14 +146,6 @@ type = real kind = kind_phys intent = inout -[ozpl] - standard_name = ozone_forcing - long_name = ozone forcing data - units = mixed - dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) - type = real - kind = kind_phys - intent = in [jindx1_h] standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation long_name = interpolation low index for stratospheric water vapor @@ -969,6 +969,13 @@ type = real kind = kind_phys intent = in +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1206,7 +1213,7 @@ standard_name = ozone_forcing long_name = ozone forcing data units = mixed - dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) + dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_data) type = real kind = kind_phys intent = inout @@ -1942,6 +1949,13 @@ type = real kind = kind_phys intent = inout +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.F90 similarity index 94% rename from physics/GFS_phys_time_vary.scm.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.F90 index 74b34e974..075bfc039 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.F90 @@ -2,17 +2,16 @@ !! Contains code related to GFS physics suite setup (physics part of time_vary_step) !>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update -!! This module contains GFS physics time vary subroutines including ozone, stratospheric water vapor, +!! This module contains GFS physics time vary subroutines including stratospheric water vapor, !! aerosol, IN&CCN and surface properties updates. !> @{ module GFS_phys_time_vary - use machine, only : kind_phys + use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec use mersenne_twister, only: random_setseed, random_number - use ozne_def, only : levozp, oz_coeff, oz_lat, oz_pres, oz_time, ozplin - use ozinterp, only : read_o3data, setindxoz, ozinterpol + use module_ozphys, only: ty_ozphys use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol @@ -62,7 +61,7 @@ module GFS_phys_time_vary !! @{ subroutine GFS_phys_time_vary_init ( & me, master, ntoz, h2o_phys, iaerclm, iccn, iflip, im, nx, ny, idate, xlat_d, xlon_d, & - jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & + jindx1_o3, jindx2_o3, ddy_o3, ozphys, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & @@ -87,7 +86,7 @@ subroutine GFS_phys_time_vary_init ( integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:) - real(kind_phys), intent(in) :: ozpl(:,:,:), h2opl(:,:,:) + real(kind_phys), intent(in) :: h2opl(:,:,:) integer, intent(inout) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) real(kind_phys), intent(inout) :: ddy_aer(:), ddx_aer(:) real(kind_phys), intent(in) :: aer_nm(:,:,:) @@ -104,6 +103,7 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(in) :: min_seaice, fice(:) real(kind_phys), intent(in) :: landfrac(:) real(kind_phys), intent(inout) :: weasd(:) + type(ty_ozphys), intent(in) :: ozphys ! NoahMP - only allocated when NoahMP is used integer, intent(in) :: lsoil, lsnow_lsm_lbound, lsnow_lsm_ubound @@ -189,30 +189,11 @@ subroutine GFS_phys_time_vary_init ( jamin=999 jamax=-999 -!> - Call read_o3data() to read ozone data - call read_o3data (ntoz, me, master) - - ! Consistency check that the hardcoded values for levozp and - ! oz_coeff in GFS_typedefs.F90 match what is set by read_o3data - ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff)) - if (size(ozpl, dim=2).ne.levozp) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "levozp from read_o3data does not match value in GFS_typedefs.F90: ", & - levozp, " /= ", size(ozpl, dim=2) - errflg = 1 - end if - if (size(ozpl, dim=3).ne.oz_coeff) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "oz_coeff from read_o3data does not match value in GFS_typedefs.F90: ", & - oz_coeff, " /= ", size(ozpl, dim=3) - errflg = 1 - end if - !> - Call read_h2odata() to read stratospheric water vapor data call read_h2odata (h2o_phys, me, master) ! Consistency check that the hardcoded values for levh2o and - ! h2o_coeff in GFS_typedefs.F90 match what is set by read_o3data + ! h2o_coeff in GFS_typedefs.F90 match what is set by read_h2odata ! in GFS_typedefs.F90: allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) if (size(h2opl, dim=2).ne.levh2o) then write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & @@ -266,9 +247,9 @@ subroutine GFS_phys_time_vary_init ( !> - Initialize soil vegetation (needed for sncovr calculation further down) call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) -!> - Call setindxoz() to initialize ozone data +!> - Setup spatial interpolation indices for ozone physics. if (ntoz > 0) then - call setindxoz (im, xlat_d, jindx1_o3, jindx2_o3, ddy_o3) + call ozphys%setup_o3prog(xlat_d, jindx1_o3, jindx2_o3, ddy_o3) endif !> - Call setindxh2o() to initialize stratospheric water vapor data @@ -652,7 +633,7 @@ end subroutine GFS_phys_time_vary_init !! @{ subroutine GFS_phys_time_vary_timestep_init ( & me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, idate, nsswr, fhswr, lsswr, fhour, & - imfdeepcnv, cal_pre, random_clds, ntoz, h2o_phys, iaerclm, iccn, clstp, & + imfdeepcnv, cal_pre, random_clds, ozphys, ntoz, h2o_phys, iaerclm, iccn, clstp, & jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, & @@ -686,15 +667,19 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(in) :: jindx1_tau(:), jindx2_tau(:) real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) real(kind_phys), intent(inout) :: tau_amf(:) + type(ty_ozphys), intent(in) :: ozphys integer, intent(in) :: nthrds character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! Local variables - integer :: i, j, k, iseed, iskip, ix - real(kind=kind_phys) :: wrk(1) - real(kind=kind_phys) :: rannie(cny) - real(kind=kind_phys) :: rndval(cnx*cny*nrcm) + integer :: i, j, k, iseed, iskip, ix, idat(8), jdat(8), iday, j1, j2, nc, n1, n2, jdow, & + jdoy, jday, w3kindreal, w3kindint + real(kind_phys) :: wrk(1), tem, tx1, tx2, rjday + real(kind_phys) :: rannie(cny) + real(kind_phys) :: rndval(cnx*cny*nrcm) + real(kind_dbl_prec) :: rinc(5) + real(kind_sngl_prec) :: rinc4(5) ! Initialize CCPP error handling variables errmsg = '' @@ -748,11 +733,41 @@ subroutine GFS_phys_time_vary_timestep_init ( endif ! imfdeepcnv, cal_re, random_clds -!> - Call ozinterpol() to make ozone interpolation + !> - Compute temporal interpolation indices for updating gas concentrations. + idat=0 + idat(1)=idate(4) + idat(2)=idate(2) + idat(3)=idate(3) + idat(5)=idate(1) + rinc=0. + rinc(2)=fhour + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4=rinc + CALL w3movdat(rinc4,idat,jdat) + else + CALL w3movdat(rinc,idat,jdat) + endif + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + if (rjday < ozphys%time(1)) rjday = rjday + 365. + + n2 = ozphys%ntime + 1 + do j=2,ozphys%ntime + if (rjday < ozphys%time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime + +!> - Update ozone concentration. if (ntoz > 0) then - call ozinterpol (me, im, idate, fhour, & - jindx1_o3, jindx2_o3, & - ozpl, ddy_o3) + call ozphys%update_o3prog(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) endif !> - Call h2ointerpol() to make stratospheric water vapor data interpolation @@ -844,12 +859,6 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg) if (.not.is_initialized) return - ! Deallocate ozone arrays - if (allocated(oz_lat) ) deallocate(oz_lat) - if (allocated(oz_pres) ) deallocate(oz_pres) - if (allocated(oz_time) ) deallocate(oz_time) - if (allocated(ozplin) ) deallocate(ozplin) - ! Deallocate h2o arrays if (allocated(h2o_lat) ) deallocate(h2o_lat) if (allocated(h2o_pres)) deallocate(h2o_pres) diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.meta similarity index 98% rename from physics/GFS_phys_time_vary.scm.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.meta index 8b59e4bed..a9094a075 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.meta @@ -1,8 +1,15 @@ [ccpp-table-properties] name = GFS_phys_time_vary type = scheme - dependencies = aerclm_def.F,aerinterp.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f - dependencies = namelist_soilveg.f,set_soilveg.f,ozinterp.f90,ozne_def.f,cires_tauamf_data.F90,noahmp_tables.f90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Interstitials/UFS_SCM_NEPTUNE/iccn_def.F,Interstitials/UFS_SCM_NEPTUNE/iccninterp.F90 + dependencies = Interstitials/UFS_SCM_NEPTUNE/sfcsub.F,Radiation/mersenne_twister.f + dependencies = MP/Morrison_Gettelman/aerclm_def.F,MP/Morrison_Gettelman/aerinterp.F90 + dependencies = SFC_Models/Land/Noah/namelist_soilveg.f,SFC_Models/Land/Noah/set_soilveg.f,SFC_Models/Land/Noahmp/noahmp_tables.f90 + dependencies = photochem/module_ozphys.F90 + dependencies = photochem/h2o_def.f,photochem/h2ointerp.f90 + dependencies = GWD/cires_tauamf_data.F90 ######################################################################## [ccpp-arg-table] @@ -124,14 +131,6 @@ type = real kind = kind_phys intent = inout -[ozpl] - standard_name = ozone_forcing - long_name = ozone forcing data - units = mixed - dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) - type = real - kind = kind_phys - intent = in [jindx1_h] standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation long_name = interpolation low index for stratospheric water vapor @@ -1118,7 +1117,7 @@ standard_name = ozone_forcing long_name = ozone forcing data units = mixed - dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) + dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_data) type = real kind = kind_phys intent = inout @@ -1353,6 +1352,13 @@ type = real kind = kind_phys intent = inout +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in [nthrds] standard_name = number_of_openmp_threads long_name = number of OpenMP threads available for physics schemes diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.F90 new file mode 100644 index 000000000..fe5409353 --- /dev/null +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.F90 @@ -0,0 +1,158 @@ +! ########################################################################################### +!> \file GFS_physics_post.F90 +!! +!! This module contains GFS specific calculations (e.g. diagnostics) and suite specific +!! code (e.g Saving fields for subsequent physics timesteps). For interoperability across a +!! wide range of hosts, CCPP compliant schemes should avoid including such calculations. This +!! module/scheme is intended for such "host-specific" computations. +!! +! ########################################################################################### +module GFS_physics_post + use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec + implicit none + public GFS_physics_post_run +contains + +! ########################################################################################### +! SUBROUTINE GFS_physics_post_run +! ########################################################################################### +!! \section arg_table_GFS_physics_post_run Argument Table +!! \htmlinclude GFS_physics_post_run.html +!! + subroutine GFS_physics_post_run(nCol, nLev, ntoz, ntracp100, nprocess, nprocess_summed, & + dtidx, is_photochem, ldiag3d, ip_physics, ip_photochem, ip_prod_loss, ip_ozmix, & + ip_temp, ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, & + dtend, errmsg, errflg) + + ! Inputs + integer, intent(in) :: & + nCol, & ! Horizontal dimension + nLev, & ! Number of vertical layers + ntoz, & ! Index for ozone mixing ratio + ntracp100, & ! Number of tracers plus 100 + nprocess, & ! Number of processes that cause changes in state variables + nprocess_summed,& ! Number of causes in dtidx per tracer summed for total physics tendency + ip_physics, & ! Index for process in diagnostic tendency output + ip_photochem, & ! Index for process in diagnostic tendency output + ip_prod_loss, & ! Index for process in diagnostic tendency output + ip_ozmix, & ! Index for process in diagnostic tendency output + ip_temp, & ! Index for process in diagnostic tendency output + ip_overhead_ozone ! Index for process in diagnostic tendency output + integer, intent(in), dimension(:,:) :: & + dtidx ! Bookkeeping indices for GFS diagnostic tendencies + logical, intent(in) :: & + ldiag3d ! Flag for 3d diagnostic fields + logical, intent(in), dimension(:) :: & + is_photochem ! Flags for photochemistry processes to sum + + ! Inputs (optional) + real(kind=kind_phys), intent(in), dimension(:,:), pointer, optional :: & + do3_dt_prd, & ! Physics tendency: production and loss effect + do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect + do3_dt_temp, & ! Physics tendency: temperature effect + do3_dt_ohoz ! Physics tendency: overhead ozone effect + + ! Outputs + real(kind=kind_phys), intent(inout), dimension(:,:,:) :: & + dtend ! Diagnostic tendencies for state variables + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + + ! Locals + integer :: idtend, ichem, iphys, itrac + logical :: all_true(nprocess) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if(.not.ldiag3d) then + return + endif + + ! ####################################################################################### + ! + ! Ozone physics diagnostics + ! + ! ####################################################################################### + idtend = dtidx(100+ntoz,ip_prod_loss) + if (idtend >= 1 .and. associated(do3_dt_prd)) then + dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_prd + endif + ! + idtend = dtidx(100+ntoz,ip_ozmix) + if (idtend >= 1 .and. associated(do3_dt_ozmx)) then + dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_ozmx + endif + ! + idtend = dtidx(100+ntoz,ip_temp) + if (idtend >= 1 .and. associated(do3_dt_temp)) then + dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_temp + endif + ! + idtend = dtidx(100+ntoz,ip_overhead_ozone) + if (idtend >= 1 .and. associated(do3_dt_ohoz)) then + dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_ohoz + endif + + ! ####################################################################################### + ! + ! Total (photochemical) tendencies. + ! + ! ####################################################################################### + itrac = ntoz+100 + ichem = dtidx(itrac, ip_photochem) + if(ichem >= 1) then + call sum_it(ichem, itrac, is_photochem) + endif + + ! ####################################################################################### + ! + ! Total (physics) tendencies + ! + ! ####################################################################################### + all_true = .true. + do itrac = 2,ntracp100 + iphys = dtidx(itrac,ip_physics) + if(iphys >= 1) then + call sum_it(iphys, itrac, all_true) + endif + enddo + + contains + + subroutine sum_it(isum,itrac,sum_me) + integer, intent(in) :: isum ! third index of dtend of summary process + integer, intent(in) :: itrac ! tracer or state variable being summed + logical, intent(in) :: sum_me(nprocess) ! false = skip this process + logical :: first + integer :: idtend, iprocess + + first=.true. + do iprocess=1,nprocess + if(iprocess>nprocess_summed) then + exit ! Don't sum up the sums. + else if(.not.sum_me(iprocess)) then + cycle ! We were asked to skip this one. + endif + idtend = dtidx(itrac,iprocess) + if(idtend>=1) then + ! This tendency was calculated for this tracer, so + ! accumulate it into the total tendency. + if(first) then + dtend(:,:,isum) = dtend(:,:,idtend) + first=.false. + else + dtend(:,:,isum) = dtend(:,:,isum) + dtend(:,:,idtend) + endif + endif + enddo + if(first) then + ! No tendencies were calculated, so sum is 0: + dtend(:,:,isum) = 0 + endif + end subroutine sum_it + end subroutine GFS_physics_post_run +end module GFS_physics_post diff --git a/physics/ozphys_2015.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.meta similarity index 59% rename from physics/ozphys_2015.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.meta index 8bce7defe..758b9d8b8 100644 --- a/physics/ozphys_2015.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.meta @@ -1,130 +1,26 @@ [ccpp-table-properties] - name = ozphys_2015 + name = GFS_physics_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] - name = ozphys_2015_init + name = GFS_physics_post_run type = scheme -[oz_phys_2015] - standard_name = flag_for_nrl_2015_ozone_scheme - long_name = flag for new (2015) ozone physics - units = flag - dimensions = () - type = logical - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = ozphys_2015_run - type = scheme -[im] +[nCol] standard_name = horizontal_loop_extent long_name = horizontal loop extent units = count dimensions = () type = integer intent = in -[levs] +[nLev] standard_name = vertical_layer_dimension long_name = number of vertical layers units = count dimensions = () type = integer intent = in -[ko3] - standard_name = vertical_dimension_of_ozone_forcing_data - long_name = number of vertical layers in ozone forcing data - units = count - dimensions = () - type = integer - intent = in -[dt] - standard_name = timestep_for_physics - long_name = physics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[oz] - standard_name = ozone_concentration_of_new_state - long_name = ozone concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[tin] - standard_name = air_temperature_of_new_state - long_name = updated air temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[po3] - standard_name = natural_log_of_ozone_forcing_data_pressure_levels - long_name = natural log of ozone forcing data pressure levels - units = 1 - dimensions = (vertical_dimension_of_ozone_forcing_data) - type = real - kind = kind_phys - intent = in -[prsl] - standard_name = air_pressure - long_name = mid-layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[prdout] - standard_name = ozone_forcing - long_name = ozone forcing data - units = mixed - dimensions = (horizontal_loop_extent,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) - type = real - kind = kind_phys - intent = in -[pl_coeff] - standard_name = number_of_coefficients_in_ozone_forcing_data - long_name = number of coefficients in ozone forcing data - units = index - dimensions = () - type = integer - intent = in -[delp] - standard_name = air_pressure_difference_between_midlayers - long_name = difference between mid-layer pressures - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for calculating 3-D diagnostic fields - units = flag - dimensions = () - type = logical - intent = in [dtend] standard_name = cumulative_change_of_state_variables long_name = diagnostic tendencies for state variables @@ -147,48 +43,114 @@ dimensions = () type = integer intent = in -[index_of_process_prod_loss] +[ntracp100] + standard_name = number_of_tracers_plus_one_hundred + long_name = number of tracers plus one hundred + units = count + dimensions = () + type = integer + intent = in +[nprocess] + standard_name = number_of_cumulative_change_processes + long_name = number of processes that cause changes in state variables + units = count + dimensions = () + type = integer + intent = in +[nprocess_summed] + standard_name = number_of_physics_causes_of_tracer_changes + long_name = number of causes in dtidx per tracer summed for total physics tendency + units = count + dimensions = () + type = integer + intent = in +[ip_physics] + standard_name = index_of_all_physics_process_in_cumulative_change_index + long_name = index of all physics transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[ip_photochem] + standard_name = index_of_photochemistry_process_in_cumulative_change_index + long_name = index of photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[is_photochem] + standard_name = flags_for_photochemistry_processes_to_sum + long_name = flags for photochemistry processes to sum as the total photochemistry process cumulative change + units = flag + dimensions = (number_of_cumulative_change_processes) + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[ip_prod_loss] standard_name = index_of_production_and_loss_process_in_cumulative_change_index long_name = index of production and loss effect in photochemistry process in second dimension of array cumulative change index units = index dimensions = () type = integer intent = in -[index_of_process_ozmix] +[ip_ozmix] standard_name = index_of_ozone_mixing_ratio_process_in_cumulative_change_index long_name = index of ozone mixing ratio effect in photochemistry process in second dimension of array cumulative change index units = index dimensions = () type = integer intent = in -[index_of_process_temp] +[ip_temp] standard_name = index_of_temperature_process_in_cumulative_change_index long_name = index of temperature effect in photochemistry process in second dimension of array cumulative change index units = index dimensions = () type = integer intent = in -[index_of_process_overhead_ozone] +[ip_overhead_ozone] standard_name = index_of_overhead_process_in_cumulative_change_index long_name = index of overhead ozone effect in photochemistry process in second dimension of array cumulative change index units = index dimensions = () type = integer intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () +[do3_dt_prd] + standard_name = ozone_tendency_due_to_production_and_loss_rate + long_name = ozone tendency due to production and loss rate + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in -[me] - standard_name = mpi_rank - long_name = rank of the current MPI task - units = index - dimensions = () - type = integer +[do3_dt_ozmx] + standard_name = ozone_tendency_due_to_ozone_mixing_ratio + long_name = ozone tendency due to ozone mixing ratio + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[do3_dt_temp] + standard_name = ozone_tendency_due_to_temperature + long_name = ozone tendency due to temperature + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[do3_dt_ohoz] + standard_name = ozone_tendency_due_to_overhead_ozone_column + long_name = ozone tendency due to overhead ozone column + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys intent = in [errmsg] standard_name = ccpp_error_message @@ -204,4 +166,4 @@ units = 1 dimensions = () type = integer - intent = out + intent = out \ No newline at end of file diff --git a/physics/GFS_rad_time_vary.fv3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.F90 similarity index 100% rename from physics/GFS_rad_time_vary.fv3.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.F90 diff --git a/physics/GFS_rad_time_vary.fv3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.meta similarity index 98% rename from physics/GFS_rad_time_vary.fv3.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.meta index 19eb41dc2..0759b7e2a 100644 --- a/physics/GFS_rad_time_vary.fv3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_rad_time_vary type = scheme - dependencies = machine.F,mersenne_twister.f,radcons.f90 + relative_path = ../../ + dependencies = hooks/machine.F,Radiation/mersenne_twister.f,Radiation/RRTMG/radcons.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rad_time_vary.scm.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.F90 similarity index 100% rename from physics/GFS_rad_time_vary.scm.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.F90 diff --git a/physics/GFS_rad_time_vary.scm.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.meta similarity index 98% rename from physics/GFS_rad_time_vary.scm.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.meta index 19eb41dc2..0759b7e2a 100644 --- a/physics/GFS_rad_time_vary.scm.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_rad_time_vary type = scheme - dependencies = machine.F,mersenne_twister.f,radcons.f90 + relative_path = ../../ + dependencies = hooks/machine.F,Radiation/mersenne_twister.f,Radiation/RRTMG/radcons.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_radiation_surface.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.F90 similarity index 100% rename from physics/GFS_radiation_surface.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.F90 diff --git a/physics/GFS_radiation_surface.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.meta similarity index 98% rename from physics/GFS_radiation_surface.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.meta index 9d5734706..686bd3c6c 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.meta @@ -1,7 +1,10 @@ [ccpp-table-properties] name = GFS_radiation_surface type = scheme - dependencies = iounitdef.f,machine.F,radiation_surface.f,set_soilveg_ruc.F90,namelist_soilveg_ruc.F90 + relative_path = ../../ + dependencies = Radiation/radiation_surface.f + dependencies = SFC_Models/Land/RUC/set_soilveg_ruc.F90,SFC_Models/Land/RUC/namelist_soilveg_ruc.F90 + dependencies = hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmg_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.F90 similarity index 100% rename from physics/GFS_rrtmg_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.F90 diff --git a/physics/GFS_rrtmg_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.meta similarity index 97% rename from physics/GFS_rrtmg_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.meta index 5fa6328a7..b387c3e33 100644 --- a/physics/GFS_rrtmg_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = GFS_rrtmg_post type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,radsw_param.f + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Radiation/radiation_aerosols.f,Radiation/RRTMG/radlw_param.f,Radiation/RRTMG/radsw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.F90 similarity index 99% rename from physics/GFS_rrtmg_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.F90 index 4f4de181a..5da5c86fb 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.F90 @@ -45,7 +45,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& gasvmr_ccl4, gasvmr_cfc113, aerodp,ext550, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, rrfs_sd, & - aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, errmsg, errflg) + aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, ozphys, & + errmsg, errflg) use machine, only: kind_phys @@ -53,7 +54,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& use funcphys, only: fpvs use module_radiation_astronomy,only: coszmn ! sol_init, sol_update - use module_radiation_gases, only: NF_VGAS, getgases, getozn ! gas_init, gas_update, + use module_radiation_gases, only: NF_VGAS, getgases ! gas_init, gas_update, use module_radiation_aerosols, only: NF_AESW, NF_AELW, setaer, & ! aer_init, aer_update, & NSPC1 use module_radiation_clouds, only: NF_CLDS, & ! cld_init @@ -80,6 +81,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& make_IceNumber, & make_DropletNumber, & make_RainNumber + ! For NRL Ozone + use module_ozphys, only: ty_ozphys implicit none integer, intent(in) :: im, levs, lm, lmk, lmp, ltp, & @@ -250,6 +253,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& integer :: iflag integer :: islmsk + ! For NRL Ozone + type(ty_ozphys),intent(in) :: ozphys + integer :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte @@ -420,7 +426,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& !> - Get layer ozone mass mixing ratio (if use ozone climatology data, -!! call getozn()). if (ntoz > 0) then ! interactive ozone generation do k=1,lmk @@ -429,8 +434,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& enddo enddo else ! climatological ozone - call getozn (prslk1, xlat, im, lmk, top_at_1, & ! --- inputs - olyr) ! --- outputs + call ozphys%run_o3clim(xlat, prslk1, con_pi, olyr) endif ! end_if_ntoz !> - Call coszmn(), to compute cosine of zenith angle (only when SW is called) @@ -976,7 +980,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & - & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_gf, do_mynnedmf, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_c3, do_mynnedmf, & & lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.meta similarity index 98% rename from physics/GFS_rrtmg_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.meta index a8aecdbe0..43802298b 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.meta @@ -1,9 +1,14 @@ [ccpp-table-properties] name = GFS_rrtmg_pre type = scheme - dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,module_mp_radar.F90,module_mp_thompson.F90 - dependencies = module_mp_thompson_make_number_concentrations.F90,radcons.f90,radiation_aerosols.f - dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90 + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F + dependencies = MP/Thompson/module_mp_thompson.F90,MP/Thompson/module_mp_thompson_make_number_concentrations.F90 + dependencies = Radiation/RRTMG/radcons.f90,Radiation/radiation_aerosols.f + dependencies = Radiation/radiation_astronomy.f,Radiation/radiation_clouds.f,Radiation/radiation_gases.f + dependencies = Radiation/RRTMG/radlw_param.f,Radiation/RRTMG/radsw_param.f,Radiation/radiation_cloud_overlap.F90 + dependencies = SFC_Models/Land/Noah/surface_perturbation.F90 + dependencies = photochem/module_ozphys.F90 ######################################################################## [ccpp-arg-table] @@ -247,6 +252,13 @@ dimensions = () type = integer intent = in +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in [iaermdl] standard_name = control_for_aerosol_radiation_scheme long_name = control of aerosol scheme in radiation diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 similarity index 97% rename from physics/GFS_rrtmg_setup.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 index 384d5252d..e48a60ac8 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 @@ -7,7 +7,7 @@ module GFS_rrtmg_setup use machine, only: kind_phys - + use module_ozphys, only: ty_ozphys implicit none public GFS_rrtmg_setup_init, GFS_rrtmg_setup_timestep_init, GFS_rrtmg_setup_finalize @@ -218,8 +218,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & con_pi ) call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, & con_pi, con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) - call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, & - con_pi, errflg, errmsg) + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, con_pi, errflg, errmsg ) call cld_init ( si, levr, imp_physics, me, con_g, con_rd, errflg, errmsg) call rlwinit ( me, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, & iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & @@ -245,7 +244,8 @@ end subroutine GFS_rrtmg_setup_init !! subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, & lsswr, me, iaermdl, iaerflg, isol, aeros_file, slag, sdec, cdec, & - solcon, con_pi, co2dat_file, co2gbl_file, ictm, ico2, ntoz, errmsg, errflg) + solcon, con_pi, co2dat_file, co2gbl_file, ictm, ico2, ntoz, ozphys,& + errmsg, errflg) implicit none @@ -258,6 +258,7 @@ subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, & logical, intent(in) :: lsswr integer, intent(in) :: me integer, intent(in) :: iaermdl, iaerflg, isol, ictm, ico2, ntoz + type(ty_ozphys), intent(inout) :: ozphys character(len=26), intent(in) :: aeros_file, co2dat_file, co2gbl_file real(kind=kind_phys), intent(out) :: slag real(kind=kind_phys), intent(out) :: sdec @@ -278,7 +279,7 @@ subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, & errflg = 0 call radupdate(idate,jdate,deltsw,deltim,lsswr,me,iaermdl, iaerflg,isol,aeros_file,& - slag,sdec,cdec,solcon,con_pi,co2dat_file,co2gbl_file,ictm,ico2,ntoz,errflg,errmsg) + slag,sdec,cdec,solcon,con_pi,co2dat_file,co2gbl_file,ictm,ico2,ntoz,ozphys,errflg,errmsg) end subroutine GFS_rrtmg_setup_timestep_init @@ -326,7 +327,7 @@ end subroutine GFS_rrtmg_setup_finalize !----------------------------------- subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& iaerflg, isol, aeros_file, slag,sdec,cdec,solcon, con_pi, & - co2dat_file,co2gbl_file, ictm, ico2, ntoz, errflg, errmsg) + co2dat_file,co2gbl_file, ictm, ico2, ntoz, ozphys, errflg, errmsg) !................................... ! ================= subprogram documentation block ================ ! @@ -370,6 +371,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& ! --- inputs: integer, intent(in) :: idate(:), jdate(:), me, iaermdl, iaerflg, isol, ictm, ntoz, ico2 + type(ty_ozphys),intent(inout) :: ozphys logical, intent(in) :: lsswr character(len=26),intent(in) :: aeros_file,co2dat_file,co2gbl_file @@ -462,8 +464,11 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& lco2_chg = .false. endif - call gas_update ( kyear,kmon,kday,khour,loz1st,lco2_chg, me, co2dat_file, & - co2gbl_file, ictm, ico2, ntoz, errflg, errmsg ) + call gas_update ( kyear,kmon,kday,khour,lco2_chg, me, co2dat_file, & + co2gbl_file, ictm, ico2, errflg, errmsg ) + if (ntoz == 0) then + call ozphys%update_o3clim(kmon, kday, khour, loz1st) + endif if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_rrtmg_setup.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.meta similarity index 96% rename from physics/GFS_rrtmg_setup.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.meta index adf6d8750..7f7ad7532 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.meta @@ -1,8 +1,12 @@ [ccpp-table-properties] name = GFS_rrtmg_setup type = scheme - dependencies = iounitdef.f,module_bfmicrophysics.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f - dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f,machine.F + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Radiation/radiation_aerosols.f + dependencies = Radiation/radiation_astronomy.f,Radiation/radiation_clouds.f,Radiation/radiation_gases.f + dependencies = Radiation/RRTMG/radlw_main.F90,Radiation/RRTMG/radlw_param.f,Radiation/RRTMG/radsw_main.F90,Radiation/RRTMG/radsw_param.f + dependencies = MP/Thompson/module_mp_thompson.F90,photochem/module_ozphys.F90 ######################################################################## [ccpp-arg-table] @@ -509,6 +513,13 @@ dimensions = () type = integer intent = in +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = inout [con_pi] standard_name = pi long_name = ratio of a circle's circumference to its diameter diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.F90 similarity index 100% rename from physics/GFS_rrtmgp_cloud_mp.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.F90 diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.meta similarity index 98% rename from physics/GFS_rrtmgp_cloud_mp.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.meta index b782e73b4..f67259b87 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.meta @@ -1,7 +1,10 @@ [ccpp-table-properties] name = GFS_rrtmgp_cloud_mp type = scheme - dependencies = radiation_tools.F90, radiation_clouds.f, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90, rrtmgp_lw_cloud_optics.F90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Radiation/radiation_tools.F90,Radiation/radiation_clouds.f,Radiation/RRTMGP/rrtmgp_lw_cloud_optics.F90 + dependencies = MP/Thompson/module_mp_thompson_make_number_concentrations.F90,MP/Thompson/module_mp_thompson.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.F90 similarity index 100% rename from physics/GFS_rrtmgp_cloud_overlap.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.F90 diff --git a/physics/GFS_rrtmgp_cloud_overlap.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.meta similarity index 98% rename from physics/GFS_rrtmgp_cloud_overlap.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.meta index cf6a05217..4d9af626d 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = GFS_rrtmgp_cloud_overlap type = scheme - dependencies = radiation_tools.F90, radiation_cloud_overlap.F90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Radiation/radiation_tools.F90,Radiation/radiation_cloud_overlap.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.F90 similarity index 100% rename from physics/GFS_rrtmgp_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.F90 diff --git a/physics/GFS_rrtmgp_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.meta similarity index 98% rename from physics/GFS_rrtmgp_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.meta index e4bc3e5dc..5b355849a 100644 --- a/physics/GFS_rrtmgp_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = GFS_rrtmgp_post type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,radiation_tools.F90,rte-rrtmgp/extensions/mo_heating_rates.F90 + relative_path = ../../ + dependencies = hooks/machine.F,Radiation/radiation_aerosols.f + dependencies = Radiation/RRTMG/radlw_param.f,Radiation/radiation_tools.F90,Radiation/RRTMGP/rte-rrtmgp/extensions/mo_heating_rates.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.F90 similarity index 98% rename from physics/GFS_rrtmgp_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.F90 index 009eb8c38..cbf8d161b 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.F90 @@ -8,7 +8,8 @@ module GFS_rrtmgp_pre use machine, only: kind_phys use funcphys, only: fpvs use module_radiation_astronomy, only: coszmn - use module_radiation_gases, only: NF_VGAS, getgases, getozn + use module_radiation_gases, only: NF_VGAS, getgases + use module_ozphys, only: ty_ozphys use mo_gas_concentrations, only: ty_gas_concs use radiation_tools, only: check_error_msg,cmp_tlev use rrtmgp_lw_gas_optics, only: lw_gas_props @@ -117,15 +118,17 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, & relhum, deltaZ, deltaZc, deltaP, active_gases_array, & tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday, semis, & - sfc_emiss_byband, ico2, con_pi, errmsg, errflg) + sfc_emiss_byband, ico2, ozphys, con_pi, errmsg, errflg) - ! Inputs + ! Inputs integer, intent(in) :: & me, & ! MPI rank nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers ico2, & ! Flag for co2 radiation scheme i_o3 ! Index into tracer array for ozone + type(ty_ozphys),intent(in) :: & + ozphys logical, intent(in) :: & doSWrad, & ! Call SW radiation? doLWrad ! Call LW radiation @@ -349,8 +352,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl enddo enddo ! OR Use climatological ozone data - else - call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, top_at_1, o3_lay) + else + call ozphys%run_o3clim(xlat, prslk, con_pi, o3_lay) endif ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.meta similarity index 97% rename from physics/GFS_rrtmgp_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.meta index abb07b825..bd767d14b 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.meta @@ -1,8 +1,9 @@ [ccpp-table-properties] name = GFS_rrtmgp_pre type = scheme - dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_aerosols.f - dependencies = radiation_astronomy.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90 + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F,Radiation/radiation_aerosols.f,photochem/module_ozphys.F90 + dependencies = Radiation/radiation_astronomy.f,Radiation/radiation_gases.f,Radiation/radiation_tools.F90 ######################################################################## [ccpp-arg-table] @@ -503,6 +504,13 @@ dimensions = (horizontal_loop_extent) type = integer intent = inout +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.F90 similarity index 91% rename from physics/GFS_rrtmgp_setup.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.F90 index 76db14279..9f2b2a9f9 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.F90 @@ -6,6 +6,7 @@ module GFS_rrtmgp_setup use module_radiation_astronomy, only : sol_init, sol_update use module_radiation_aerosols, only : aer_init, aer_update use module_radiation_gases, only : gas_init, gas_update + use module_ozphys, only : ty_ozphys implicit none public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_timestep_init, GFS_rrtmgp_setup_finalize @@ -37,9 +38,10 @@ module GFS_rrtmgp_setup subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, si, levr, ictm, isol, ico2, iaer, & - ntcw, ntoz, iovr, isubc_sw, isubc_lw, lalw1bd, idate, me, aeros_file, & - iaermdl, iaerflg, con_pi, con_t0c, con_c, con_boltz, con_plnk, solar_file, & - con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, ipsd0, errmsg, errflg) + ntcw, ntoz, iovr, isubc_sw, isubc_lw, lalw1bd, idate, & + me, aeros_file, iaermdl, iaerflg, con_pi, con_t0c, con_c, con_boltz, con_plnk, & + solar_file, con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, ipsd0, & + errmsg, errflg) ! Inputs logical, intent(in) :: do_RRTMGP @@ -56,9 +58,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, con_pi, con_t0c, con_c, con_boltz, con_plnk, con_solr_2008, con_solr_2002 real(kind_phys), dimension(:), intent(in) :: & si - integer, intent(in) :: levr, ictm, isol, ico2, iaer, & - ntcw, ntoz, iovr, isubc_sw, isubc_lw, & - me + integer, intent(in) :: levr, ictm, isol, ico2, iaer, ntcw, ntoz, iovr, isubc_sw, isubc_lw, me logical, intent(in) :: & lalw1bd integer, intent(in), dimension(:) :: & @@ -129,7 +129,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, & con_c, con_boltz, con_plnk, errflg, errmsg) - call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, errflg, errmsg ) + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, con_pi, errflg, errmsg ) if ( me == 0 ) then print *,' return from rad_initialize (GFS_rrtmgp_setup_init) - after calling radinit' @@ -148,7 +148,7 @@ end subroutine GFS_rrtmgp_setup_init !! subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad, me, & iaermdl, aeros_file, isol, slag, sdec, cdec, solcon, con_pi, co2dat_file, & - co2gbl_file, ictm, ico2, ntoz, errmsg, errflg) + co2gbl_file, ictm, ico2, ntoz, ozphys, errmsg, errflg) ! Inputs integer, intent(in) :: idate(:) @@ -160,7 +160,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad integer, intent(in) :: me integer, intent(in) :: iaermdl,isol,ictm,ico2,ntoz character(len=26), intent(in) :: aeros_file,co2dat_file,co2gbl_file - + type(ty_ozphys),intent(inout) :: ozphys ! Outputs real(kind_phys), intent(out) :: slag real(kind_phys), intent(out) :: sdec @@ -240,8 +240,11 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad else lco2_chg = .false. endif - call gas_update (kyear, kmon, kday, khour, loz1st, lco2_chg, me, co2dat_file, & - co2gbl_file, ictm, ico2, ntoz, errflg, errmsg ) + call gas_update (kyear, kmon, kday, khour, lco2_chg, me, co2dat_file, co2gbl_file, ictm,& + ico2, errflg, errmsg ) + if (ntoz == 0) then + call ozphys%update_o3clim(kmon, kday, khour, loz1st) + endif if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.meta similarity index 96% rename from physics/GFS_rrtmgp_setup.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.meta index c4f7cfaa5..fecb716ed 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.meta @@ -1,8 +1,10 @@ [ccpp-table-properties] name = GFS_rrtmgp_setup type = scheme - dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,radiation_aerosols.f,radiation_astronomy.f - dependencies = module_mp_thompson.F90,radiation_gases.f + relative_path = ../../ + dependencies = hooks/machine.F,MP/Thompson/module_mp_thompson.F90 + dependencies = Radiation/radiation_aerosols.f,photochem/module_ozphys.F90 + dependencies = Radiation/radiation_gases.f,Radiation/radiation_astronomy.f ######################################################################## [ccpp-arg-table] @@ -389,6 +391,13 @@ dimensions = () type = integer intent = in +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = inout [iaermdl] standard_name = control_for_aerosol_radiation_scheme long_name = control of aerosol scheme in radiation diff --git a/physics/GFS_stochastics.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_stochastics.F90 similarity index 100% rename from physics/GFS_stochastics.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_stochastics.F90 diff --git a/physics/GFS_stochastics.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_stochastics.meta similarity index 99% rename from physics/GFS_stochastics.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_stochastics.meta index 796f4ddf7..6c55a09de 100644 --- a/physics/GFS_stochastics.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_stochastics.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_stochastics type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F [ccpp-arg-table] name = GFS_stochastics_init diff --git a/physics/GFS_suite_interstitial_1.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_1.F90 similarity index 100% rename from physics/GFS_suite_interstitial_1.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_1.F90 diff --git a/physics/GFS_suite_interstitial_1.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_1.meta similarity index 99% rename from physics/GFS_suite_interstitial_1.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_1.meta index a465ed320..295ffdf2e 100644 --- a/physics/GFS_suite_interstitial_1.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_1.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_1 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_2.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_2.F90 similarity index 100% rename from physics/GFS_suite_interstitial_2.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_2.F90 diff --git a/physics/GFS_suite_interstitial_2.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_2.meta similarity index 99% rename from physics/GFS_suite_interstitial_2.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_2.meta index 1f4300574..de4db5f9f 100644 --- a/physics/GFS_suite_interstitial_2.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_2.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_2 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.F90 similarity index 100% rename from physics/GFS_suite_interstitial_3.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.F90 diff --git a/physics/GFS_suite_interstitial_3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.meta similarity index 99% rename from physics/GFS_suite_interstitial_3.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.meta index e8f9fe889..22f57e354 100644 --- a/physics/GFS_suite_interstitial_3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_3 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_4.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.F90 similarity index 100% rename from physics/GFS_suite_interstitial_4.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.F90 diff --git a/physics/GFS_suite_interstitial_4.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.meta similarity index 98% rename from physics/GFS_suite_interstitial_4.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.meta index 92870d95f..c0df52f1a 100644 --- a/physics/GFS_suite_interstitial_4.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.meta @@ -2,7 +2,9 @@ [ccpp-table-properties] name = GFS_suite_interstitial_4 type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = MP/Thompson/module_mp_thompson_make_number_concentrations.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_5.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_5.F90 similarity index 100% rename from physics/GFS_suite_interstitial_5.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_5.F90 diff --git a/physics/GFS_suite_interstitial_5.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_5.meta similarity index 98% rename from physics/GFS_suite_interstitial_5.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_5.meta index 9d32160a1..511137901 100644 --- a/physics/GFS_suite_interstitial_5.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_5.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_5 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_phys_reset.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_phys_reset.F90 similarity index 100% rename from physics/GFS_suite_interstitial_phys_reset.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_phys_reset.F90 diff --git a/physics/GFS_suite_interstitial_phys_reset.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_phys_reset.meta similarity index 96% rename from physics/GFS_suite_interstitial_phys_reset.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_phys_reset.meta index adebbc833..947a1950f 100644 --- a/physics/GFS_suite_interstitial_phys_reset.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_phys_reset.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_phys_reset type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_rad_reset.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_rad_reset.F90 similarity index 100% rename from physics/GFS_suite_interstitial_rad_reset.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_rad_reset.F90 diff --git a/physics/GFS_suite_interstitial_rad_reset.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_rad_reset.meta similarity index 96% rename from physics/GFS_suite_interstitial_rad_reset.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_rad_reset.meta index 91fd8cba7..aaaff02f5 100644 --- a/physics/GFS_suite_interstitial_rad_reset.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_rad_reset.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_rad_reset type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_stateout_reset.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_reset.F90 similarity index 100% rename from physics/GFS_suite_stateout_reset.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_reset.F90 diff --git a/physics/GFS_suite_stateout_reset.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_reset.meta similarity index 98% rename from physics/GFS_suite_stateout_reset.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_reset.meta index fa4111e6b..b84d10691 100644 --- a/physics/GFS_suite_stateout_reset.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_reset.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_stateout_reset type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.F90 new file mode 100644 index 000000000..e9e477fce --- /dev/null +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.F90 @@ -0,0 +1,91 @@ +! ######################################################################################### +!> \file GFS_suite_stateout_update.f90 +!! Update the state variables due to process-split physics from accumulated tendencies +!! during that phase. +!! Update gas concentrations, if using prognostic photolysis schemes. +!! Also, set bounds on the mass-weighted rime factor when using Ferrier-Aligo microphysics. +! ######################################################################################### +module GFS_suite_stateout_update + use machine, only: kind_phys + use module_ozphys, only: ty_ozphys + implicit none +contains +! ######################################################################################### +!> \section arg_table_GFS_suite_stateout_update_run Argument Table +!! \htmlinclude GFS_suite_stateout_update_run.html +!! +! ######################################################################################### + subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, tgrs, ugrs, vgrs, qgrs, & + dudt, dvdt, dtdt, dqdt, gt0, gu0, gv0, gq0, oz0, ntiw, nqrimef, imp_physics, & + imp_physics_fer_hires, epsq, ozphys, oz_phys_2015, oz_phys_2006, con_1ovg, prsl, & + dp, ozpl, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, errmsg, errflg) + + ! Inputs + integer, intent(in ) :: im + integer, intent(in ) :: levs + integer, intent(in ) :: ntrac + integer, intent(in ) :: imp_physics,imp_physics_fer_hires + integer, intent(in ) :: ntiw, nqrimef + real(kind=kind_phys), intent(in ) :: dtp, epsq, con_1ovg + real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs, prsl, dp + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs, ozpl + real(kind=kind_phys), intent(in ), dimension(:,:) :: dudt, dvdt, dtdt + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: dqdt + logical, intent(in) :: oz_phys_2015 + logical, intent(in) :: oz_phys_2006 + type(ty_ozphys), intent(in) :: ozphys + + ! Outputs (optional) + real(kind=kind_phys), intent(inout), dimension(:,:), pointer, optional :: & + do3_dt_prd, & ! Physics tendency: production and loss effect + do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect + do3_dt_temp, & ! Physics tendency: temperature effect + do3_dt_ohoz ! Physics tendency: overhead ozone effect + + ! Outputs + real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0, oz0 + real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Locals + integer :: i, k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Update prognostic state varaibles using accumulated tendencies from "process-split" + ! section of GFS suite. + gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp + gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp + gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp + gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp + + ! If using photolysis physics schemes, update (prognostic) gas concentrations using + ! updated state. + if (oz_phys_2015) then + call ozphys%run_o3prog_2015(con_1ovg, dtp, prsl, gt0, dp, ozpl, oz0, do3_dt_prd, & + do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) + endif + if (oz_phys_2006) then + call ozphys%run_o3prog_2006(con_1ovg, dtp, prsl, gt0, dp, ozpl, oz0, do3_dt_prd, & + do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) + endif + + ! If using Ferrier-Aligo microphysics, set bounds on the mass-weighted rime factor. + if (imp_physics == imp_physics_fer_hires) then + do k=1,levs + do i=1,im + if(gq0(i,k,ntiw) > epsq) then + gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) + else + gq0(i,k,nqrimef) = 1. + end if + end do + end do + end if + + end subroutine GFS_suite_stateout_update_run + +end module GFS_suite_stateout_update diff --git a/physics/GFS_suite_stateout_update.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.meta similarity index 63% rename from physics/GFS_suite_stateout_update.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.meta index 580482b71..9f8977482 100644 --- a/physics/GFS_suite_stateout_update.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_stateout_update type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F,../../photochem/module_ozphys.F90 ######################################################################## [ccpp-arg-table] @@ -37,6 +37,27 @@ type = real kind = kind_phys intent = in +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in +[oz_phys_2015] + standard_name = flag_for_nrl_2015_ozone_scheme + long_name = flag for new (2015) ozone physics + units = flag + dimensions = () + type = logical + intent = in +[oz_phys_2006] + standard_name = flag_for_nrl_2006_ozone_scheme + long_name = flag for new (2006) ozone physics + units = flag + dimensions = () + type = logical + intent = in [tgrs] standard_name = air_temperature long_name = model layer mean temperature @@ -133,6 +154,14 @@ type = real kind = kind_phys intent = out +[oz0] + standard_name = ozone_concentration_of_new_state + long_name = ozone concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [ntiw] standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array long_name = tracer index for ice water @@ -169,6 +198,70 @@ type = real kind = kind_phys intent = in +[con_1ovg] + standard_name = one_divided_by_the_gravitational_acceleration + long_name = inverse of gravitational acceleration + units = s2 m-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mid-layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ozpl] + standard_name = ozone_forcing + long_name = ozone forcing data + units = mixed + dimensions = (horizontal_loop_extent,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_data) + type = real + kind = kind_phys + intent = in +[dp] + standard_name = air_pressure_difference_between_midlayers + long_name = difference between mid-layer pressures + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[do3_dt_prd] + standard_name = ozone_tendency_due_to_production_and_loss_rate + long_name = ozone tendency due to production and loss rate + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[do3_dt_ozmx] + standard_name = ozone_tendency_due_to_ozone_mixing_ratio + long_name = ozone tendency due to ozone mixing ratio + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[do3_dt_temp] + standard_name = ozone_tendency_due_to_temperature + long_name = ozone tendency due to temperature + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[do3_dt_ohoz] + standard_name = ozone_tendency_due_to_overhead_ozone_column + long_name = ozone tendency due to overhead ozone column + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_surface_composites_inter.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_inter.F90 similarity index 100% rename from physics/GFS_surface_composites_inter.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_inter.F90 diff --git a/physics/GFS_surface_composites_inter.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_inter.meta similarity index 99% rename from physics/GFS_surface_composites_inter.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_inter.meta index 36af0ef5a..ef3005583 100644 --- a/physics/GFS_surface_composites_inter.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_inter.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_surface_composites_inter type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_composites_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.F90 similarity index 100% rename from physics/GFS_surface_composites_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.F90 diff --git a/physics/GFS_surface_composites_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.meta similarity index 99% rename from physics/GFS_surface_composites_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.meta index d0c465452..e4a364e04 100644 --- a/physics/GFS_surface_composites_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.meta @@ -2,7 +2,8 @@ [ccpp-table-properties] name = GFS_surface_composites_post type = scheme - dependencies = machine.F,sfc_diff.f + relative_path = ../../ + dependencies = hooks/machine.F,SFC_Layer/UFS/sfc_diff.f ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.F90 similarity index 98% rename from physics/GFS_surface_composites_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.F90 index 98b9fecd2..fd16dea59 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.F90 @@ -241,8 +241,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, iopt_lake, iopt_l !mjz tsfcl(i) = huge endif + if (icy(i) .or. wet(i)) then ! init uustar_ice for all water/ice grids + uustar_ice(i) = uustar(i) + endif if (icy(i)) then ! Ice - uustar_ice(i) = uustar(i) is_clm = lkm>0 .and. iopt_lake==iopt_lake_clm .and. use_lake_model(i)>0 if(lsm /= lsm_ruc .and. .not.is_clm) then weasd_ice(i) = weasd(i) diff --git a/physics/GFS_surface_composites_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.meta similarity index 99% rename from physics/GFS_surface_composites_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.meta index d6b9003fe..33e2f0523 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_surface_composites_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.F90 similarity index 99% rename from physics/GFS_surface_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.F90 index 9faebc8cf..7e8cfa753 100644 --- a/physics/GFS_surface_generic_post.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.F90 @@ -130,6 +130,8 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl if (cplflx .or. cpllnd) then do i=1,im + dlwsfci_cpl (i) = adjsfcdlw(i) + dswsfci_cpl (i) = adjsfcdsw(i) dlwsfc_cpl (i) = dlwsfc_cpl(i) + adjsfcdlw(i)*dtf dswsfc_cpl (i) = dswsfc_cpl(i) + adjsfcdsw(i)*dtf psurfi_cpl (i) = pgr(i) @@ -138,8 +140,6 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl if (cplflx) then do i=1,im - dlwsfci_cpl (i) = adjsfcdlw(i) - dswsfci_cpl (i) = adjsfcdsw(i) dnirbmi_cpl (i) = adjnirbmd(i) dnirdfi_cpl (i) = adjnirdfd(i) dvisbmi_cpl (i) = adjvisbmd(i) @@ -242,7 +242,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl tedir(i) = tedir(i) + edir(i) * dtf if (lsm == lsm_noahmp) then paha(i) = paha(i) + pah(i) * dtf - twa(i) = waxy(i) + twa(i) = waxy(i) endif enddo endif @@ -252,7 +252,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl ! heat torage parameterization the kinematic sensible heat flux ! (hflx) as surface boundary forcing to the pbl scheme is ! reduced in a factor of hffac given as a function of surface roughness & -! green vegetation fraction (zvfun) +! green vegetation fraction (zvfun) ! do i=1,im hflxq(i) = hflx(i) diff --git a/physics/GFS_surface_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.meta similarity index 99% rename from physics/GFS_surface_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.meta index 9658be7d8..2c28b17d7 100644 --- a/physics/GFS_surface_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_surface_generic_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_pre.F90 similarity index 100% rename from physics/GFS_surface_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_pre.F90 diff --git a/physics/GFS_surface_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_pre.meta similarity index 99% rename from physics/GFS_surface_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_pre.meta index d78988787..bbf7dd5c3 100644 --- a/physics/GFS_surface_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_pre.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_surface_generic_pre type = scheme - dependencies = machine.F,surface_perturbation.F90 + relative_path = ../../ + dependencies = hooks/machine.F,SFC_Models/Land/Noah/surface_perturbation.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_loop_control_part1.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.F90 similarity index 100% rename from physics/GFS_surface_loop_control_part1.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.F90 diff --git a/physics/GFS_surface_loop_control_part1.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.meta similarity index 97% rename from physics/GFS_surface_loop_control_part1.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.meta index f178320ee..4bf962f6e 100644 --- a/physics/GFS_surface_loop_control_part1.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_surface_loop_control_part1 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_loop_control_part2.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.F90 similarity index 100% rename from physics/GFS_surface_loop_control_part2.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.F90 diff --git a/physics/GFS_surface_loop_control_part2.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.meta similarity index 98% rename from physics/GFS_surface_loop_control_part2.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.meta index 7c9bc7408..ba19bf437 100644 --- a/physics/GFS_surface_loop_control_part2.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_surface_loop_control_part2 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.F90 similarity index 100% rename from physics/GFS_time_vary_pre.fv3.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.F90 diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.meta similarity index 98% rename from physics/GFS_time_vary_pre.fv3.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.meta index 3ec92287a..c6dd95bce 100644 --- a/physics/GFS_time_vary_pre.fv3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_time_vary_pre type = scheme - dependencies = funcphys.f90,machine.F + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_time_vary_pre.scm.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.F90 similarity index 100% rename from physics/GFS_time_vary_pre.scm.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.F90 diff --git a/physics/GFS_time_vary_pre.scm.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.meta similarity index 98% rename from physics/GFS_time_vary_pre.scm.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.meta index 20708c51e..af9afcdfe 100644 --- a/physics/GFS_time_vary_pre.scm.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_time_vary_pre type = scheme - dependencies = funcphys.f90,machine.F + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cnvc90.f b/physics/Interstitials/UFS_SCM_NEPTUNE/cnvc90.f similarity index 100% rename from physics/cnvc90.f rename to physics/Interstitials/UFS_SCM_NEPTUNE/cnvc90.f diff --git a/physics/cnvc90.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/cnvc90.meta similarity index 98% rename from physics/cnvc90.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/cnvc90.meta index 9728266d4..bbf161eb5 100644 --- a/physics/cnvc90.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/cnvc90.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cnvc90 type = scheme - dependencies = + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/dcyc2t3.f b/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.f similarity index 100% rename from physics/dcyc2t3.f rename to physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.f diff --git a/physics/dcyc2t3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.meta similarity index 99% rename from physics/dcyc2t3.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.meta index 65b05f4b3..95b3f341b 100644 --- a/physics/dcyc2t3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = dcyc2t3 type = scheme - dependencies = machine.F,physcons.F90 + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gcycle.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/gcycle.F90 similarity index 100% rename from physics/gcycle.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/gcycle.F90 diff --git a/physics/iccn_def.F b/physics/Interstitials/UFS_SCM_NEPTUNE/iccn_def.F similarity index 100% rename from physics/iccn_def.F rename to physics/Interstitials/UFS_SCM_NEPTUNE/iccn_def.F diff --git a/physics/iccninterp.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/iccninterp.F90 similarity index 100% rename from physics/iccninterp.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/iccninterp.F90 diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/maximum_hourly_diagnostics.F90 similarity index 100% rename from physics/maximum_hourly_diagnostics.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/maximum_hourly_diagnostics.F90 diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/maximum_hourly_diagnostics.meta similarity index 99% rename from physics/maximum_hourly_diagnostics.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/maximum_hourly_diagnostics.meta index e9d0876d2..0c2d1bcbe 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/maximum_hourly_diagnostics.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = maximum_hourly_diagnostics type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/scm_sfc_flux_spec.F90 similarity index 100% rename from physics/scm_sfc_flux_spec.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/scm_sfc_flux_spec.F90 diff --git a/physics/scm_sfc_flux_spec.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/scm_sfc_flux_spec.meta similarity index 99% rename from physics/scm_sfc_flux_spec.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/scm_sfc_flux_spec.meta index 52722f1c4..85bf403ad 100644 --- a/physics/scm_sfc_flux_spec.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/scm_sfc_flux_spec.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = scm_sfc_flux_spec type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/sfcsub.F b/physics/Interstitials/UFS_SCM_NEPTUNE/sfcsub.F similarity index 99% rename from physics/sfcsub.F rename to physics/Interstitials/UFS_SCM_NEPTUNE/sfcsub.F index 7be07b39c..494b8f7dc 100644 --- a/physics/sfcsub.F +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/sfcsub.F @@ -7491,9 +7491,6 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & endif call abort endif -! -! soil type - print *,'in FIXREAD fnsotc =',fnsotc ! if(fnsotc(1:8).ne.' ') then if ( index(fnsotc, "tileX.nc") == 0) then ! grib file diff --git a/physics/sgscloud_radpost.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpost.F90 similarity index 100% rename from physics/sgscloud_radpost.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpost.F90 diff --git a/physics/sgscloud_radpost.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpost.meta similarity index 98% rename from physics/sgscloud_radpost.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpost.meta index 6ad91d496..046531a0a 100644 --- a/physics/sgscloud_radpost.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpost.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = sgscloud_radpost type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/sgscloud_radpre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.F90 similarity index 98% rename from physics/sgscloud_radpre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.F90 index 44ab87bcc..936393d5b 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.F90 @@ -216,10 +216,10 @@ subroutine sgscloud_radpre_run( & qi(i,k) = ice_frac*qi_bl(i,k) !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) - if(qi(i,k)>1.E-8)clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) + clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 8b) !iwc = qi(i,k)*1.0e6*rho(i,k) - !IF(qi(i,k)>1.E-8)clouds5(i,k)=MAX(139.7 + 1.76*Tc + 13.49*LOG(iwc), 20.) + !clouds5(i,k)=MAX(139.7 + 1.76*Tc + 13.49*LOG(iwc), 20.) !calculate the ice water path using additional BL clouds clouds4(i,k) = max(0.0, qi(i,k) * gfac * delp(i,k)) @@ -229,7 +229,7 @@ subroutine sgscloud_radpre_run( & qs(i,k) = snow_frac*qi_bl(i,k) !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) - if(qs(i,k)>1.E-8)clouds9(i,k)=max(2.*(173.45 + 2.14*Tc), 50.) + clouds9(i,k)=max(2.*(173.45 + 2.14*Tc), 50.) !calculate the snow water path using additional BL clouds clouds8(i,k) = max(0.0, qs(i,k) * gfac * delp(i,k)) diff --git a/physics/sgscloud_radpre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.meta similarity index 98% rename from physics/sgscloud_radpre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.meta index d5341bcd4..a9635efa5 100644 --- a/physics/sgscloud_radpre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.meta @@ -1,7 +1,10 @@ [ccpp-table-properties] name = sgscloud_radpre type = scheme - dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_clouds.f,module_mp_thompson.F90 + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F + dependencies = hooks/physcons.F90,Radiation/RRTMG/radcons.f90 + dependencies = Radiation/radiation_clouds.f,MP/Thompson/module_mp_thompson.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/module_MP_FER_HIRES.F90 b/physics/MP/Ferrier_Aligo/module_MP_FER_HIRES.F90 similarity index 100% rename from physics/module_MP_FER_HIRES.F90 rename to physics/MP/Ferrier_Aligo/module_MP_FER_HIRES.F90 diff --git a/physics/mp_fer_hires.F90 b/physics/MP/Ferrier_Aligo/mp_fer_hires.F90 similarity index 100% rename from physics/mp_fer_hires.F90 rename to physics/MP/Ferrier_Aligo/mp_fer_hires.F90 diff --git a/physics/mp_fer_hires.meta b/physics/MP/Ferrier_Aligo/mp_fer_hires.meta similarity index 99% rename from physics/mp_fer_hires.meta rename to physics/MP/Ferrier_Aligo/mp_fer_hires.meta index 9f7c63d4d..0f7be213e 100644 --- a/physics/mp_fer_hires.meta +++ b/physics/MP/Ferrier_Aligo/mp_fer_hires.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mp_fer_hires type = scheme - dependencies = machine.F,module_MP_FER_HIRES.F90 + dependencies = ../../hooks/machine.F,module_MP_FER_HIRES.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFDL_parse_tracers.F90 b/physics/MP/GFDL/GFDL_parse_tracers.F90 similarity index 100% rename from physics/GFDL_parse_tracers.F90 rename to physics/MP/GFDL/GFDL_parse_tracers.F90 diff --git a/physics/fv_sat_adj.F90 b/physics/MP/GFDL/fv_sat_adj.F90 similarity index 100% rename from physics/fv_sat_adj.F90 rename to physics/MP/GFDL/fv_sat_adj.F90 diff --git a/physics/fv_sat_adj.meta b/physics/MP/GFDL/fv_sat_adj.meta similarity index 98% rename from physics/fv_sat_adj.meta rename to physics/MP/GFDL/fv_sat_adj.meta index 5cdc96358..c91e438b7 100644 --- a/physics/fv_sat_adj.meta +++ b/physics/MP/GFDL/fv_sat_adj.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = fv_sat_adj type = scheme - dependencies = machine.F,module_gfdl_cloud_microphys.F90,module_mp_radar.F90,multi_gases.F90,physcons.F90 + dependencies = ../../hooks/machine.F,../../hooks/physcons.F90 + dependencies = module_gfdl_cloud_microphys.F90,multi_gases.F90 + dependencies = ../module_mp_radar.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/MP/GFDL/gfdl_cloud_microphys.F90 similarity index 100% rename from physics/gfdl_cloud_microphys.F90 rename to physics/MP/GFDL/gfdl_cloud_microphys.F90 diff --git a/physics/gfdl_cloud_microphys.meta b/physics/MP/GFDL/gfdl_cloud_microphys.meta similarity index 99% rename from physics/gfdl_cloud_microphys.meta rename to physics/MP/GFDL/gfdl_cloud_microphys.meta index 5e752b473..719a340e5 100644 --- a/physics/gfdl_cloud_microphys.meta +++ b/physics/MP/GFDL/gfdl_cloud_microphys.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = gfdl_cloud_microphys type = scheme - dependencies = machine.F,module_mp_radar.F90,module_gfdl_cloud_microphys.F90 + dependencies = ../../hooks/machine.F + dependencies = ../module_mp_radar.F90 + dependencies = module_gfdl_cloud_microphys.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/module_gfdl_cloud_microphys.F90 b/physics/MP/GFDL/module_gfdl_cloud_microphys.F90 similarity index 100% rename from physics/module_gfdl_cloud_microphys.F90 rename to physics/MP/GFDL/module_gfdl_cloud_microphys.F90 diff --git a/physics/multi_gases.F90 b/physics/MP/GFDL/multi_gases.F90 similarity index 100% rename from physics/multi_gases.F90 rename to physics/MP/GFDL/multi_gases.F90 diff --git a/physics/aer_cloud.F b/physics/MP/Morrison_Gettelman/aer_cloud.F similarity index 100% rename from physics/aer_cloud.F rename to physics/MP/Morrison_Gettelman/aer_cloud.F diff --git a/physics/aerclm_def.F b/physics/MP/Morrison_Gettelman/aerclm_def.F similarity index 100% rename from physics/aerclm_def.F rename to physics/MP/Morrison_Gettelman/aerclm_def.F diff --git a/physics/aerinterp.F90 b/physics/MP/Morrison_Gettelman/aerinterp.F90 similarity index 100% rename from physics/aerinterp.F90 rename to physics/MP/Morrison_Gettelman/aerinterp.F90 diff --git a/physics/cldmacro.F b/physics/MP/Morrison_Gettelman/cldmacro.F similarity index 100% rename from physics/cldmacro.F rename to physics/MP/Morrison_Gettelman/cldmacro.F diff --git a/physics/cldwat2m_micro.F b/physics/MP/Morrison_Gettelman/cldwat2m_micro.F similarity index 100% rename from physics/cldwat2m_micro.F rename to physics/MP/Morrison_Gettelman/cldwat2m_micro.F diff --git a/physics/m_micro.F90 b/physics/MP/Morrison_Gettelman/m_micro.F90 similarity index 100% rename from physics/m_micro.F90 rename to physics/MP/Morrison_Gettelman/m_micro.F90 diff --git a/physics/m_micro.meta b/physics/MP/Morrison_Gettelman/m_micro.meta similarity index 99% rename from physics/m_micro.meta rename to physics/MP/Morrison_Gettelman/m_micro.meta index a9b5ec4db..16efc5cc4 100644 --- a/physics/m_micro.meta +++ b/physics/MP/Morrison_Gettelman/m_micro.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = m_micro type = scheme - dependencies = aer_cloud.F,aerclm_def.F,cldmacro.F,cldwat2m_micro.F,machine.F,micro_mg_utils.F90,micro_mg2_0.F90,micro_mg3_0.F90,physcons.F90,wv_saturation.F,machine.F + dependencies = ../../hooks/machine.F,../../hooks/physcons.F90 + dependencies = aer_cloud.F,aerclm_def.F,cldmacro.F,cldwat2m_micro.F + dependencies = micro_mg_utils.F90,micro_mg2_0.F90,micro_mg3_0.F90,wv_saturation.F ######################################################################## [ccpp-arg-table] diff --git a/physics/m_micro_post.F90 b/physics/MP/Morrison_Gettelman/m_micro_post.F90 similarity index 100% rename from physics/m_micro_post.F90 rename to physics/MP/Morrison_Gettelman/m_micro_post.F90 diff --git a/physics/m_micro_post.meta b/physics/MP/Morrison_Gettelman/m_micro_post.meta similarity index 99% rename from physics/m_micro_post.meta rename to physics/MP/Morrison_Gettelman/m_micro_post.meta index 684ac3f21..88a4325e7 100644 --- a/physics/m_micro_post.meta +++ b/physics/MP/Morrison_Gettelman/m_micro_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = m_micro_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/m_micro_pre.F90 b/physics/MP/Morrison_Gettelman/m_micro_pre.F90 similarity index 100% rename from physics/m_micro_pre.F90 rename to physics/MP/Morrison_Gettelman/m_micro_pre.F90 diff --git a/physics/m_micro_pre.meta b/physics/MP/Morrison_Gettelman/m_micro_pre.meta similarity index 99% rename from physics/m_micro_pre.meta rename to physics/MP/Morrison_Gettelman/m_micro_pre.meta index 7ac592833..b8cd2ac32 100644 --- a/physics/m_micro_pre.meta +++ b/physics/MP/Morrison_Gettelman/m_micro_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = m_micro_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/micro_mg2_0.F90 b/physics/MP/Morrison_Gettelman/micro_mg2_0.F90 similarity index 100% rename from physics/micro_mg2_0.F90 rename to physics/MP/Morrison_Gettelman/micro_mg2_0.F90 diff --git a/physics/micro_mg3_0.F90 b/physics/MP/Morrison_Gettelman/micro_mg3_0.F90 similarity index 100% rename from physics/micro_mg3_0.F90 rename to physics/MP/Morrison_Gettelman/micro_mg3_0.F90 diff --git a/physics/micro_mg_utils.F90 b/physics/MP/Morrison_Gettelman/micro_mg_utils.F90 similarity index 100% rename from physics/micro_mg_utils.F90 rename to physics/MP/Morrison_Gettelman/micro_mg_utils.F90 diff --git a/physics/wv_saturation.F b/physics/MP/Morrison_Gettelman/wv_saturation.F similarity index 100% rename from physics/wv_saturation.F rename to physics/MP/Morrison_Gettelman/wv_saturation.F diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/MP/NSSL/module_mp_nssl_2mom.F90 similarity index 77% rename from physics/module_mp_nssl_2mom.F90 rename to physics/MP/NSSL/module_mp_nssl_2mom.F90 index 409bf4019..ad90ec81f 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/MP/NSSL/module_mp_nssl_2mom.F90 @@ -1,7 +1,14 @@ !> \file module_mp_nssl_2mom.F90 + + + + + + + !--------------------------------------------------------------------- -! code snapshot: "Feb 24 2022" at "14:27:57" +! code snapshot: "Sep 22 2023" at "22:01:53" !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: @@ -19,37 +26,32 @@ ! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; ! !>\ingroup mod_mp_nssl2m -!! This module provides a 2-moment bulk microphysics scheme described by -!! Mansell, Zeigler, and Bruning (2010, JAS) -!! -!! This module provides a 2-moment bulk microphysics scheme based on a combination of -!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in -!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation +!! This module provides a 1/2/3-moment bulk microphysics scheme based on a combination of +!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in +!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation !! follows Mansell (2010, JAS), using parameter infall = 4. !! !! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) !! -!! Average graupel particle density is predicted, which affects fall speed as well. -!! Hail density prediction is by default disabled in this version, but may be enabled -!! at some point if there is interest. +!! Average graupel and hail particle densities are predicted, which affects fall speed as well. !! !! Maintainer: Ted Mansell, National Severe Storms Laboratory !! !! Microphysics References: !! -!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small +!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small !! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. !! -!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and -!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, +!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and +!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, !! doi:10.1175/JAS-D-12-0264.1. !! -!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. +!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. !! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. !! !! Sedimentation reference: !! -!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. +!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. !! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. ! ! Possible parameters to adjust: @@ -63,18 +65,25 @@ ! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The ! implementation of an explicit charging and discharge lightning scheme ! within the WRF-ARW model: Benchmark simulations of a continental squall line, a -! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 +! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 ! -! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated +! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated ! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287 ! ! Note: Some parameters below apply to unreleased features. ! ! !--------------------------------------------------------------------- +! Apr. 2023 +! - Update to 3-moment for rain, graupel, and hail +! - Change default graupel/hail fall speeds to icdx/icdxhl=6 (Milbrandt & Morrison 2013) +! and also set default ehw0=0.9 and ehlw0=0.9 to compensate for lower fall speeds. +! - Change default hail conversion to ihlcnh=-1, and then =1 for 2-mom or =3 for 3-mom, +! using wet growth diameter to convert large graupel +!--------------------------------------------------------------------- ! Sept. 2021: ! Fixes: -! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed +! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed ! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics) ! Other: ! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect) @@ -221,7 +230,7 @@ MODULE module_mp_nssl_2mom real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params - real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params + real, private :: rho_qhl= 800., cnohl = 4.0e4 ! set in namelist!! hail params real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel) real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail) @@ -234,8 +243,9 @@ MODULE module_mp_nssl_2mom real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) - real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value - real , public :: qccn ! ccn "mixing ratio" + real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , private :: ccnuf = 0 ! set in namelist!! Central plains CCN value + real , public :: qccn, qccnuf ! ccn "mixing ratio" real , private :: old_qccn = -1.0 integer, private :: iauttim = 1 ! 10-ice rain delay flag real , private :: auttim = 300. ! 10-ice rain delay time @@ -245,12 +255,17 @@ MODULE module_mp_nssl_2mom ! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state #else - logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state + logical, private :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state #endif logical :: switchccn = .false. real :: old_cccn = -1.0 logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) + real, private :: restoreccnfrac = 1.0 ! fraction of evaporated droplets that restore CCN + real :: ufccntimeconst = 6.*3600. ! time constant for UFCCN decay (Blossey et al. 2018) + real :: ufbackground = 0.1e9 ! background ccnuf value (Blossey et al.) + logical :: decayufccn = .false. + integer :: i_uf_or_ccn = 0 ! 0 = ship adds UF; 1 = treat UF as regular ccn (add to qccn) ! sedimentation flags ! itfall -> 0 = 1st order fallout (other options removed) @@ -259,6 +274,7 @@ MODULE module_mp_nssl_2mom integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, private :: irfall = -1 + integer, private :: isfall = 2 ! default limit with method II (more restrictive) logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive) ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) ! Mainly is an issue for small dz near the surface. @@ -269,14 +285,20 @@ MODULE module_mp_nssl_2mom ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. + integer :: imydiagalpha = 0 ! apply MY diagnostic shape parameter for fall speeds (1=for fall speed only; 2=also for microphysics rates) real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) - integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. - integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + integer, private :: icdx = 6 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + ! 6= Milbrandt and Morrison (2013) density-based fall speed + integer, private :: icdxhl = 6 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + ! 6= Milbrandt and Morrison (2013) density-based fall speed + real :: axh = 75.7149, bxh = 0.5 + real :: axf = 75.7149, bxf = 0.5 + real :: axhl = 206.984, bxhl = 0.6384 real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4) real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4) real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) @@ -310,7 +332,7 @@ MODULE module_mp_nssl_2mom integer, private :: irimtim = 0 ! future use ! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds - integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993) + integer, private :: irimdenopt = 1 ! = 1 for default Heymsfield and Pflaum (1985); = 2 for experimental Cober and List (1993); = 3 Macklin real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985) real , private :: rimc3 = 170.0 ! minimum rime density real :: rimc4 = 900.0 ! maximum rime density @@ -325,7 +347,7 @@ MODULE module_mp_nssl_2mom ! (first nucleation is done with a KW sat. adj. step) integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) - integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud + integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete) ! =2 renucleation following Twomey/Cohard&Pinty ! =7 New renucleation that requires prediction of the number of activated nuclei ! i.e., not only at cloud base @@ -347,6 +369,7 @@ MODULE module_mp_nssl_2mom ! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process + integer, private :: in_freeze_rain_first = 0 ! =1 use IN to freezed rain drops (if none, then freeze droplets) integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version @@ -357,7 +380,9 @@ MODULE module_mp_nssl_2mom integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron) + integer, private :: icrcev = 1 ! 1 = old crcev; 2 = crcev scaled by vtrain ratio (num/mass); 3 = set to zero integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off) + integer, private :: icracrthresh = 1 ! For rain self-coll. thresh. use: 1 = mean diam of 2mm; 2 = rain median volume diam of 1.9mm integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) @@ -413,11 +438,15 @@ MODULE module_mp_nssl_2mom ! set eii1 = 0 to get a constant value of eii0 real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) ! set eii1hl = 0 to get a constant value of eii0hl + real, private :: ewi_dcmin = 15.0e-06 ! minimum droplet diameter for nonzero ewi + real, private :: ewi_dimin = 30.0e-06 ! minimum ice crystal diameter for nonzero ewi real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! set ehs1 = 0 to get a constant value of ehs0 + integer :: iessopt = 1 ! 1 = Original (no factor); 2 = factor based on wvel; 3 = factor based on SSI + ! 4 = as 3 but sets min factor of 0.1 and goes to full value at 0.5% SSI real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) ! set ess1 = 0 to get a constant value of ess0 real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on @@ -452,11 +481,13 @@ MODULE module_mp_nssl_2mom ! 0 = no condensation on rain; 1 = bulk condensation on rain integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) + integer, private :: iqis0 = 2 ! = 1 for normal qis; = 2 to set qis to use T = 0C when T > 0C real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 ! and for ciacrf for iacr=4 real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + integer, private :: ivshdgs = 1 ! 0 = use 1mm for all shedding (non-mixedphase); 1 = use vshdgs with sheddiam integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail @@ -480,6 +511,7 @@ MODULE module_mp_nssl_2mom real, private :: qhdpvdn = -1. real, private :: qhacidn = -1. + integer, private :: iraintypes = 0 logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel integer, private :: imixedphase = 0 logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density @@ -511,17 +543,23 @@ MODULE module_mp_nssl_2mom real, parameter :: alpharmax = 8. ! limited for rwvent calculation - integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use + integer, private :: ihlcnh = -1 ! which graupel -> hail conversion to use ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter ! 2 = Straka and Mansell (2005) conversion using size threshold + ! 3 = Conversion using wet growth diameter real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) - real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + real , private :: hldia1 = 10.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer, private :: incwet = 0 ! flag to do wet growth only on D > D_wet integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on) - real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwetmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwmax = 15.e-3 ! for ihlcnh, always convert this size and larger whether or not there is wet growth real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + integer :: ifddenfac = 0 ! = 1 to use density threshold to count FD as GR when converting to HL + real :: fddenthresh = 500. ! if ifddenfac > 0, then hail from FD with lower density are considered to come from graupel integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. @@ -538,6 +576,8 @@ MODULE module_mp_nssl_2mom ! = 1 use mean diameter for breakup ! = 2 use maximum mass diameter for breakup ! = 3 use mass-weighted diameter for breakup + integer :: iraintailbreak = 0 ! 1 = on + real :: draintail = 8.e-3 ! starting size for rain breakup integer, private :: dmrauto = 0 ! = -1 no limiter on crcnw ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) @@ -545,7 +585,7 @@ MODULE module_mp_nssl_2mom ! = 2 DTD mass-weighted version based on MY code ! = 3 Milbrandt version (from Cohard and Pinty code integer :: dmropt = 0 ! extra option for crcnw - integer :: dmhlopt = 1 ! options for graupel -> conversion + integer :: dmhlopt = 0 ! options for graupel -> hail conversion integer :: irescalerainopt = 3 ! 0 = default option ! 1 = qx(mgs,lc) > qxmin(lc) ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 @@ -562,7 +602,7 @@ MODULE module_mp_nssl_2mom integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting ! when liquid fraction is not predicted - logical :: iwetsoak = .true. ! soak and freeze during wet growth or not + logical, private :: iwetsoak = .true. ! soak and freeze during wet growth or not integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters ! 1 = original Zrnic et al. (Mansell et al. 2010) @@ -595,9 +635,12 @@ MODULE module_mp_nssl_2mom integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1) integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr + integer, private :: iqhacwshr = 1 ! turn on/off qhacw for T > 0 + integer, private :: iqhlacwshr = 1 ! turn on/off qhlacw for T > 0 real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow. + real, private :: alphasmlr0 = 14.0 ! shape parameter for drops formed from melting/shedding snow real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau) @@ -739,6 +782,7 @@ MODULE module_mp_nssl_2mom real da1 (lc:lqmx) ! collection coefficients from Seifert 2005 real bb (lc:lqmx) + ! put ipelec here for now.... integer :: ipelec = 0 integer :: isaund = 0 @@ -764,8 +808,8 @@ MODULE module_mp_nssl_2mom double precision, parameter :: dgam = 0.01, dgami = 100. double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) - integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15 - integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 + integer, parameter :: nqiacralpha = 300 !480 ! 240 ! 120 ! 15 + integer, parameter :: nqiacrratio = 400 ! 500 !50 ! 25 ! real, parameter :: maxratiolu = 25. real, parameter :: maxratiolu = 100. ! 25. real, parameter :: maxalphalu = 15. @@ -782,6 +826,10 @@ MODULE module_mp_nssl_2mom ! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) ! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) +! for 3-moment collection coefficients + real, save :: dab0lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real, save :: dab1lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + integer, parameter :: ngdnmm = 9 real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail @@ -860,7 +908,7 @@ MODULE module_mp_nssl_2mom ! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius - real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius + real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks max volume = 60 micron radius real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6 real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6 real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13 @@ -903,18 +951,20 @@ MODULE module_mp_nssl_2mom real, parameter :: cawbolton = 17.67 real, parameter :: tfrh = 233.15 +! -------------------------- + ! For CCPP, the following variables should be set by the host model, but initial values are set just in case real :: tfr = 273.15 - real :: cp = 1004.0, rd = 287.04 real :: rw = 461.5 ! gas const. for water vapor - REAL, PRIVATE :: cpl = 4190.0 - REAL, PRIVATE :: cpigb = 2106.0 - real :: cpi - real :: cap - real :: tfrcbw - real :: tfrcbi - real :: rovcp - + real :: cpl = 4190.0 + real :: cpigb = 2106.0 + real :: cpi = 1.0/1004.0 + real :: cap = 287.04/1004.0 + real :: tfrcbw = 273.15 - cbw + real :: tfrcbi = 273.15 - cbi + real :: rovcp = 287.04/1004.0 + real :: rdorv = 0.622 +! -------------------------- real, parameter :: poo = 1.0e+05 real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc @@ -922,8 +972,8 @@ MODULE module_mp_nssl_2mom ! GHB: Needed for eqtset=2 in cm1 ! REAL, PRIVATE :: cv = cp - rd - real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air - REAL, PRIVATE, parameter :: cvv = 1408.5 + real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air + REAL, PRIVATE, parameter :: cvv = 1408.5 ! GHB real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) @@ -952,10 +1002,12 @@ MODULE module_mp_nssl_2mom logical, parameter :: do_satadj_for_wrfchem = .true. + integer, parameter :: ac_opt = 0 ! option flag for alternate aerosol (for NUWRF only) + logical, private :: nuaccoinp = .false. ! Note to users: Many of these options are for development and not guaranteed to perform well. ! Some may not be functional depending on the version of the code. -! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions +! Some may be useful for ensemble physics diversity. Feel free to contact Ted Mansell if you have questions ! in that regard. NAMELIST /nssl_mp_params/ & ndebug, ncdebug,& @@ -965,7 +1017,7 @@ MODULE module_mp_nssl_2mom idbzci, & vtmaxsed, & itfall,iscfall, & - infall, & + infall,irfall,isfall, & rssflg, & sssflg, & hssflg, & @@ -976,13 +1028,15 @@ MODULE module_mp_nssl_2mom icnuclimit, & irenuc, & restoreccn, ccntimeconst, cck, & + decayufccn, ufccntimeconst, & switchccn, old_cccn, & ciintmx, & itype1, itype2, & - icenucopt, & + icenucopt, in_freeze_rain_first, & naer, & icfn, & ibfc, iacr, icracr, & + icracrthresh, & cwfrz2snowfrac, cwfrz2snowratio, & ibfr, & ibiggopt, & @@ -998,7 +1052,7 @@ MODULE module_mp_nssl_2mom eri_cimin, & eii0hl, eii1hl, & ehs0, ehs1, & - ess0, ess1, & + ess0, ess1, iessopt, & esstem1,esstem2, & ircnw, qminrncw,& ! single-moment only iglcnvi, & @@ -1024,6 +1078,7 @@ MODULE module_mp_nssl_2mom hailfallfac, & icefallopt, & icdx,icdxhl, & + axh,bxh,axf,bxf,axhl,bxhl, & cdhmin, cdhmax, & cdhdnmin, cdhdnmax, & cdhlmin, cdhlmax, & @@ -1058,7 +1113,7 @@ MODULE module_mp_nssl_2mom rescale_low_alphah, & rescale_low_alphahl, & rescale_high_alpha, & - ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, & icvhl2h, hldnmn,hdnmn, & hlcnhdia, hlcnhqmin, & isedonly, & @@ -1133,12 +1188,12 @@ SUBROUTINE nssl_2mom_init_const( & real, intent(in) :: con_g, con_rd, con_cp, con_rv, & con_t0c, con_cliq, con_csol, con_eps - cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv gr = con_g tfr = con_t0c cp = con_cp rd = con_rd rw = con_rv + rdorv = con_eps cpl = con_cliq ! 4190.0 cpigb = con_csol ! 2106.0 cpi = 1./cp @@ -1151,6 +1206,8 @@ SUBROUTINE nssl_2mom_init_const( & RETURN END SUBROUTINE nssl_2mom_init_const + + ! ##################################################################### ! ##################################################################### !>\ingroup mod_nsslmp @@ -1165,7 +1222,14 @@ SUBROUTINE nssl_2mom_init( & & nssl_icdxhl, & & nssl_icefallfac, & & nssl_snowfallfac, & + & nssl_cccn, & + & nssl_ufccn, & + & nssl_alphah, & + & nssl_alphahl, & + & nssl_alphar, & + & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, & & errmsg, errflg, & + & infileunit, & & myrank, mpiroot & ) @@ -1177,24 +1241,38 @@ SUBROUTINE nssl_2mom_init( & & nssl_ehw0, & & nssl_ehlw0, & & nssl_icefallfac, & - & nssl_snowfallfac + & nssl_snowfallfac, & + & nssl_cccn, & + & nssl_alphah, & + & nssl_alphahl, & + & nssl_alphar integer, intent(in), optional :: & & nssl_icdx, & - & nssl_icdxhl, myrank, mpiroot + & nssl_icdxhl, myrank, mpiroot, & + & nssl_ufccn + logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on + integer, intent(inout), optional :: ccn_is_ccna + + integer, intent(in),optional :: infileunit ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg - integer, intent(in) :: ims,ime, jms,jme, kms,kme - real, intent(in), dimension(20) :: nssl_params + integer, intent(in), optional :: ims,ime, jms,jme, kms,kme + + real, intent(in), dimension(20), optional :: nssl_params - integer, intent(in) :: ipctmp,mixphase,ihvol + integer, intent(in) :: ipctmp,mixphase + integer, optional, intent(in) :: ihvol logical, optional, intent(in) :: idoniconlytmp + integer :: igvol_local = 1 logical :: wrote_namelist = .false. logical :: wrf_dm_on_monitor + integer :: hail_on = -1, density_on = -1, icecrystals_on = 1 + integer :: ccn_on = -1 double precision :: arg real :: temq @@ -1202,22 +1280,59 @@ SUBROUTINE nssl_2mom_init( & integer :: i,il,j,l integer :: ltmp integer :: isub - real :: bxh,bxhl + real :: bxh1,bxhl1 real :: alp,ratio double precision :: x,y,y2,y7 logical :: turn_on_ccna, turn_on_cina + integer :: iufccn = 0 integer :: istat + + real :: alpjj, alpii, xnuii, xnujj + integer :: ii, jj errmsg = '' errflg = 0 turn_on_ccna = .false. turn_on_cina = .false. + +! IF ( present( igvol ) ) THEN +! igvol_local = igvol +! ENDIF + + IF ( present( nssl_hail_on ) ) THEN + IF ( nssl_hail_on ) THEN + hail_on = 1 + ELSE + hail_on = 0 + ENDIF + ENDIF + + IF ( present( nssl_density_on ) ) THEN + IF ( nssl_density_on ) THEN + density_on = 1 + ELSE + density_on = 0 + ENDIF + ENDIF + + IF ( present( nssl_icecrystals_on ) ) THEN + IF ( nssl_icecrystals_on ) THEN + icecrystals_on = 1 + ELSE + icecrystals_on = 0 + ! renucfrac = 1.0 ! why was this set to 1? + ffrzs = 1.0 + ENDIF + ENDIF + + ! ! set some global values from namelist input ! + IF ( present( nssl_params ) ) THEN ccn = Abs( nssl_params(1) ) alphah = nssl_params(2) alphahl = nssl_params(3) @@ -1228,26 +1343,60 @@ SUBROUTINE nssl_2mom_init( & rho_qh = nssl_params(8) rho_qhl = nssl_params(9) rho_qs = nssl_params(10) - alphar = nssl_params(15) - + IF ( Nint(nssl_params(13)) == 1 ) THEN + ! hack to switch CCN field to CCNA (activated ccn) +! invertccn = .true. + turn_on_ccna = .true. + irenuc = 7 + ENDIF + ccnuf = Abs( nssl_params(14) ) + IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn + + ENDIF + alphar = nssl_params(15) ! ipelec = Nint(nssl_params(11)) ! isaund = Nint(nssl_params(12)) + + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac - IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0 - IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0 + IF ( present(nssl_ehw0) ) THEN + IF ( nssl_ehw0 > 0.0 ) ehw0 = nssl_ehw0 + ENDIF + IF ( present(nssl_ehlw0) ) THEN + IF ( nssl_ehlw0 > 0.0 ) ehlw0 = nssl_ehlw0 + ENDIF IF ( present(nssl_icdx) ) icdx = nssl_icdx IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac + IF ( present(nssl_cccn) ) THEN + IF (nssl_cccn > 1 ) ccn = nssl_cccn + ENDIF + IF ( present(nssl_alphah) ) THEN + IF ( nssl_alphah > -1. ) alphah = nssl_alphah + ENDIF + IF ( present(nssl_alphahl) ) THEN + IF ( nssl_alphahl > -1. ) alphahl = nssl_alphahl + ENDIF + IF ( present(nssl_alphar) ) THEN + IF ( nssl_alphar > -1.0 ) alphar = nssl_alphar + ENDIF - IF ( Nint(nssl_params(13)) == 1 ) THEN - ! hack to switch CCN field to CCNA (activated ccn) -! invertccn = .true. - turn_on_ccna = .true. - irenuc = 7 + ipconc = ipctmp + + IF ( ipconc < 5 ) THEN + ihlcnh = 0 + ENDIF + + IF ( ihlcnh <= 0 ) THEN + IF ( ipconc == 5 ) THEN + ihlcnh = 3 + ELSEIF ( ipconc >= 6 ) THEN + ihlcnh = 3 ENDIF + ENDIF @@ -1275,8 +1424,43 @@ SUBROUTINE nssl_2mom_init( & + IF ( iufccn > 0 ) THEN ! make sure to use option that uses UF ccn + irenuc = 7 + IF ( ccnuf <= 0.0 ) decayufccn = .true. ! assume surface emission and need decay + IF ( i_uf_or_ccn > 0 ) THEN + ufbackground = 0.0 + ccntimeconst = ufccntimeconst + ENDIF + ENDIF + + IF ( present( nssl_ccn_on ) ) THEN + IF ( nssl_ccn_on ) THEN + ccn_on = 1 + ELSE + ccn_on = 0 + irenuc = 2 + ENDIF + ENDIF + IF ( irenuc >= 5 ) THEN turn_on_ccna = .true. + IF ( present( nssl_ccn_on ) ) THEN + IF ( .not. nssl_ccn_on ) THEN + errmsg = 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!' + errflg = 1 + return + ENDIF + ENDIF + ENDIF + + IF ( present( ccn_is_ccna ) .and. ccn_on == 1 ) THEN + IF ( ccn_is_ccna > 0 ) THEN + turn_on_ccna = .true. + ELSE + IF ( irenuc >= 5 ) THEN + ccn_is_ccna = 1 + ENDIF + ENDIF ENDIF cwccn = ccn @@ -1290,25 +1474,42 @@ SUBROUTINE nssl_2mom_init( & lh = lh + 1 lhl = lhl + 1 ENDIF - IF ( ihvol <= -1 .or. ihvol == 2 ) THEN - IF ( ihvol == -1 .or. ihvol == -2 ) THEN - lhab = lhab - 1 ! turns off hail - lhl = 0 - ! past me thought it would be a good idea to change graupel factors when hail is off.... - ! ehw0 = 0.75 - ! iehw = 2 - ! dfrz = Max( dfrz, 0.5e-3 ) - ENDIF - IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off - ! a value of -3 means to turn off ice crystals but turn on hail - renucfrac = 1.0 - ffrzs = 1.0 - ! idoci = 0 ! try this later + IF ( hail_on == -1 ) THEN ! hail_on is not set + hail_on = 1 + IF ( ihvol <= -1 .or. ihvol == 2 ) THEN + IF ( ihvol == -1 .or. ihvol == -2 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + hail_on = 0 + ! past me thought it would be a good idea to change graupel factors when hail is off.... + ! ehw0 = 0.75 + ! iehw = 2 + ! dfrz = Max( dfrz, 0.5e-3 ) + ENDIF + IF ( ihvol == -2 .or. ihvol == 2 .or. icecrystals_on == 0 ) THEN ! ice crystals are turned off + ! a value of 2? means to turn off ice crystals but turn on hail + ! renucfrac = 1.0 ! why? + ffrzs = 1.0 + ! idoci = 0 ! try this later + ENDIF + ENDIF + + ELSE ! hail_on is set + IF ( hail_on == 0 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + ELSE + ! assume default that hail is on ENDIF ENDIF + + IF ( density_on == -1 ) THEN ! density flag not set, so default is to predict it + density_on = 1 + ENDIF + IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl -! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl +! write(0,*) 'wrf_init: lhab,lhl,hail_on,density_on = ',lhab,lhl,hail_on,density_on ! IF ( ipelec > 0 ) idonic = .true. @@ -1335,29 +1536,42 @@ SUBROUTINE nssl_2mom_init( & bx(lr) = 0.85 ax(lr) = 1647.81 fx(lr) = 135.477 + IF ( icdx == 6 ) THEN bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. ax(lh) = 157.71 - ELSEIF ( icdx > 0 ) THEN +! ELSEIF ( icdx == 1 ) THEN +! bx(lh) = bxh +! ax(lh) = axh + ELSEIF ( icdx > 1 ) THEN bx(lh) = 0.5 ax(lh) = 75.7149 - ELSE - bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 + ELSEIF ( icdx == 0 ) THEN + bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 graupel ax(lh) = 19.3 + ELSE ! icdx < 0 +! ax(lh) = 206.984 ! Ferrier 1994 hail/frozen drops +! bx(lh) = 0.6384 + bx(lh) = bxh + ax(lh) = axh ENDIF + ! bx(lh) = 0.6 IF ( lhl .gt. 1 ) THEN IF ( icdxhl == 6 ) THEN bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750. ax(lhl) = 179.36 + ELSEIF (icdxhl == 0 ) THEN + ax(lhl) = 206.984 ! Ferrier 1994 + bx(lhl) = 0.6384 ELSEIF (icdxhl > 0 ) THEN - bx(lhl) = 0.5 - ax(lhl) = 75.7149 + bx(lhl) = 0.5 + ax(lhl) = 75.7149 ELSE - ax(lhl) = 206.984 ! Ferrier 1994 - bx(lhl) = 0.6384 + bx(lhl) = bxhl + ax(lhl) = axhl ENDIF ENDIF @@ -1373,8 +1587,8 @@ SUBROUTINE nssl_2mom_init( & ! Uses incomplete gamma functions ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) - bxh = bx(lh) - bxhl = bx(Max(lh,lhl)) + bxh1 = bx(lh) + bxhl1 = bx(Max(lh,lhl)) ! DO j = 0,nqiacralpha DO j = ialpstart,nqiacralpha @@ -1390,9 +1604,9 @@ SUBROUTINE nssl_2mom_init( & ! graupel (.,.,.,1) gamxinflu(i,j,1,1) = x/y gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y - gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y + gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh1, ratio )/y gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y - gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y + gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh1) - gamxinfdp( 5.5+alp+0.5*bxh1, ratio ))/y gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y @@ -1401,9 +1615,9 @@ SUBROUTINE nssl_2mom_init( & ! hail (.,.,.,2) gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) - gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl1, ratio )/y gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) - gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y + gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl1) - gamxinfdp( 5.5+alp+0.5*bxhl1, ratio ))/y gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) @@ -1411,16 +1625,16 @@ SUBROUTINE nssl_2mom_init( & ! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y ! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y - gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y -! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y - gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y + gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh1) - gamxinfdp( alp - 0.5 + 0.5*bxh1, ratio ))/y +! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio )/y + gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl1) - gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio ))/y ELSE ! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y -! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y -! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y - gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y - gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y +! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio )/y +! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio ) )/y + gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio ) )/y ENDIF gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) @@ -1454,9 +1668,8 @@ SUBROUTINE nssl_2mom_init( & qiacrratio(0,:) = 1.0 - isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0 - lccn = 0 + lccnuf = 0 lccna = 0 lnc = 0 lnr = 0 @@ -1478,34 +1691,41 @@ SUBROUTINE nssl_2mom_init( & ! lccn = 9 - ipconc = ipctmp IF ( ipconc == 0 ) THEN - IF ( ihvol >= 0 ) THEN + IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme lvh = 9 ltmp = 9 denscale(lvh) = 1 - ELSE ! no hail + ELSE ! no hail, 'LFO' scheme ltmp = lhab lhl = 0 ENDIF ELSEIF ( ipconc == 5 ) THEN - lccn = lhab+1 ! 9 - lnc = lhab+2 ! 10 - lnr = lhab+3 ! 11 - lni = lhab+4 !12 - lns = lhab+5 !13 - lnh = lhab+6 !14 + ltmp = lhab + IF ( iufccn > 0 ) THEN + ltmp = ltmp+1 + lccnuf = ltmp + denscale(lccnuf) = 1 + ENDIF + lccn= ltmp+1 ! 9 + lnc = ltmp+2 ! 10 + lnr = ltmp+3 ! 11 + lni = ltmp+4 !12 + lns = ltmp+5 !13 + lnh = ltmp+6 !14 ltmp = lnh - IF ( ihvol >= 0 ) THEN + IF ( hail_on == 1 ) THEN ltmp = ltmp + 1 lnhl = ltmp ! lhab+7 ! 15 ENDIF + IF ( density_on >= 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off ! ltmp = lvh - denscale(lccn:lvh) = 1 - IF ( ihvol >= 1 ) THEN + ENDIF + denscale(lccn:ltmp) = 1 + IF ( density_on == 1 .and. hail_on == 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp ! ltmp = lvhl @@ -1523,25 +1743,31 @@ SUBROUTINE nssl_2mom_init( & ! ltmp = lhlw ENDIF ELSEIF ( ipconc >= 6 ) THEN - errmsg = 'NSSL microphysics has not been compiled for 3-moment. Sorry.' - errflg = 1 - return - lccn = lhab+1 ! 9 - lnc = lhab+2 ! 10 - lnr = lhab+3 ! 11 - lni = lhab+4 !12 - lns = lhab+5 !13 - lnh = lhab+6 !14 + ltmp = lhab + IF ( iufccn > 0 ) THEN + ltmp = ltmp+1 + lccnuf = ltmp + denscale(lccnuf) = 1 + ENDIF + + lccn= ltmp+1 ! 9 + lnc = ltmp+2 ! 10 + lnr = ltmp+3 ! 11 + lni = ltmp+4 !12 + lns = ltmp+5 !13 + lnh = ltmp+6 !14 ltmp = lnh IF ( lhl > 0 ) THEN ltmp = ltmp + 1 lnhl = ltmp ! lhab+7 ! 15 ENDIF + IF ( density_on == 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off + ENDIF ! ltmp = lvh - denscale(lccn:lvh) = 1 - IF ( ihvol >= 1 ) THEN + denscale(lccn:ltmp) = 1 + IF ( density_on == 1 .and. hail_on == 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp ! ltmp = lvhl @@ -1561,19 +1787,14 @@ SUBROUTINE nssl_2mom_init( & lzh = ltmp ltmp = ltmp + 1 lzr = ltmp - ltmp = ltmp + 1 IF ( lhl > 1 ) THEN ltmp = ltmp + 1 lzhl = ltmp ENDIF + ! write(0,*) 'ipcon,lzr = ',ipconc,lzr,lzh,lzhl ENDIF ! ltmp = lvh ! denscale(lccn:lvh) = 1 - IF ( ihvol >= 1 ) THEN - lvhl = ltmp+1 - ltmp = lvhl - denscale(lvhl) = 1 - ENDIF IF ( mixedphase ) THEN ltmp = ltmp + 1 lsw = ltmp @@ -1593,7 +1814,8 @@ SUBROUTINE nssl_2mom_init( & - + ! write(0,*) 'wrf_init: lh,lhl,lzh,lzhl = ',lh,lhl,lzh,lzhl + ! write(0,*) 'wrf_init: ipconc = ',ipconc ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna IF ( turn_on_ccna ) THEN ltmp = ltmp + 1 @@ -1825,9 +2047,11 @@ SUBROUTINE nssl_2mom_init( & IF ( lhl .gt. 1 ) ido(lhl) = idohl IF ( irfall .lt. 0 ) irfall = infall + IF ( isfall .lt. 0 ) isfall = infall IF ( lzr > 0 ) irfall = 0 qccn = ccn/rho00 + qccnuf = ccnuf/rho00 IF ( old_cccn > 0.0 ) THEN old_qccn = old_cccn/rho00 ELSE @@ -1981,6 +2205,33 @@ SUBROUTINE nssl_2mom_init( & ENDDO ENDDO + dab0lu(:,:,:,:) = 0.0 + dab1lu(:,:,:,:) = 0.0 + + IF ( ipconc >= 6 ) THEN + DO il = lc,lhab ! collector + DO j = lc,lhab ! collected + IF ( il .ne. j ) THEN + + DO jj = ialpstart,nqiacralpha + alpjj = float(jj)*dqiacralpha + xnujj = (alpjj - 2.)/3. + DO ii = ialpstart,nqiacralpha + alpii = float(ii)*dqiacralpha + xnuii = (alpii - 2.)/3. + + dab0lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 0) + dab1lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 1) + + ENDDO + ENDDO +! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j) + ENDIF + ENDDO + ENDDO + + ENDIF + gf4br = gamma_sp(4.0+br) gf4ds = gamma_sp(4.0+ds) gf4p5 = gamma_sp(4.0+0.5) @@ -2029,18 +2280,25 @@ END SUBROUTINE nssl_2mom_init !>\ingroup mod_nsslmp !! Driver subroutine that copies state data to local 2D arrays for microphysics calls SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & - cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & - zrw, zhw, zhl, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, & + cnuf, f_cnuf, & + zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, & qsw, qhw, qhlw, & tt, th, pii, p, w, dn, dz, dtp, itimestep, & + is_theta_or_temp, & + ntmul, ntcnt, lastloop, & RAINNC,RAINNCV, & dx, dy, & axtra, & SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & SR,HAILNC, HAILNCV, & + hail_maxk1, hail_max2d, nwp_diagnostics, & tkediss, & re_cloud, re_ice, re_snow, re_rain, & + re_graup, re_hail, & has_reqc, has_reqi, has_reqs, has_reqr, & + has_reqg, has_reqh, & rainncw2, rainnci2, & dbz, vzf,compdbz, & rscghis_2d,rscghis_2dp,rscghis_2dn, & @@ -2074,6 +2332,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + + implicit none @@ -2091,7 +2351,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw zrw, zhw, zhl, & qsw, qhw, qhlw, & qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni + integer, optional, intent(in) :: is_theta_or_temp + logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) @@ -2102,8 +2364,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez - real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez + real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii @@ -2124,22 +2386,30 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra ! WRF variables - real, dimension(ims:ime, jms:jme), intent(inout):: & + real, dimension(ims:ime, jms:jme) :: & RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout) :: hail_maxk1, hail_max2d + integer, optional, intent(in) :: nwp_diagnostics +! for cm1, set nproctot=44 (or as needed) to get domain total rates integer, parameter :: nproc = 1 - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, re_rain + double precision :: proctot(nproc),proctotmpi(nproc) + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, & + re_rain, re_graup, re_hail REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss - INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr, has_reqg, has_reqh real, dimension(ims:ime, jms:jme), intent(out), optional :: & rainncw2, rainnci2 ! liquid rain, ice, accumulation rates real, optional, intent(in) :: dx,dy real, intent(in):: dtp integer, intent(in):: itimestep !, ccntype - logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina + integer, intent(in), optional :: ntmul, ntcnt + logical, optional, intent(in) :: lastloop + logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf + logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl integer, optional, intent(in) :: ipelectmp, ke_diag ! CCPP error handling @@ -2151,7 +2421,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop LOGICAL :: flag_qndrop ! wrf-chem LOGICAL :: flag_qnifa , flag_qnwfa + logical :: flag_cnuf = .false. + logical :: flag_ccn = .false. + logical :: flag_qi = .true. + logical :: has_reqg_local = .false., has_reqh_local = .false. logical :: flag + logical :: nwp_diagflag = .false. real :: cinchange, t7max,testmax,wmax ! 20130903 acd_ck_washout start @@ -2176,12 +2451,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d + real, dimension(its:ite, 1, kts:kte, 3) :: alpha2d real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d real, dimension(its:ite, 1, na) :: xfall + real, dimension(its:ite, 1) :: hailmax1d,hailmaxk1 real, dimension(kts:kte, nproc) :: thproclocal integer, parameter :: nor = 0, ng = 0 - integer :: nx,ny,nz + integer :: nx,ny,nz,ngs integer ix,jy,kz,i,j,k,il,n integer :: infdo real :: ssival, ssifac, t8s, t9s, qvapor @@ -2223,15 +2500,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real :: fach(kts:kte) logical, parameter :: debugdriver = .false. - -#ifdef MPI - -#if defined(MPI) - integer, parameter :: ntot = 50 - double precision mpitotindp(ntot), mpitotoutdp(ntot) - INTEGER :: mpi_error_code = 1 -#endif -#endif + + integer :: loopcnt, loopmax, outerloopcnt + logical :: lastlooptmp ! ------------------------------------------------------------------- @@ -2246,13 +2517,52 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw flag_qndrop = .false. flag_qnifa = .false. flag_qnwfa = .false. + flag_cnuf = .false. + flag_ccn = .false. + nwp_diagflag = .false. IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn + IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf + IF ( present ( nwp_diagnostics ) ) nwp_diagflag = ( nwp_diagnostics > 0 ) + IF ( present ( f_cn ) .and. present( cn ) ) THEN + flag_ccn = f_cn + ELSEIF ( present( cn ) ) THEN + flag_ccn = .true. + ENDIF + + IF ( present( f_qi ) ) THEN + flag_qi = f_qi + ELSE + IF ( ffrzs < 1.0 ) THEN + flag_qi = .true. + ELSE + flag_qi = .false. + ENDIF + ENDIF + IF ( .not. flag_qi .and. ffrzs < 1.0 ) ffrzs = 1.0 + + IF ( PRESENT ( has_reqg ) ) has_reqg_local = has_reqg > 0 + IF ( PRESENT ( has_reqh ) ) has_reqh_local = has_reqh > 0 - ! --- + loopmax = 1 + outerloopcnt = 1 + lastlooptmp = .true. + IF ( present( ntmul ) .and. present( ntcnt ) .and. present( lastloop ) ) THEN + loopmax = ntmul + outerloopcnt = ntcnt + lastlooptmp = lastloop + ENDIF + + + has_wetscav = .false. + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( wetscav_on ) ) THEN + has_wetscav = wetscav_on + ENDIF + ENDIF IF ( present( f_cna ) ) THEN f_cnatmp = f_cna @@ -2303,8 +2613,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw nx = ite-its+1 ny = 1 ! set up as 2D slabs nz = kte-kts+1 + ngs = 64 - IF ( .not. present( cn ) ) THEN + IF ( .not. flag_ccn ) THEN renucfrac = 1.0 ENDIF @@ -2365,32 +2676,35 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ancuten(its:ite,1,kts:kte,:) = 0.0 thproclocal(:,:) = 0.0 + DO jy = jts,jye - xfall(:,:,:) = 0.0 - ! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn IF ( present( pcc2 ) .and. makediag ) THEN axtra2d(its:ite,1,kts:kte,:) = 0.0 ENDIF + IF ( nwp_diagflag ) THEN + alpha2d(its:ite,1,kts:kte,1) = alphar + alpha2d(its:ite,1,kts:kte,2) = alphah + alpha2d(its:ite,1,kts:kte,3) = alphahl + ENDIF + + ! copy from 3D array to 2D slab DO kz = kts,kte DO ix = its,ite - IF ( present( tt ) ) THEN an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy) ELSE an(ix,1,kz,lt) = th(ix,kz,jy) ENDIF - - an(ix,1,kz,lv) = qv(ix,kz,jy) an(ix,1,kz,lc) = qc(ix,kz,jy) an(ix,1,kz,lr) = qr(ix,kz,jy) - IF ( present( qi ) ) THEN + IF ( flag_qi ) THEN an(ix,1,kz,li) = qi(ix,kz,jy) ELSE an(ix,1,kz,li) = 0.0 @@ -2401,13 +2715,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lccn > 1 ) THEN IF ( is_aerosol_aware .and. flag_qnwfa ) THEN ! - ELSEIF ( present( cn ) ) THEN + ELSEIF ( flag_ccn ) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN an(ix,1,kz,lccna) = cn(ix,kz,jy) an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy) ELSE an(ix,1,kz,lccn) = cn(ix,kz,jy) ENDIF + IF ( i_uf_or_ccn > 0 .and. lccnuf > 1 ) THEN ! UF ccn are extra regular ccn + an(ix,1,kz,lccn) = an(ix,1,kz,lccn) + cnuf(ix,kz,jy) + ENDIF ELSE IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) @@ -2418,6 +2735,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + IF ( lccnuf > 0 .and. flag_cnuf ) THEN + IF ( i_uf_or_ccn == 0 ) THEN ! UF are UF + an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) ) + ELSE ! UF were added to lccn + an(ix,1,kz,lccnuf) = 0.0 + ENDIF + ENDIF + IF ( lccna > 1 ) THEN IF ( present( cna ) .and. f_cnatmp ) THEN an(ix,1,kz,lccna) = cna(ix,kz,jy) @@ -2448,9 +2773,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy) + IF ( ipconc >= 6 ) THEN + IF ( lzr > 0 ) an(ix,1,kz,lzr) = zrw(ix,kz,jy)*zscale + IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,kz,jy)*zscale + IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,kz,jy)*zscale + ENDIF + ENDDO + ENDDO + + DO kz = kts,kte + DO ix = its,ite IF ( present( tt ) ) THEN @@ -2458,6 +2793,26 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSE t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin) ENDIF + t00(ix,1,kz) = 380.0/p(ix,kz,jy) + t77(ix,1,kz) = pii(ix,kz,jy) + dbz2d(ix,1,kz) = 0.0 + vzf2d(ix,1,kz) = 0.0 + ENDDO + ENDDO + + DO ix = its,ite + RAINNCV(ix,jy) = 0.0 + IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = 0.0 + IF ( present( HAILNCV ) ) HAILNCV(ix,jy) = 0.0 + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = 0.0 + ENDDO + + DO loopcnt = 1,loopmax + + DO kz = kts,kte + DO ix = its,ite + + t1(ix,1,kz) = 0.0 t2(ix,1,kz) = 0.0 t3(ix,1,kz) = 0.0 @@ -2467,14 +2822,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw t7(ix,1,kz) = 0.0 t8(ix,1,kz) = 0.0 t9(ix,1,kz) = 0.0 - t00(ix,1,kz) = 380.0/p(ix,kz,jy) - t77(ix,1,kz) = pii(ix,kz,jy) - dbz2d(ix,1,kz) = 0.0 - vzf2d(ix,1,kz) = 0.0 - dn1(ix,1,kz) = dn(ix,kz,jy) pn(ix,1,kz) = p(ix,kz,jy) wn(ix,1,kz) = w(ix,kz,jy) +! calculate dn1 in case we are substepping: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps)) + dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv)) ! wmax = Max(wmax,wn(ix,1,kz)) dz2d(ix,1,kz) = dz(ix,kz,jy) dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) @@ -2492,6 +2844,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + if ( ssival .gt. 1.0 ) then ! IF ( icenucopt == 1 ) THEN @@ -2544,19 +2897,20 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 - IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN ! ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d) ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 ! naer needs units of cm**-3, so mult by 1.e-6 - ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) - dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) - t7(ix,jy,kz) = Min(dp1, 1.0d30) + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*cin*dn(ix,1,kz))**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) + tmp = 1.e-6*naer + dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * tmp**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) + t7(ix,1,kz) = Min(dp1, 1.0d30) ELSE - t7(ix,jy,kz) = 0.0 + ! t7(ix,1,kz) = 0.0 ENDIF ENDIF ! icenucopt @@ -2569,39 +2923,39 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! ix ENDDO ! kz - has_wetscav = .false. - IF ( wrfchem_flag > 0 ) THEN - IF ( PRESENT( wetscav_on ) ) THEN - has_wetscav = wetscav_on - IF ( has_wetscav ) THEN - IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 - IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 - ENDIF - ENDIF - ENDIF + IF ( wrfchem_flag > 0 ) THEN + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + ENDIF ! transform from number mixing ratios to number conc. + IF ( loopcnt == 1 ) THEN DO il = lnb,na IF ( denscale(il) == 1 ) THEN DO kz = kts,kte DO ix = its,ite - an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy) + an(ix,1,kz,il) = an(ix,1,kz,il)*dn1(ix,1,kz) ! dn(ix,kz,jy) ENDDO ENDDO ENDIF ENDDO ! il + ENDIF + ! sedimentation xfall(:,:,:) = 0.0 - IF ( .true. ) THEN + +! IF ( .true. ) THEN ! #ifndef CM1 ! for real cases when hydrometeor mixing ratios have been initialized without concentrations - IF ( itimestep == 1 .and. ipconc > 0 ) THEN + IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) ENDIF ! IF ( itimestep == 3 .and. ipconc > 0 ) THEN @@ -2611,9 +2965,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present(cu_used) .and. & ( present( qrcuten ) .or. present( qscuten ) .or. & - present( qicuten ) .or. present( qccuten ) ) ) THEN + present( qicuten ) .or. present( qccuten ) ) ) THEN !{ - IF ( cu_used == 1 ) THEN + IF ( cu_used == 1 ) THEN !{ DO kz = kts,kte DO ix = its,ite @@ -2627,10 +2981,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) + DO kz = kts,kte + DO ix = its,ite + + + IF ( ipconc >= 6 ) THEN +! IF ( lzr > 0 ) an(ix,1,kz,lzr) = an(ix,1,kz,lzr) + ancuten(ix,1,kz,lzr) + ENDIF + + ENDDO + ENDDO - ENDIF + ENDIF !} - ENDIF + ENDIF !} + + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & @@ -2644,10 +3010,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO ix = its,ite IF ( lhl > 1 ) THEN - RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + RAINNCV(ix,jy) = RAINNCV(ix,jy) + & + dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) ELSE - RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + RAINNCV(ix,jy) = RAINNCV(ix,jy) + & + dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF IF ( present ( rainncw2 ) ) THEN ! rain only @@ -2662,17 +3030,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF ENDIF - IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = SNOWNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) IF ( present( GRPLNCV ) ) THEN IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel - GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) ELSE - GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) ENDIF ENDIF - RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) + IF ( loopcnt == loopmax ) RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) - IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + IF ( present (SNOWNC) .and. present (SNOWNCV) .and. loopcnt == loopmax ) THEN + SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + ENDIF IF ( lhl > 1 ) THEN !#ifdef CM1 ! IF ( .true. ) THEN @@ -2680,13 +3050,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( HAILNC ) ) THEN !#endif HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) - HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) + IF ( loopcnt == loopmax ) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) ! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel ! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) ENDIF ENDIF - IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) - IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN + IF ( present( GRPLNCV ) .and. loopcnt == loopmax ) THEN + GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + ENDIF + IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) .and. loopcnt == loopmax ) THEN IF ( present( HAILNC ) ) THEN SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) ELSE @@ -2695,7 +3067,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDDO - ENDIF ! .false. +! ENDIF ! .false. IF ( isedonly /= 1 ) THEN ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics @@ -2717,15 +3089,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,dbz2d,tke2d, & - & thproclocal,nproc,dx1,dy1, & + & thproclocal,nproc,dx1,dy1,ngs, & & timevtcalc,axtra2d, makediag & - & ,has_wetscav, rainprod2d, evapprod2d & + & ,has_wetscav, rainprod2d, evapprod2d, alpha2d & & ,errmsg,errflg & & ,elec2,its,ids,ide,jds,jde & & ) +! recalculate dn1 after temperature changes: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps)) + DO kz = kts,kte + DO ix = its,ite + dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv)) + ENDDO + ENDDO + ENDIF ! isedonly /= 1 @@ -2737,29 +3116,38 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,dz2d & & ,t0,t9 & & ,an,dn1,t77 & - & ,pn,wn & + & ,pn,wn & + & ,ngs & & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) +! recalculate dn1 after temperature changes + DO kz = kts,kte + DO ix = its,ite + dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv)) + ENDDO + ENDDO + ENDIF + + ENDDO ! loopcnt=1,loopmax IF ( present( pcc2 ) .and. makediag ) THEN DO kz = kts,kte DO ix = its,ite ! example of using the 'axtra2d' array to get rates out of the microphysics routine for output. ! Search for 'axtra' to find example code below ! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1) - ENDDO ENDDO ENDIF ! compute diagnostic S-band reflectivity if needed - IF ( present( dbz ) .and. makediag ) THEN + IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN ! calc dbz IF ( .true. ) THEN @@ -2797,7 +3185,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & - present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN + present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) .and. & + lastlooptmp) THEN IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN DO kz = kts,kte DO ix = its,ite @@ -2815,16 +3204,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw call calc_eff_radius & & (nx,ny,nz,na,jy & & ,nor,nor & - & ,t1=t1,t2=t2,t3=t3,t4=t4 & + & ,t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,f_t5=has_reqg_local, f_t6=has_reqh_local & & ,an=an,dn=dn1 ) DO kz = kts,kte DO ix = its,ite re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6)) - re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6)) + re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6)) re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) - IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 200.E-6)) + IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) ENDDO ENDDO @@ -2837,19 +3226,53 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDIF ENDIF + + IF ( present(has_reqg) .and. present( re_graup ) ) THEN + IF ( has_reqg /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_graup(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 10.E-3)) + ENDDO + ENDDO + ENDIF + ENDIF + + IF ( present(has_reqh) .and. present( re_hail ) ) THEN + IF ( has_reqh /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_hail(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 40.E-3)) + ENDDO + ENDDO + ENDIF + ENDIF ENDIF ENDIF + IF ( present( hail_maxk1 ) .and. present( hail_max2d ) .and. nwp_diagflag ) THEN + DO ix = its,ite + hailmax1d(ix,1) = hail_max2d(ix,jy) + hailmaxk1(ix,1) = hail_maxk1(ix,jy) + ENDDO + + call hailmaxd(dtp,nx,ny,nz,an,na,nor,nor,alpha2d,dn1, & + hailmax1d,hailmaxk1,1 ) + DO ix = its,ite + hail_max2d(ix,jy) = hailmax1d(ix,1) + hail_maxk1(ix,jy) = hailmaxk1(ix,1) + ENDDO +! ENDIF + ENDIF ! transform concentrations back to mixing ratios DO il = lnb,na IF ( denscale(il) == 1 ) THEN DO kz = kts,kte DO ix = its,ite - an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy) + an(ix,1,kz,il) = an(ix,1,kz,il)/dn1(ix,1,kz) ! dn(ix,kz,jy) ENDDO ENDDO ENDIF @@ -2870,14 +3293,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw qv(ix,kz,jy) = an(ix,1,kz,lv) qc(ix,kz,jy) = an(ix,1,kz,lc) qr(ix,kz,jy) = an(ix,1,kz,lr) - IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li) + IF ( flag_qi ) qi(ix,kz,jy) = an(ix,1,kz,li) qs(ix,kz,jy) = an(ix,1,kz,ls) qh(ix,kz,jy) = an(ix,1,kz,lh) IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN ! not used here - ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN + ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) ELSE @@ -2896,6 +3319,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + IF ( lccnuf > 0 .and. flag_cnuf ) THEN + IF ( i_uf_or_ccn > 0 ) THEN ! UF are ccn and lccnuf is zero, so put cnuf into lccnuf to do decay + an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) ) + ENDIF + IF ( decayufccn ) THEN + IF ( an(ix,1,kz,lccnuf) > ufbackground ) THEN + an(ix,1,kz,lccnuf) = an(ix,1,kz,lccnuf) - (an(ix,1,kz,lccnuf) - & + ufbackground)*(1.0 - exp(-dtp/ufccntimeconst)) + ENDIF + ENDIF + cnuf(ix,kz,jy) = an(ix,1,kz,lccnuf) + ENDIF + + + IF ( ipconc >= 5 ) THEN ccw(ix,kz,jy) = an(ix,1,kz,lnc) @@ -2906,6 +3344,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl) ENDIF + IF ( ipconc >= 6 ) THEN + IF ( lzr > 0 ) zrw(ix,kz,jy) = an(ix,1,kz,lzr) *zscaleinv + IF ( lzh > 0 ) zhw(ix,kz,jy) = an(ix,1,kz,lzh) *zscaleinv + IF ( lzhl > 0 ) zhl(ix,kz,jy) = an(ix,1,kz,lzhl)*zscaleinv + ENDIF @@ -2914,6 +3357,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw #if ( WRF_CHEM == 1 ) IF ( has_wetscav ) THEN + IF ( loopmax > 1 ) THEN + ! wrferror not supported + ENDIF IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) ENDIF @@ -2921,8 +3367,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO - + + ENDDO ! jy + + @@ -3217,7 +3666,7 @@ END FUNCTION GAML02 ! ********************************************************** !>\ingroup mod_nsslmp !! Function calculates fraction of drops larger than 300 microns ( imurain == 3 ) - real FUNCTION GAML02d300(x) + real FUNCTION GAML02d300(x) implicit none integer ig, i, ii, n, np real x @@ -3558,11 +4007,245 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) RETURN END Function delabk - + + +! ####################################################################### +! HAILMAXD - calculated maximum expected hail size +! ####################################################################### !>\ingroup mod_nsslmp -!! Sedimentation driver subroutine. Calls fallout column by column - subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & +!! Hail max size subroutine. + subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & + & hailmax1d,hailmaxk1,jslab ) +! +! Calculate maximum hail size from the tail of of the distribution. The value +! of thresh_conc sets the minimum concentration in the integral over (Dmax, Inf). +! This uses the lookup tables for incomplete gamma functions and simply search for +! the expected value (and linearly interpolate) on D. +! +! Written by ERM 7/2023 +! +! +! + implicit none + + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density +! integer :: its,ite ! x-range to calculate + + integer ng1 + parameter(ng1 = 1) + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + +! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) + real dtp + real alpha2d(-nor+1:nx+nor,1,-norz+1:nz+norz,3) ! array for PSD shape parameters + real :: hailmax1d(nx,ny),hailmaxk1(nx,ny) + integer infdo + integer jslab ! which line of xfall to use + + integer ix,jy,kz,ndfall,n,k,il,in + double precision :: tmp, ratio, del, g1palp + real, parameter :: dz = 200. + + real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + + real :: rhovtzx(nz,nx) + + real :: alp, diam, diam1, hwdn + +! real, parameter :: cmin = 0.001 ! threshold number per m^3 for maximum diamter (threshold from diag_nwp) + DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.0005d0 ! number conc. of graupel/hail per cubic meter + real :: cwchtmp,cwchltmp, maxdia + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + integer :: plo, phi + integer :: ialp, i, j + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + + IF ( lh > 1 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + ENDIF + IF ( lhl > 1 ) THEN + cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) + ENDIF + + + kzb = 1 + kze = nz + + ixb = 1 ! aliased its + ixe = nx ! aliased ite + + + jy = jslab + jgs = jy + + +! hailmax1d(:,jy) = 0.0 +! hailmaxk1(:,jy) = 0.0 + + if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' + + +! first graupel, even if hail is also predicted, since graupel can sometime be large on its own + IF ( lh > 1 .and. lnh > 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + IF ( an(ix,jy,kz,lh) .gt. qxmin(lh) .and. an(ix,jy,kz,lnh) .gt. thresh_conc ) THEN + IF ( lvh .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = rho_qh + ENDIF + + tmp = 1. + alpha2d(ix,1,kz,2) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh)) + diam = (6.0*tmp/pi)**(1./3.) + IF ( lzh > 1 ) THEN ! 3moment + cwchtmp = ((3. + alpha2d(ix,1,kz,2))*(2. + alpha2d(ix,1,kz,2))*(1.0 + alpha2d(ix,1,kz,2)))**(-1./3.) + ENDIF + diam1 = diam*cwchtmp ! characteristic diameter, i.e., 1/lambda + ! want cxd1 = thresh_conc + ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + ! cxd1 = cx(mgs,lh)*(tmp)/g1palp + ! tmp = thresh_conc*g1palp/cx + ! + tmp = thresh_conc*g1palp/an(ix,jy,kz,lnh) + alp = alpha2d(ix,1,kz,2) + ! gamxinflu(i,j,luindex,ilh) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + ratio = 0.0 + maxdia = 0.0 + ! eventually could replace with bisection search, but final value of i is usually small + ! compared to nqiacrratio + DO i = 0,nqiacrratio-1 + IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN + ! interpolate here for FWIW + ratio = i*dqiacrratio + del = tmp - gamxinflu(i,j,1,1) + ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio + exit + ENDIF + ENDDO + + IF ( ratio > 0.0 ) THEN + maxdia = ratio*diam1 ! units of m + ENDIF + + IF ( kz == kzb ) THEN + hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) ) +! IF ( maxdia > 0.1 ) THEN +! IF ( an(ix,jy,kz,lh) > 1.e-4 ) THEN +! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100. +! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp +! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), & +! gamxinflu(4,j,1,1) +! ENDIF + ENDIF + + hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) + + ! + + ENDIF + + ENDDO + ENDDO + + ENDIF ! lh + +! And diam for hail if present + IF ( lhl > 1 .and. lnhl > 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. an(ix,jy,kz,lnhl) .gt. thresh_conc ) THEN + IF ( lvhl .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = rho_qhl + ENDIF + + tmp = 1. + alpha2d(ix,1,kz,3) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl)) + diam = (6.0*tmp/pi)**(1./3.) + IF ( lzhl > 1 ) THEN ! 3moment + cwchltmp = ((3. + alpha2d(ix,1,kz,3))*(2. + alpha2d(ix,1,kz,3))*(1.0 + alpha2d(ix,1,kz,3)))**(-1./3.) + ENDIF + diam1 = diam*cwchltmp ! characteristic diameter, i.e., 1/lambda + ! want cxd1 = thresh_conc + ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + ! cxd1 = cx(mgs,lh)*(tmp)/g1palp + ! tmp = thresh_conc*g1palp/cx + ! + tmp = thresh_conc*g1palp/an(ix,jy,kz,lnhl) + alp = alpha2d(ix,1,kz,3) + ! gamxinflu(i,j,luindex,ilh) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + ratio = 0.0 + maxdia = 0.0 + ! eventually could replace with bisection search, but final value of i is usually small + ! compared to nqiacrratio + DO i = 0,nqiacrratio-1 + IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN + ! interpolate here for FWIW + ratio = i*dqiacrratio + del = tmp - gamxinflu(i,j,1,1) + ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio + exit + ENDIF + ENDDO + + IF ( ratio > 0.0 ) THEN + maxdia = ratio*diam1 ! units of m + ENDIF + + IF ( kz == kzb ) THEN + hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) ) +! IF ( maxdia > 0.1 ) THEN +! IF ( an(ix,jy,kz,lhl) > 1.e-4 ) THEN +! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100. +! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp +! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), & +! gamxinflu(4,j,1,1) +! ENDIF + ENDIF + + hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) + + ! + + ENDIF + + ENDDO + ENDDO + + ENDIF + + + END SUBROUTINE HAILMAXD +! ####################################################################### +! ####################################################################### +!>\ingroup mod_nsslmp +!! Sedimentation driver subroutine. Calls fallout column by column + subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & t0,t7,infdo,jslab,its,jts, & & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing ! @@ -3591,7 +4274,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) real dtp real xfall(nx,ny,na) ! array for stuff landing on the ground - real xfall0(nx,ny) ! dummy array +! real xfall0(nx,ny) ! dummy array integer infdo integer jslab ! which line of xfall to use @@ -3599,47 +4282,81 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & real tmp, vtmax, dtptmp, dtfrac real, parameter :: dz = 200. - real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted - real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) - real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) +! real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted +! real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) +! real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) +! real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) +! real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) - real :: rhovtzx(nz,nx) +! real :: rhovtzx(nz,nx) + + real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) ! db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + real, allocatable :: rhovtzx(:,:) + real, allocatable :: xfall0(:,:), xvt(:,:,:,:),tmpn(:,:,:),tmpn2(:,:,:),z(:,:,:) double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy double precision :: dt1,dt2,dt3,dt4 - integer,parameter :: ngs = 128 + integer :: ngs ! = 512 integer :: ngscnt,mgs,ipconc0 - real :: qx(ngs,lv:lhab) - real :: qxw(ngs,ls:lhab) - real :: cx(ngs,lc:lhab) - real :: xv(ngs,lc:lhab) - real :: vtxbar(ngs,lc:lhab,3) - real :: xmas(ngs,lc:lhab) - real :: xdn(ngs,lc:lhab) - real :: xdia(ngs,lc:lhab,3) - real :: vx(ngs,li:lhab) - real :: alpha(ngs,lc:lhab) - real :: zx(ngs,lr:lhab) - logical :: hasmass(nx,lc+1:lhab) - - integer igs(ngs),kgs(ngs) - - real rho0(ngs),temcg(ngs) - - real temg(ngs) - - real rhovt(ngs) - - real cwnc(ngs),cinc(ngs) - real fadvisc(ngs),cwdia(ngs),cipmas(ngs) - - real cimasn,cimasx,cnina(ngs),cimas(ngs) - - real cnostmp(ngs) +! real :: qx(ngs,lv:lhab) +! real :: qxw(ngs,ls:lhab) +! real :: cx(ngs,lc:lhab) +! real :: xv(ngs,lc:lhab) +! real :: vtxbar(ngs,lc:lhab,3) +! real :: xmas(ngs,lc:lhab) +! real :: xdn(ngs,lc:lhab) +! real :: xdia(ngs,lc:lhab,3) +! real :: vx(ngs,li:lhab) +! real :: alpha(ngs,lc:lhab) +! real :: zx(ngs,lr:lhab) +! logical :: hasmass(nx,lc+1:lhab) +! +! integer igs(ngs),kgs(ngs) +! +! real rho0(ngs),temcg(ngs) +! +! real temg(ngs) +! +! real rhovt(ngs) +! +! real cwnc(ngs),cinc(ngs) +! real fadvisc(ngs),cwdia(ngs),cipmas(ngs) +! +! real cimasn,cimasx,cnina(ngs),cimas(ngs) +! +! real cnostmp(ngs) + + real, allocatable :: qx(:,:) + real, allocatable :: qxw(:,:) + real, allocatable :: cx(:,:) + real, allocatable :: xv(:,:) + real, allocatable :: vtxbar(:,:,:) + real, allocatable :: xmas(:,:) + real, allocatable :: xdn(:,:) + real, allocatable :: xdia(:,:,:) + real, allocatable :: vx(:,:) + real, allocatable :: alpha(:,:) + real, allocatable :: zx(:,:) + logical, allocatable :: hasmass(:,:) + + integer, allocatable :: igs(:),kgs(:) + + real, allocatable :: rho0(:),temcg(:) + + real, allocatable :: temg(:) + + real, allocatable :: rhovt(:) + + real, allocatable :: cwnc(:),cinc(:) + real, allocatable :: fadvisc(:),cwdia(:),cipmas(:) + + real, allocatable :: cnina(:),cimas(:) + + real, allocatable :: cnostmp(:) + + real :: cimasn,cimasx !----------------------------------------------------------------------------- @@ -3653,7 +4370,30 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ################################################################### - + allocate( db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1),rhovtzx(nz,nx) ) + allocate( xfall0(nx,ny), xvt(nz+1,nx,3,lc:lhab), tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ) + allocate( tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz), z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)) + + ngs = nz+3 + + allocate( qx(ngs,lv:lhab), & + qxw(ngs,ls:lhab), & + cx(ngs,lc:lhab), & + xv(ngs,lc:lhab), & + vtxbar(ngs,lc:lhab,3), & + xmas(ngs,lc:lhab), & + xdn(ngs,lc:lhab), & + xdia(ngs,lc:lhab,3), & + vx(ngs,li:lhab), & + alpha(ngs,lc:lhab), & + zx(ngs,lr:lhab), & + hasmass(nx,lc+1:lhab), & + igs(ngs),kgs(ngs), & + rho0(ngs),temcg(ngs),temg(ngs), rhovt(ngs), & + cwnc(ngs),cinc(ngs), & + fadvisc(ngs),cwdia(ngs),cipmas(ngs), & + cnina(ngs),cimas(ngs), & + cnostmp(ngs) ) kzb = 1 kze = nz @@ -3825,7 +4565,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN - IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN + IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. & + (il .ge. lh .and. lz(il) .lt. 1 ) .or. (il == ls .and. isfall == infall ) ) THEN call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) ENDIF @@ -3850,6 +4591,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF ENDIF +! reflectivity + + IF ( ipconc .ge. 6 ) THEN + IF ( lz(il) .gt. 1 ) THEN + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + & an,db1,lz(il),0,xfall,dtz1,ix) + ENDIF + ENDIF if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' @@ -3863,9 +4612,11 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! to put a lower bound on number conc. ! - IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. & + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il == ls .and. isfall .eq. infall ) & + & .or. il .eq. lh .or. il .eq. lhl .or. il == lf .or. & & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN + ! set up for method I+II DO kz = kzb,kze ! DO ix = ixb,ixe tmpn2(ix,jy,kz) = z(ix,kz,il) @@ -3878,7 +4629,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ELSE - + ! set up for method II only DO kz = kzb,kze ! DO ix = ixb,ixe tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) @@ -3907,7 +4658,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & xfall0(:,jgs) = 0.0 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & - & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN + & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) & + .or. (il .eq. ls .and. isfall .eq. infall) ) ) THEN call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & & tmpn2,db1,1,0,xfall0,dtz1,ix) call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & @@ -3918,12 +4670,12 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & - & .or. il .ge. lh ) ) THEN + & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) THEN ! "Method I" - dbz correction call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & - & lvol(il), rho_qh, infall, ix) + & lvol(il), xdn0(il), infall, ix) ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN @@ -3934,7 +4686,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ENDDO ENDDO - ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN + ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN ! "Method II" M-wgt N-fallout correction DO kz = kzb,kze @@ -3961,8 +4713,29 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ! ix + deallocate( db1,dtz1,dz2dinv,db1inv,rhovtzx ) + deallocate( xfall0, xvt, tmpn ) + deallocate( tmpn2, z) + + deallocate( qx, & + qxw, & + cx, & + xv, & + vtxbar, & + xmas, & + xdn, & + xdia, & + vx, & + alpha, & + zx, & + hasmass, & + igs,kgs, & + rho0,temcg,temg, rhovt, & + cwnc,cinc, & + fadvisc,cwdia,cipmas, & + cnina,cimas, & + cnostmp ) - RETURN END SUBROUTINE SEDIMENT1D @@ -4120,13 +4893,14 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & integer ix,jy,kz - real vr,qr,nrx,rd,xv,g1,zx,chw,xdn + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu jy = jgs ix = ixcol - IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN + IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) & + .or. ( l .eq. ls .and. imusnow == 1 ) ) THEN DO kz = 1,kze @@ -4176,16 +4950,19 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & ENDDO - ELSEIF ( l .eq. lr .and. imurain == 3) THEN + ELSEIF ( (l == ls .and. imusnow == 3) .or. ( l .eq. lr .and. imurain == 3 ) ) THEN - xdn = 1000. + xdn = rho_qx ! 1000. + IF ( l == ls ) ynu = snu + IF ( l == lr ) ynu = rnu DO kz = 1,kze + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) -! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) - z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) +! z(ix,kz,l) = 3.6e18*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0) + z(ix,kz,l) = 3.6*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0) ! qr = a(ix,jy,kz,lr) ! nrx = a(ix,jy,kz,lnr) @@ -4598,6 +5375,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF ENDIF + IF ( lzr > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lr) > qxmin_init(lr) .and. an(ix,jy,kz,lzr) < zxmin .and. & + an(ix,jy,kz,lnr) > cxmin ) THEN + q = an(ix,jy,kz,lr) + nrx = an(ix,jy,kz,lnr) + an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv + ENDIF + ENDIF + ! snow IF ( lns > 1 ) THEN IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN @@ -4660,6 +5446,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF ENDIF + IF ( lzh > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lh) > qxmin_init(lh) .and. an(ix,jy,kz,lzh) < zxmin .and. & + an(ix,jy,kz,lnh) > cxmin ) THEN + q = an(ix,jy,kz,lh) + nrx = an(ix,jy,kz,lnh) + an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv + ENDIF + ENDIF + ! hail IF ( lnhl > 1 .and. lhl > 1 ) THEN @@ -4680,7 +5475,6 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio - ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN @@ -4689,6 +5483,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF ENDIF + + IF ( lzhl > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lhl) > qxmin_init(lhl) .and. an(ix,jy,kz,lzhl) < zxmin .and. & + an(ix,jy,kz,lnhl) > cxmin ) THEN + q = an(ix,jy,kz,lhl) + nrx = an(ix,jy,kz,lnhl) + an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv + ENDIF + ENDIF ! ENDIF @@ -4859,6 +5662,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass ENDIF + IF ( lzr > 1 ) THEN ! set reflectivity moment + an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv + ENDIF ENDIF ENDIF @@ -4909,6 +5715,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio ! +! IF ( lzh > 1 ) THEN ! set reflectivity moment +! an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv +! ENDIF ! ENDIF ! ENDIF ! @@ -4932,6 +5741,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio ! +! IF ( lzhl > 1 ) THEN ! set reflectivity moment +! an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv +! ENDIF ! ENDIF ! ENDIF @@ -4950,7 +5762,7 @@ END subroutine calcnfromcuten SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & - & ,t1,t2,t3,t4 & + & ,t1,t2,t3,t4,t5,t6, f_t5,f_t6 & & ,qcw,qci,qsw,qrw & & ,ccw,cci,csw,crw & & ,an,dn ) @@ -4972,6 +5784,9 @@ SUBROUTINE calc_eff_radius & real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + logical, optional :: f_t5, f_t6 ! flags to fill t5/t6 for graupel/hail real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) @@ -6490,6 +7305,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) aax = axx(mgs,lhl) bbx = bxx(mgs,lhl) + ELSEIF ( icdxhl <= 0 ) THEN ! + aax = ax(lhl) + bbx = bx(lhl) ENDIF ENDIF ! } @@ -6798,7 +7616,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & real vtmax real xvbarmax - + + real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain + real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel + real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail + integer l1, l2 double precision :: dpt1, dpt2 @@ -7074,68 +7896,549 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ELSEIF ( imurain == 3 ) THEN alpha(:,lr) = xnu(lr) ENDIF - - - + IF ( ipconc == 5 .and. imydiagalpha > 0 ) THEN + DO mgs = 1,ngscnt + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! + xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) + alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) + ENDIF + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) + ENDIF +! alpha(:,lr) = 0. ! 10. +! alpha(:,lh) = 0. ! 10. + IF ( lhl > 0 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.) + IF ( xdia(mgs,lhl,3) < 0.008 ) THEN + alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl) + ELSE + alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl) + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF ! -! Set density -! - if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' +! Set 6th moments ! + IF ( ipconc .ge. 6 .or. lzr > 1) THEN - call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & - & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & - & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & - & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx) -! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + zx(:,:) = 0.0 + +! DO il = lr,lhab + DO il = l1,l2 + + IF ( lz(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + zx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0) + ENDDO + + + ENDIF + + ENDDO + + ENDIF + -! -! put fall speeds into the x-z arrays -! - DO il = l1,l2 - do mgs = 1,ngscnt - vtmax = 150.0 +! Find shape parameter rain - - IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & - & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN - - - - vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) - vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) + + IF ( lz(lr) > 1 .and. (ildo == 0 .or. ildo == lr ) .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM + il = lr + DO mgs = 1,ngscnt + + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN +! IF ( .false. .and. zx(mgs,lr) <= zxmin ) THEN + IF ( zx(mgs,lr) <= zxmin ) THEN + qx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) +! ELSEIF ( zx(mgs,lr) <= 0.0 .and. cx(mgs,lr) > 0.0 .and. qx(mgs,il) .gt. qxmin(il)) THEN +! write(91,*) 'ZF: overdepletion of Zr: z,c,q = ',zx(mgs,il),cx(mgs,il),qx(mgs,il) + ELSEIF ( cx(mgs,lr) <= cxmin ) THEN + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + - ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN - - IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & - & vtxbar(mgs,il,3) .gt. vtmax ) THEN - - vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) - vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) - vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) - -! call commasmpi_abort() - ENDIF + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! tmp = cx(mgs,lr) +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) +! IF ( tmp < cx(mgs,il) ) THEN ! breakup +! g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) +!! zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(1000.))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) +!! an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) +! ENDIF + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr))) +! vr = xv(mgs,lr) + +! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! write(91,*) 'alpha = ',alpha(mgs,il) + IF ( qx(mgs,il) < 1.e-8 ) THEN + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + ELSE +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr))) + vr = xv(mgs,lr) +! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN +! alpha(mgs,lr) = 3. + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 +! IF ( 100.*Abs(alp - alpha(mgs,lr))/Abs(alpha(mgs,lr)) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. +! write(0,*) 'i,alp = ',i,alp + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO +! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(mgs,lr),qr*1000,z*1.e18,vr,nrx + + +! check for artificial breakup (rain larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) ) THEN + tmp = cx(mgs,il) + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO - xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) - xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) - IF ( infdo .ge. 2 ) THEN - xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) - ELSE - xvt(kgs(mgs),igs(mgs),3,il) = 0.0 - ENDIF + + ENDIF + ENDIF -! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! +! IF ( alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax ) THEN + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + + ENDIF + ENDIF + + ENDIF + ENDIF + + ELSE + + zx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ENDIF + + ENDDO + ENDIF ! } + + + IF ( ipconc .ge. 6 ) THEN + +! Find shape parameters for graupel,hail + + DO il = lr,lhab + + IF ( lz(il) .gt. 1 .and. (ildo == 0 .or. ildo == il ) .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN + + DO mgs = 1,ngscnt + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN +!! write(91,*) 'cx=0; qx,zx = ',1000.*qx(mgs,il),1.e18*zx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN +! tmp = cx(mgs,il) + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) +! IF ( tmp < cx(mgs,il) ) THEN ! breakup +! g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) +! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) +! an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) +! +! ENDIF + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? +! write(91,*) 'ziegfall: something screwy with moments: il = ',il +! write(91,*) 'q,n,z = ', 1.e3*qx(mgs,il),cx(mgs,il),zx(mgs,il) +! write(91,*) 'alpha = ',alpha(mgs,il) + + IF ( qx(mgs,il) < 1.e-8 ) THEN + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + ELSE +! write(0,*) 'alpha = ',alpha(mgs,il) + ! set values according to dBZ of -10 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) .and. cx(mgs,il) .gt. cxmin ) THEN + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN + +! rd = z*(pi/6.*1000.)**2*chw/(0.224*(dn(igs(mgs),jy,kgs(mgs))*qr)**2) + rd = z*(pi/6.*xdn(mgs,il))**2*chw/((dn(igs(mgs),jy,kgs(mgs))*qr)**2) + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 +! write(0,*) 'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + +! check for artificial breakup (graupel/hail larger than allowed max size) + + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ENDIF + + IF ( xv(mgs,il) .gt. xvbarmax ) THEN + tmp = cx(mgs,il) + xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rd = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alpha .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) ) THEN + +!! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*( 0.224*qr)*qr/chw + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + ENDIF + ELSE + ENDIF + ENDIF + ENDDO ! mgs + + ENDIF ! lz(il) .gt. 1 + + ENDDO ! il + +! CALL cld_cpu('Z-MOMENT-ZFAll') + + ENDIF + + IF ( lzhl > 1 ) THEN + IF ( lhl .gt. 1 ) THEN + + ENDIF + ENDIF + + + +! +! Set density +! + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' +! + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + +! +! put fall speeds into the x-z arrays +! + DO il = l1,l2 + do mgs = 1,ngscnt + + vtmax = 150.0 + + + IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & + & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN + + +! IF ( qx(mgs,il) > 1.e-4 .and. & +! & .not. ( il == lr .and. 1.e3*xdia(mgs,il,3) > 5.0 ) ) THEN +! write(0,*) 'infdo,mgs = ',infdo,lzr,mgs +! write(0,*) 'Moment problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs) +! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor +! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3) +! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3) +! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il) +! IF ( il .ge. lg .or. il == lr ) THEN +! write(0,*) 'alpha = ',alpha(mgs,il) +! ENDIF +! ENDIF + + vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) + + ENDIF + + + IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & + & vtxbar(mgs,il,3) .gt. vtmax ) THEN + +! IF ( ndebugzf >= 0 .and. 1.e3*qx(mgs,il) > 0.1 ) THEN +! write(0,*) 'infdo = ',infdo +! write(0,*) 'Problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs) +! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor +! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3) +! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3) +! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il) +! IF ( il .ge. lg ) THEN +! write(0,*) 'alpha = ',alpha(mgs,il) +! ENDIF +! ENDIF + vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) + vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) + +! call commasmpi_abort() + ENDIF + + + xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) + xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) + IF ( infdo .ge. 2 ) THEN + xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) + ELSE + xvt(kgs(mgs),igs(mgs),3,il) = 0.0 + ENDIF + +! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) enddo ENDDO @@ -7630,6 +8933,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .le. 2 ) THEN gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( lzr .gt. 1 ) THEN + dtmp(ix,kz) = 1e18*an(ix,jy,kz,lzr) ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN IF ( imurain == 3 ) THEN vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) @@ -7822,7 +9127,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size ! p = 0.106214 for m = p v^(2/3) - dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) + dnsnow = 0.0346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) IF ( .true. .or. dnsnow < 900. ) THEN gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + & & (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ & @@ -7898,6 +9203,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN ltest = .false. + IF ( lzh > 1 ) THEN + IF ( an(ix,jy,kz,lzh) > 0.0 .and. an(ix,jy,kz,lh) > qhmin .and. & + an(ix,jy,kz,lnh) >= cxmin ) ltest = .true. + ENDIF IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN @@ -7943,6 +9252,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF IF ( lzh .gt. 1 ) THEN + x = (0.224*qh + 0.776*qxw)/an(ix,jy,kz,lh) ! weighted average of dielectric const + dtmph = 1.e18*x*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + dtmp(ix,kz) = dtmp(ix,kz) + dtmph ELSE g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) ! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw @@ -8015,6 +9327,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .ge. 5 ) THEN ltest = .false. + IF ( lzhl > 1 ) THEN + IF ( an(ix,jy,kz,lzhl) > 0.0 .and. an(ix,jy,kz,lhl) > qhlmin .and. & + an(ix,jy,kz,lnhl) > 0.0 ) ltest = .true. + ENDIF IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ chl = an(ix,jy,kz,lnhl) @@ -8038,6 +9354,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF IF ( lzhl .gt. 1 ) THEN !{ + x = (0.224*an(ix,jy,kz,lhl) + 0.776*qxw)/an(ix,jy,kz,lhl) ! weighted average of dielectric const + dtmphl = 1.e18*x*an(ix,jy,kz,lzhl)*(hldn/rwdn)**2 + dtmp(ix,kz) = dtmp(ix,kz) + dtmphl ELSE !} g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) @@ -8118,8 +9437,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) ! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph ! ENDIF - - IF ( ndebug>1 .and. .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN + IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN ! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN ! write(0,*) 'my_rank = ',my_rank write(0,*) 'ix,jy,kz = ',ix,jy,kz @@ -8190,6 +9508,8 @@ END subroutine radardd02 ! ##################################################################### ! ! Subroutine for explicit cloud condensation and droplet nucleation +! +! 11/30/2022: Fixed droplet evaporation heating term for CM1 eqtset=2 (was only doing eqtset=1) ! SUBROUTINE NUCOND & & (nx,ny,nz,na,jyslab & @@ -8198,6 +9518,7 @@ SUBROUTINE NUCOND & & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & + & ,ngs & & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) @@ -8256,6 +9577,7 @@ SUBROUTINE NUCOND & logical :: io_flag real :: dv + real :: ccnefactwo, sstmp, cn1, cnuctmp ! ! declarations microphysics and for gather/scatter @@ -8264,7 +9586,6 @@ SUBROUTINE NUCOND & real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. integer nxmpb,nzmpb,nxz integer mgs,ngs,numgs,inumgs - parameter (ngs=500) integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs) integer nsvcnt @@ -8283,6 +9604,7 @@ SUBROUTINE NUCOND & real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real :: ccnc_nu(ngs), ccnc_ac(ngs), ccnc_co(ngs) real ccncuf(ngs) real sscb ! 'cloud base' SS threshold parameter ( sscb = 2.0 ) @@ -8295,7 +9617,7 @@ SUBROUTINE NUCOND & integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold - real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel + real :: ssmax(ngs) ! maximum SS experienced by a parcel real ssmx real dnnet,dqnet ! real cnu,rnu,snu,cinu @@ -8419,7 +9741,6 @@ SUBROUTINE NUCOND & integer :: count - ! ------------------------------------------------------------------------------- itile = nxi jtile = ny @@ -8433,6 +9754,7 @@ SUBROUTINE NUCOND & kzbeg = 1 nzbeg = 1 + IF ( ac_opt > 0 ) ccnefactwo = (1.63e-3/(cck * beta(3./2., cck/2.)))**(1.0/(cck + 2.0)) f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) jy = 1 @@ -8543,6 +9865,7 @@ SUBROUTINE NUCOND & qx(:,:) = 0.0 cx(:,:) = 0.0 + zx(:,:) = 0.0 xv(:,:) = 0.0 xmas(:,:) = 0.0 @@ -8602,6 +9925,7 @@ SUBROUTINE NUCOND & ELSE ! equation set 2 in cm1 tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + IF ( lf > 1 ) tmp = tmp + qx(mgs,lf) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & @@ -8656,12 +9980,16 @@ SUBROUTINE NUCOND & ELSE ssmax(mgs) = 0.0 ENDIF - IF ( lccn .gt. 1 ) THEN - ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + IF ( lccn .gt. 1 .and. ac_opt == 0 ) THEN + IF ( lccnuf .gt. 1 .and. i_uf_or_ccn > 0 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + an(igs(mgs),jy,kgs(mgs),lccnuf) + ELSE + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ENDIF ELSE ccnc(mgs) = cwnccn(mgs) ENDIF - IF ( lccnuf .gt. 1 ) THEN + IF ( lccnuf .gt. 1 .and. i_uf_or_ccn == 0 ) THEN ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf) ELSE ccncuf(mgs) = 0.0 @@ -8716,6 +10044,237 @@ SUBROUTINE NUCOND & ventrxn(:) = ventrn +! Find shape parameter rain + + IF ( lzr > 1 .and. rcond == 2 ) THEN ! { RAIN SHAPE PARAM + DO mgs = 1,ngscnt + zx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lzr), 0.0) + ENDDO + +! CALL cld_cpu('Z-MOMENT-1r2') + il = lr + DO mgs = 1,ngscnt + + IF ( zx(mgs,il) <= zxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( cx(mgs,il) <= 0.0 ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN + xv(mgs,lr) = xvmx(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + + ENDIF +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000) + + ENDIF + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( imurain == 1 ) THEN + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z1*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ENDIF + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) +! z1 = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z1 = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z1*(pi/6.*1000.)**2/xv + + +! determine shape parameter alpha by iteration + IF ( z1 .gt. 0.0 ) THEN + + IF ( imurain == 3 ) THEN + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1. +! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z1,xv + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1. +! write(0,*) 'i,alp = ',i,alp + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + ELSE ! imurain == 1 + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + + rd1 = z1*(pi/6.*xdn(mgs,il))**2*nrx/(rho0(mgs)*qr)**2 + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0 + + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0 + + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF +! ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + IF ( imurain == 3 ) THEN + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + + z1 = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z1 + ENDIF + ENDIF + + ELSEIF ( imurain == 1 ) THEN + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*rho0(mgs)**2*(qr)*qr/zx(mgs,lr)*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alpha .and. alp <= alphamin ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + z1 = g1*rho0(mgs)**2*(qr)*qr/nrx + z2 = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z2 + an(igs(mgs),jy,kgs(mgs),lz(il)) = z2 + ENDIF + ENDIF ! imurain + + ENDIF ! z > 0 + + tmp = alpha(mgs,lr) + 4./3. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma(alpha(mgs,lr) + 1.) + ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + + IF ( imurain == 3 .and. izwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 1.5 + br/6. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) + + ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 2.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/y + + + ENDIF + + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r2') + ENDIF ! } + ! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit ssmx = 0.0 @@ -8735,6 +10294,8 @@ SUBROUTINE NUCOND & ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) +! IF ( wvel(mgs) /= 0.0 ) write(0,*) 'mgs,wvel1,ssf = ',mgs,wvel(mgs),ssf(mgs) + ENDDO @@ -8744,7 +10305,7 @@ SUBROUTINE NUCOND & ! cloud water variables ! - if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set cloud water variables' do mgs = 1,ngscnt xv(mgs,lc) = 0.0 @@ -8868,23 +10429,22 @@ SUBROUTINE NUCOND & QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) - IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 + IF ( qx(mgs,lc) <= QEVAP ) THEN ! GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) - thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + thetap(mgs) = thetap(mgs) - felvcp(mgs)*qx(mgs,lc)/(pi0(mgs)) IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp ENDIF qx(mgs,lc) = 0. IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN - IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) - ELSE - ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) - ENDIF - ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - cx(mgs,lc) + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + ELSEIF ( irenuc <= 2 ) THEN + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) + ENDIF ENDIF ENDIF cx(mgs,lc) = 0. @@ -8894,39 +10454,37 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) - QEVAP IF ( qx(mgs,lc) .le. 0. ) THEN IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) ! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) ELSE - ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ENDIF ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - cx(mgs,lc) - ENDIF ENDIF cx(mgs,lc) = 0. ELSE tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp + ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) ! ccnc(mgs) = ccnc(mgs) + tmp IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*tmp ) ) ELSE - ccnc(mgs) = ccnc(mgs) + tmp + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp ENDIF ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - tmp - ENDIF ENDIF cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF - thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + thetap(mgs) = thetap(mgs) - felvcp(mgs)*QEVAP/(pi0(mgs)) IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp ENDIF @@ -9208,11 +10766,24 @@ SUBROUTINE NUCOND & !! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) - theta(mgs) = thetap(mgs) + theta0(mgs) - temg(mgs) = theta(mgs)*f1 - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + IF ( lzr > 1 .and. rcond == 2 .and. qx(mgs,lr) .gt. qxmin(lr) & + & .and. cx(mgs,lr) .gt. 1.e-9 ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + + ENDIF + zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(xdn(mgs,lr)))**2*( 2.*( tmp ) * dqr ) + ENDIF + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*f1 + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ! es(mgs) = 6.1078e2*tabqvs(ltemq) ! @@ -9249,7 +10820,8 @@ SUBROUTINE NUCOND & ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK - IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test + IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. & + ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test ! IF ( ssf(mgs) > ssmx ) THEN ! original condition CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) @@ -9260,7 +10832,7 @@ SUBROUTINE NUCOND & ELSE dcloud = 0.0 ENDIF - + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD @@ -9285,11 +10857,16 @@ SUBROUTINE NUCOND & IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem + IF ( ac_opt == 0 ) THEN + cnuctmp = cnuc(mgs) + ELSE + cnuctmp = ccnc_ac(mgs) + ENDIF ! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN ! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 - CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = CCNE0*cnuctmp**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & & .and. ncdebug .ge. 1 ) THEN write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & @@ -9311,12 +10888,16 @@ SUBROUTINE NUCOND & ENDIF IF ( cn(mgs) .gt. 0.0 ) THEN - IF ( cn(mgs) .gt. ccnc(mgs) ) THEN - cn(mgs) = ccnc(mgs) -! ccnc(mgs) = 0.0 + IF ( ac_opt == 0 ) THEN + IF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) +! ccnc(mgs) = 0.0 + ENDIF + ELSE + cn(mgs) = Min( cn(mgs), ccnc_ac(mgs) ) ENDIF ! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ccna(mgs) = ccna(mgs) + cn(mgs) ENDIF @@ -9362,7 +10943,8 @@ SUBROUTINE NUCOND & DSSDZ=0. r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) - IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) + + IF ( irenuc >= 0 .and. ac_opt == 0 .and. .not. flag_qndrop ) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) IF ( irenuc < 2 ) THEN !{ @@ -9439,6 +11021,7 @@ SUBROUTINE NUCOND & ! nucleation CN(mgs) = Min(cn(mgs), ccnc(mgs)) cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + CN(mgs) = Min( CN(mgs), Max(0.0, (cnuc(mgs) - ccna(mgs) )) ) IF ( .false. .and. ny <= 2 ) THEN write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn @@ -9466,8 +11049,136 @@ SUBROUTINE NUCOND & cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + IF ( lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 3 ) THEN !} { + ! Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = cwccn*Min(ssf(mgs),ssfcut)**cck + +! Need to calculate new ssf since condensation has happened: + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + CN(mgs) = cnuc(mgs)*Min(1.0, (ssf(mgs))**cck ) ! + + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 4 ) THEN !} { + ! modification of Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp +! cn(mgs) = Min( cn(mgs), cnuc(mgs) ) +! Need to calculate new ssf since condensation has happened: + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + CN(mgs) = cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ! this allows cn(mgs) > cnuc(mgs) + + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air +! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + + + ELSEIF ( irenuc == 6 ) THEN !} { + + ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + cn(mgs) = 0.0 +! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation + IF ( ccna(mgs) < 0.7*cnuc(mgs) ) THEN ! here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( 0.9*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 +! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN + ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (0.7*cnuc(mgs) - ccna(mgs) )) ) +! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) + + ELSE + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + +! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF +! CN(mgs) = cnuc(mgs)*Min(0.99, Min(ssf(mgs),ssfcut)**cck ) ! + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,ssf(mgs))**cck ) ! +! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck ! + + + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from +! cn(mgs) = 0.0 + ENDIF +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF ELSEIF ( irenuc == 5 ) THEN !} { ! modification of Phillips Donner Garner 2007 @@ -9525,17 +11236,22 @@ SUBROUTINE NUCOND & ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - ELSEIF ( irenuc == 7 ) THEN !} { + ELSEIF ( irenuc == 7 .or. irenuc == 17 ) THEN !} { ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) cn(mgs) = 0.0 + IF ( irenuc == 7 ) THEN + frac = 0.9 + ELSE + frac = 0.98 + ENDIF ! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation - IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation - CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + IF ( ccna(mgs) < frac*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( (frac+0.01)*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN ! prevent this branch from activating more than 70% of CCN - CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) ) + CN(mgs) = Min( CN(mgs), Max(0.0, (frac*cnuc(mgs) - ccna(mgs) )) ) ! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) !! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN @@ -9573,7 +11289,7 @@ SUBROUTINE NUCOND & ! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) ! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs) ! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN - IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN + IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ( ssmax(mgs) > ssmxuf .or. lss < 1 ) ) THEN CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) ENDIF @@ -9675,7 +11391,7 @@ SUBROUTINE NUCOND & IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ! create some small droplets at minimum size (CP 2000), although it adds very little liquid @@ -9694,8 +11410,6 @@ SUBROUTINE NUCOND & ccna(mgs) = ccna(mgs) + cn(mgs) - - ENDIF ! irenuc >= 0 .and. .not. flag_qndrop IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. @@ -9748,7 +11462,11 @@ SUBROUTINE NUCOND & ELSEIF ( imaxsupopt == 4 ) THEN cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) ENDIF - ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) + cn(mgs) + ELSE + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + ENDIF cx(mgs,lc) = cx(mgs,lc) + cn(mgs) ENDIF @@ -9853,15 +11571,21 @@ SUBROUTINE NUCOND & ! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) end if + IF ( lzr > 1 .and. rcond == 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lzr) = zx(mgs,lr) + & + & min( an(igs(mgs),jy,kgs(mgs),lzr), 0.0 ) + ENDIF IF ( ipconc .ge. 2 ) THEN an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) - IF ( lccn .gt. 1 ) THEN - an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + IF ( ac_opt == 0 ) THEN + IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF ENDIF - IF ( lccnuf .gt. 1 ) THEN + IF ( lccnuf .gt. 1 .and. .not. ( lccna .gt. 1 .and. i_uf_or_ccn > 0 ) ) THEN an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) ENDIF IF ( lccna .gt. 1 ) THEN @@ -9938,6 +11662,42 @@ SUBROUTINE NUCOND & IF ( lhl .gt. 1 ) THEN + IF ( lzhl .gt. 1 ) THEN + + an(ix,jy,kz,lzhl) = Max(0.0, an(ix,jy,kz,lzhl) ) + + IF ( an(ix,jy,kz,lhl) .ge. frac*qxmin(lhl) .and. rescale_low_alpha ) THEN ! check 6th moment + + IF ( an(ix,jy,kz,lnhl) .gt. 0.0 ) THEN + + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + hwdn = Max( xdnmn(lhl), hwdn ) + ELSE + hwdn = xdn0(lhl) + ENDIF + + chw = an(ix,jy,kz,lnhl) + g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ & + & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin)) + z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lhl) )*an(ix,jy,kz,lhl)/chw + z1 = z1*(6./(pi*hwdn))**2 + ELSE + z1 = 0.0 + ENDIF + + an(ix,jy,kz,lzhl) = Min( z1, an(ix,jy,kz,lzhl) ) + + IF ( an(ix,jy,kz,lnhl) .lt. 1.e-5 ) THEN +! an(ix,jy,kz,lzhl) = 0.9*an(ix,jy,kz,lzhl) + ENDIF + ENDIF + + ENDIF !lzhl if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then @@ -10038,6 +11798,42 @@ SUBROUTINE NUCOND & + IF ( lzh .gt. 1 ) THEN + + an(ix,jy,kz,lzh) = Max(0.0, an(ix,jy,kz,lzh) ) + + IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. rescale_low_alpha ) THEN + + IF ( an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = xdn0(lh) + ENDIF + hwdn = Max( xdnmn(lh), hwdn ) + ELSE + hwdn = xdn0(lh) + ENDIF + + chw = an(ix,jy,kz,lnh) + g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ & + & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin)) + z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lh) )*an(ix,jy,kz,lh)/chw + z1 = z1*(6./(pi*hwdn))**2 + ELSE + z1 = 0.0 + ENDIF + + an(ix,jy,kz,lzh) = Min( z1, an(ix,jy,kz,lzh) ) + + IF ( an(ix,jy,kz,lnh) .lt. 1.e-5 ) THEN +! an(ix,jy,kz,lzh) = 0.9*an(ix,jy,kz,lzh) + ENDIF + ENDIF + + ENDIF if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then @@ -10198,6 +11994,9 @@ SUBROUTINE NUCOND & end if + IF ( lzr > 1 ) THEN + an(ix,jy,kz,lzr) = Max(0.0, an(ix,jy,kz,lzr) ) + ENDIF if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & & ) then @@ -10208,6 +12007,10 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lnr) = 0.0 ENDIF + IF ( lzr > 1 ) THEN + an(ix,jy,kz,lzr) = 0.0 + ENDIF + end if ! @@ -10260,18 +12063,25 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) an(ix,jy,kz,lc)= 0.0 IF ( ipconc .ge. 2 ) THEN - IF ( lccn .gt. 1 ) THEN - an(ix,jy,kz,lccn) = & - & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + IF ( lccn .gt. 1 .or. ac_opt == 1 ) THEN + IF ( irenuc < 5 .and. lccna <= 1 ) THEN + IF ( ac_opt == 0 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ENDIF + ELSEIF ( lccna > 1 ) THEN + an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - Max(0.0,an(ix,jy,kz,lnc)) ) + ENDIF ENDIF an(ix,jy,kz,lnc) = 0.0 + IF ( lccn > 1 ) an(ix,jy,kz,lccn) = Max( 0.0, an(ix,jy,kz,lccn) ) - IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + IF ( restoreccn ) THEN tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) - - ELSEIF ( lccn > 1 .and. restoreccn ) THEN + ENDIF + ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN ! in this case, we are treating the ccn field as ccna tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) ! IF ( ny == 2 .and. ix == nx/2 ) THEN @@ -10335,9 +12145,9 @@ subroutine nssl_2mom_gs & ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,tmp3d,tkediss & - & ,thproc,numproc,dx1,dy1 & + & ,thproc,numproc,dx1,dy1,ngs & & ,timevtcalc,axtra,io_flag & - & , has_wetscav,rainprod2d, evapprod2d & + & , has_wetscav,rainprod2d, evapprod2d, alpha2d & & ,errmsg,errflg & & ,elec,its,ids,ide,jds,jde & & ) @@ -10425,6 +12235,12 @@ subroutine nssl_2mom_gs & real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + + real :: alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3) + + real, parameter :: tfrdry = 243.15 + + logical lrescalelow(lc:lhab) real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) @@ -10570,7 +12386,6 @@ subroutine nssl_2mom_gs & ! integer nxmpb,nzmpb,nxz integer jgs,mgs,ngs,numgs - parameter (ngs=500) !500) integer, parameter :: ngsz = 500 integer ntt parameter (ntt=300) @@ -10633,7 +12448,8 @@ subroutine nssl_2mom_gs & real ex1, ft, rhoinv(ngs) double precision ec0(ngs) - real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super + real :: flim real dw,dwr double precision :: tmpz, tmpzmlt real ratio, delx, dely @@ -10714,7 +12530,7 @@ subroutine nssl_2mom_gs & real temgx(ngs),temcgx(ngs) real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) real elv(ngs),elf(ngs),els(ngs) - real tsqr(ngs),ssi(ngs),ssw(ngs) + real tsqr(ngs),ssi(ngs),ssw(ngs),ssi0(ngs) real qcwtmp(ngs),qtmp,qtot(ngs) real qcond(ngs) real ctmp, sctmp @@ -10729,6 +12545,7 @@ subroutine nssl_2mom_gs & parameter ( rwradmn = 50.e-6 ) real dh0 real dg0(ngs),df0(ngs) + real dhwet(ngs),dhlwet(ngs),dfwet(ngs) real clionpmx,clionnmx parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 @@ -10736,7 +12553,7 @@ subroutine nssl_2mom_gs & ! other arrays real fwet1(ngs),fwet2(ngs) - real fmlt1(ngs),fmlt2(ngs) + real fmlt1(ngs),fmlt2(ngs),fmlt1e(ngs) real fvds(ngs),fvce(ngs),fiinit(ngs) real fvent(ngs),fraci(ngs),fracl(ngs) ! @@ -10760,6 +12577,7 @@ subroutine nssl_2mom_gs & ! real :: sfm1(ngs),sfm2(ngs) real :: gfm1(ngs),gfm2(ngs) + real :: ffm1(ngs),ffm2(ngs) real :: hfm1(ngs),hfm2(ngs) logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs) @@ -10800,6 +12618,10 @@ subroutine nssl_2mom_gs & real :: alpha(ngs,lc:lhab) real :: dab0lh(ngs,lc:lhab,lc:lhab) real :: dab1lh(ngs,lc:lhab,lc:lhab) + real :: zx(ngs,lr:lhab) + real :: zxmxd(ngs,lr:lhab) + real :: g1x(ngs,lr:lhab) + real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis real :: qsimxsub(ngs) ! max depositionof qi+qs+qis @@ -10815,6 +12637,7 @@ subroutine nssl_2mom_gs & real ventrxn(ngs) real g1shr, alphashr real g1mlr, alphamlr + real g1smlr, alphasmlr real massfacshr, massfacmlr real :: qhgt8mm ! ice mass greater than 8mm @@ -10827,6 +12650,8 @@ subroutine nssl_2mom_gs & real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield ! real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) + real hxventtmp + real hlventinc(ngs),hwventinc(ngs) integer, parameter :: ndiam = 10 integer :: numdiam real hwvent0(ndiam+4),hlvent0 ! 0 to d1 @@ -10940,15 +12765,15 @@ subroutine nssl_2mom_gs & real qrcnw(ngs), qwcnr(ngs) real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) - real qracw(ngs) ! qwacr(ngs), real qiacw(ngs) !, qwaci(ngs) real qsacw(ngs) ! ,qwacs(ngs), real qhacw(ngs) ! qwach(ngs), - real :: qhlacw(ngs) ! + real :: qhlacw(ngs), qxacwtmp, qxacrtmp, qxacitmp, qxacstmp ! real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + real qfcev(ngs) real qfmul1(ngs),cfmul1(ngs) ! real qsacws(ngs) @@ -10957,7 +12782,7 @@ subroutine nssl_2mom_gs & ! arrays for x-ac-r and r-ac-x; ! real qsacr(ngs),qracs(ngs) - real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs) + real qhacr(ngs),qhacrmlr(ngs),qhacwmlr(ngs) ! ,qrach(ngs) real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) real qiacr(ngs),qraci(ngs) @@ -10965,7 +12790,7 @@ subroutine nssl_2mom_gs & real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) - real :: qhlacr(ngs),qhlacrmlr(ngs) + real :: qhlacr(ngs),qhlacrmlr(ngs), qhlacwmlr(ngs) real qsacrs(ngs) !,qracss(ngs) ! ! ice - ice interactions @@ -11011,7 +12836,8 @@ subroutine nssl_2mom_gs & real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs) real zhmlrtmp,zhmlr0inf,zhlmlr0inf real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs) - real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) +! real zsmlr(ngs) + real zsmlrr(ngs), zsshr(ngs), zsshrr(ngs) real zhcns(ngs), zhcni(ngs) real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes real zhldn(ngs) ! change in Z due to density changes @@ -11052,9 +12878,10 @@ subroutine nssl_2mom_gs & ! real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) - real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) + real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs), qxwettmp ! real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) + real :: qffz(ngs) ! real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) @@ -11064,6 +12891,7 @@ subroutine nssl_2mom_gs & real qhshh(ngs) !accreted water that remains on graupel real qhmlh(ngs) !melt water that remains on graupel real qhfzh(ngs) !water that freezes on mixed-phase graupel + real qffzf(ngs) !water that freezes on mixed-phase FD real qhlfzhl(ngs) !water that freezes on mixed-phase hail real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters @@ -11115,6 +12943,7 @@ subroutine nssl_2mom_gs & real qrshr(ngs) real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions + real ffwmax(ngs) real qhcnf(ngs) real :: qhlcnh(ngs) real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) @@ -11128,7 +12957,7 @@ subroutine nssl_2mom_gs & real ehxr(ngs),ehlr(ngs),egmr(ngs) real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) - real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) + real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs),ehsfac(ngs) real ehscnv(ngs) real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) @@ -11187,12 +13016,13 @@ subroutine nssl_2mom_gs & real pqgli(ngs),pqghi(ngs),pqfwi(ngs) real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), - real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) + real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs),pqlwfi(ngs) real pqlwlghi(ngs),pqlwlghli(ngs) real pqlwlghd(ngs),pqlwlghld(ngs) + real pvhwi(ngs), pvhwd(ngs) real pvfwi(ngs), pvfwd(ngs) @@ -11204,7 +13034,7 @@ subroutine nssl_2mom_gs & real pqgld(ngs),pqghd(ngs),pqfwd(ngs) real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) real pqird(ngs),pqipd(ngs) ! pqwad(ngs), - real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) + real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs),pqlwfd(ngs) ! ! real pqxii(ngs,nhab),pqxid(ngs,nhab) ! @@ -11352,7 +13182,7 @@ subroutine nssl_2mom_gs & real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 - real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt + real total, qweps, gf2a, gf4a, dqldt, dqidt, dqdt real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 real a1,a2,a3,a4,a5,a6 @@ -11384,9 +13214,22 @@ subroutine nssl_2mom_gs & real :: term1,term2,term3,term4 real :: qaacw ! combined qsacw-qhacw for WSM6 variation + real :: cwchtmp + + real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain + real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel + real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail +! inline functions for Newton method + real :: galpha, dgalpha + real :: a_in + logical, parameter :: newton = .false. + + galpha(a_in) = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in)) + dgalpha(a_in) = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ & + & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6) ! ! #################################################################### ! @@ -11416,6 +13259,11 @@ subroutine nssl_2mom_gs & jstag = 0 kstag = 1 + lrescalelow(:) = rescale_low_alpha + lrescalelow(lr) = rescale_low_alphar .and. rescale_low_alpha + lrescalelow(lh) = rescale_low_alphah .and. rescale_low_alpha + IF ( lf > 1 ) lrescalelow(lf) = rescale_low_alphah .and. rescale_low_alpha + IF ( lhl > 1 ) lrescalelow(lhl) = rescale_low_alphahl .and. rescale_low_alpha ! @@ -11533,11 +13381,18 @@ subroutine nssl_2mom_gs & vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) - snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + IF ( snowmeltdia > 0.0 ) THEN + snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + ENDIF tdtol = 1.0e-05 tfrcbw = tfr - cbw tfrcbi = tfr - cbi + + IF ( mixedphase ) THEN + ibinhmlr = 0 + ibinhlmlr = 0 + ENDIF ! ! ! #ifdef COMMAS @@ -11689,35 +13544,25 @@ subroutine nssl_2mom_gs & do ix = nxmpb,itile pqs(1) = t00(ix,jy,kz) -! pqs(kz) = t00(ix,jy,kz) theta(1) = an(ix,jy,kz,lt) temg(1) = t0(ix,jy,kz) temcg(1) = temg(1) - tfr tqvcon = temg(1)-cbw - ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = (temg(1)-163.15)/fqsat + 1.5 ltemq = Min( nqsat, Max(1,ltemq) ) qvs(1) = pqs(1)*tabqvs(ltemq) - qis(1) = pqs(1)*tabqis(ltemq) + IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN + qis(1) = pqs(1)*tabqis(ltemq) + ELSE + ltemq = (tfr - 163.15)/fqsat + 1.5 + qis(1) = pqs(1)*tabqis(ltemq) + ENDIF qss(1) = qvs(1) -! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN -! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) -! ENDIF - if ( temg(1) .lt. tfr ) then -! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = qis(kz) -! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / -! > (qcw(kz) + qci(kz)) - qss(1) = qis(1) - else -! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN -! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) -! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) -! ENDIF + qss(1) = qis(1) end if ! ishail = .false. @@ -11793,7 +13638,12 @@ subroutine nssl_2mom_gs & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - qis(mgs) = pqs(mgs)*tabqis(ltemq) + IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN + qis(mgs) = pqs(mgs)*tabqis(ltemq) + ELSE + ltemq = (tfr - 163.15)/fqsat + 1.5 + qis(mgs) = pqs(mgs)*tabqis(ltemq) + ENDIF qss(mgs) = qvs(mgs) ! es(mgs) = 6.1078e2*tabqvs(ltemq) ! eis(mgs) = 6.1078e2*tabqis(ltemq) @@ -11834,93 +13684,21 @@ subroutine nssl_2mom_gs & - scx(:,:) = 0.0 + ! -! set shape parameters +! set concentrations ! - IF ( imurain == 1 ) THEN - alpha(:,lr) = alphar - ELSEIF ( imurain == 3 ) THEN - alpha(:,lr) = xnu(lr) - ENDIF - - alpha(:,li) = xnu(li) - alpha(:,lc) = xnu(lc) - - IF ( imusnow == 1 ) THEN - alpha(:,ls) = alphas - ELSEIF ( imusnow == 3 ) THEN - alpha(:,ls) = xnu(ls) - ENDIF +! ssmax = 0.0 - DO il = lr,lhab - do mgs = 1,ngscnt - IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) - - - DO ic = lc,lhab - dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) - dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) - ENDDO - ENDDO - end do + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b' -! DO mgs = 1,ngscnt - DO il = lr,lhab - da0lx(:,il) = da0(il) - ENDDO - da0lh(:) = da0(lh) - da0lr(:) = da0(lr) - da1lr(:) = da1(lr) - da0lc(:) = da0(lc) - da1lc(:) = da1(lc) - - - IF ( lzh < 1 .or. lzhl < 1 ) THEN - rzxhlh(:) = rzhl/rz - ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN - rzxhlh(:) = 1. - ENDIF - IF ( lzr > 1 ) THEN - rzxh(:) = 1. - rzxhl(:) = 1. - ELSE - rzxh(:) = rz - rzxhl(:) = rzhl - ENDIF - - IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN - rzxs(:) = rzs - ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN - rzxs(:) = 1. - ENDIF - ! ENDDO - - IF ( lhl .gt. 1 ) THEN - DO mgs = 1,ngscnt - da0lhl(mgs) = da0(lhl) - ENDDO - ENDIF - - ventrx(:) = ventr - ventrxn(:) = ventrn - gf1palp(:) = gamma_sp(1.0 + alphar) - -! -! set concentrations -! -! ssmax = 0.0 - - - if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b' - - if ( ipconc .ge. 1 ) then - do mgs = 1,ngscnt - cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) - IF ( qx(mgs,li) .le. qxmin(li) ) THEN - cx(mgs,li) = 0.0 - ENDIF + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + IF ( qx(mgs,li) .le. qxmin(li) ) THEN + cx(mgs,li) = 0.0 + ENDIF IF ( lcina .gt. 1 ) THEN cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) @@ -12074,6 +13852,124 @@ subroutine nssl_2mom_gs & +! +! 6th moments +! + + IF ( ipconc .ge. 6 ) THEN + zx(:,:) = 0.0 + DO il = lr,lhab + IF ( lz(il) .gt. 1 ) THEN + DO mgs = 1,ngscnt + zx(mgs,il) = Max( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 ) + ENDDO + ENDIF + ENDDO + + ENDIF + + IF ( ipconc .ge. 6 ) THEN + + IF ( lz(lr) .lt. 1 ) THEN + g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + + + DO mgs = 1,ngscnt + IF ( cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + + vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + IF ( lzr < 1 ) THEN + IF ( imurain == 3 ) THEN + zx(mgs,lr) = 3.6476*(rnu+2.0)*cx(mgs,lr)*vr**2/(rnu+1.0) + ELSE ! imurain == 1 + zx(mgs,lr) = 3.6476*g1x(mgs,lr)*cx(mgs,lr)*vr**2 + ENDIF + ENDIF + + ENDIF + ENDDO + ENDIF + + ENDIF + + + scx(:,:) = 0.0 +! +! set shape parameters +! + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set alpha' + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + alpha(:,li) = xnu(li) + alpha(:,lc) = xnu(lc) + + IF ( imusnow == 1 ) THEN + alpha(:,ls) = alphas + ELSEIF ( imusnow == 3 ) THEN + alpha(:,ls) = xnu(ls) + ENDIF + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set dab' + + DO il = lr,lhab + do mgs = 1,ngscnt + IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) + + + DO ic = lc,lhab + dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) + ENDDO + end do + ENDDO + + +! DO mgs = 1,ngscnt + DO il = lr,lhab + da0lx(:,il) = da0(il) + ENDDO + da0lh(:) = da0(lh) + da0lr(:) = da0(lr) + da1lr(:) = da1(lr) + da0lc(:) = da0(lc) + da1lc(:) = da1(lc) + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set rz' + + IF ( lzh < 1 .or. lzhl < 1 ) THEN + rzxhlh(:) = rzhl/rz + ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN + rzxhlh(:) = 1. + ENDIF + IF ( lzr > 1 ) THEN + rzxh(:) = 1. + rzxhl(:) = 1. + ELSE + rzxh(:) = rz + rzxhl(:) = rzhl + ENDIF + + IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN + rzxs(:) = rzs + ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN + rzxs(:) = 1. + ENDIF + ! ENDDO + + IF ( lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + da0lhl(mgs) = da0(lhl) + ENDDO + ENDIF + + ventrx(:) = ventr + ventrxn(:) = ventrn + gf1palp(:) = gamma_sp(1.0 + alphar) ! ! set factors @@ -12112,6 +14008,7 @@ subroutine nssl_2mom_gs & tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + IF ( lf > 1 ) tmp = tmp + qx(mgs,lf) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) @@ -12231,62 +14128,880 @@ subroutine nssl_2mom_gs & ENDIF - IF ( lhl .gt. 1 ) THEN + IF ( lhl .gt. 1 ) THEN + + xdn(mgs,lhl) = xdn0(lhl) + xdntmp(mgs,lhl) = xdn0(lhl) + + IF ( lvol(lhl) .gt. 1 ) THEN + IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + + IF ( mixedphase .and. lhlw > 1 ) THEN + ELSE + dnmx = xdnmx(lhl) + ENDIF + + xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + xdntmp(mgs,lhl) = xdn(mgs,lhl) + + ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + + ENDIF + ENDIF + + ENDIF + + + end do + + IF ( ipconc == 5 .and. imydiagalpha == 2 ) THEN + + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + + DO mgs = 1,ngscnt + !IF ( igs(mgs) == 19 ) write(0,*) 'k,qr,qh,cr,ch = ',kgs(mgs),qx(mgs,lr),cx(mgs,lr),qx(mgs,lh),cx(mgs,lh) + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! + xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) + ! alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) + ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000. + + ! M&M-C 2010: + tmp = 4. + alphar + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + alphar + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = (x/y)**(1./3.)*xdia(mgs,lr,3)*cwchtmp + + alpha(mgs,lr) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.) + ENDIF + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN +! MY 2005: + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) +! alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) + + ! M&M-C 2010: + tmp = 4. + dnu(lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + dnu(lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = (x/y)**(1./3.)*xdia(mgs,lh,3)*cwchtmp + + alpha(mgs,lh) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.) + ! alphan(mgs,lh) = alpha(mgs,lh) + + ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alph,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lh),xdia(mgs,lh,3)*1000. + il = lh + DO ic = lc,lh-1 ! lhab + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + ENDDO + ENDIF +! alpha(:,lr) = 0. ! 10. +! alpha(:,lh) = 0. ! 10. + IF ( lhl > 0 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.) + IF ( xdia(mgs,lhl,3) < 0.008 ) THEN + alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl) + ELSE + alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl) + ENDIF + + il = lhl + DO ic = lc,lh-1 ! lhab + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + ENDDO + + ENDIF + ENDIF + + + + ENDDO + ENDIF + + + IF ( imurain == 3 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 0.0 + alphamlr = -2.0/3.0 + alphasmlr = -2.0/3.0 + ELSE + alphashr = xnu(lr) + alphamlr = xnu(lr) + alphasmlr = xnu(lr) + ENDIF +! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor +! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) + massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor + massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) + ELSEIF ( imurain == 1 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 4.0 + alphamlr = 4.0 + alphasmlr = alphasmlr0 + ELSE + alphashr = alphar + alphamlr = alphar + alphasmlr = alphar + ENDIF +! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor +! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) + massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor + massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) + ENDIF + +! Find shape parameter rain + + g1shr = 1.0 + g1mlr = 1.0 + g1smlr = 1.0 + +! CALL cld_cpu('Z-MOMENT-1') + + IF ( ipconc >= 6 ) THEN + + ! set base g1x in case rain is not 3-moment + IF ( ipconc >= 6 .and. imurain == 3 ) THEN + il = lr + DO mgs = 1,ngscnt +! g1x(mgs,il) = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + g1x(mgs,il) = (alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)) + ENDDO + ENDIF + + IF (lzr > 1 ) THEN + IF ( imurain == 3 ) THEN + g1shr = (alphashr+2.0)/((alphashr+1.0)) + g1mlr = (alphamlr+2.0)/((alphamlr+1.0)) + g1smlr = (alphasmlr+2.0)/((alphasmlr+1.0)) + ELSEIF ( imurain == 1 ) THEN +! g1shr = 36.*(6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ & +! & (pi**2*(3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr)) + g1shr = (6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ & + & ((3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr)) +! g1mlr = 36.*(6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ & +! & (pi**2*(3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr)) + g1mlr = (6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ & + & ((3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr)) + g1smlr = (6.0 + alphasmlr)*(5.0 + alphasmlr)*(4.0 + alphasmlr)/ & + & ((3.0 + alphasmlr)*(2.0 + alphasmlr)*(1.0 + alphasmlr)) + ENDIF + ENDIF + + IF ( lzr > 1 .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM + + +! CALL cld_cpu('Z-MOMENT-1r') + il = lr + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN + + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + + IF ( .false. .and. zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN +! alpha(mgs,lr) = 3. + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + +! check for artificial breakup (rain larger than allowed max size) + IF ( (xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) )) THEN + tmp = cx(mgs,il) + IF ( ioldlimiter >= 2 ) THEN ! MY-style active breakup + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE ! simple cutoff + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + + ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then + ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that + ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates + ! stay consistent with dN/dt and dq/dt. + IF ( alp >= rnumax - 0.01 ) THEN +! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2) +! g1x(mgs,il) = xdn(mgs,il)*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,lr))**2) + g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2) + ELSE + g1x(mgs,il) = g1 + ENDIF + + tmp = alpha(mgs,lr) + 4./3. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + gf1palp(mgs) = y + +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.) + ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + + IF ( imurain == 3 .and. izwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 1.5 + br/6. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) + +! This whole section is imurain == 3, so this branch never runs +! ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN +! +! tmp = alpha(mgs,lr) + 2.5 + br/2. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) +! ventrxn(mgs) = x/y + + + ENDIF + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r') + ENDIF ! } + + ENDIF ! ipconc >= 6 + +! Find shape parameters for graupel and hail + IF ( ipconc .ge. 6 ) THEN + + DO il = lr,lhab + + ! set base values of g1x + IF ( (.not. ( il == lr .and. imurain == 3 )) .and. ( il == lr .or. il == lh .or. il == lhl .or. il == lf ) ) THEN + DO mgs = 1,ngscnt + g1x(mgs,il) = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + ENDDO + ENDIF + + IF ( lz(il) .gt. 1 .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN + + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) ) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + zx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ & + & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax)) + zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSE + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN + +! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv + alp = Max( alphamin, Min( alphamax, alp ) ) + + IF ( newton ) THEN + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = alp + ( galpha(alp) - rdi )/dgalpha(alp) + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + ELSE + DO i = 1,10 +! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + ENDIF + + +! check for artificial breakup (graupel/hail larger than allowed max size) + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSE + xvbarmax = xvmx(il) + ENDIF + + IF ( xv(mgs,il) .gt. xvbarmax .or. (il == lr .and. ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.)) THEN + tmp = cx(mgs,il) + IF( ioldlimiter >= 2 .and. il == lr) THEN ! MY-style drop limiter for rain + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE + xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + IF ( tmp < cx(mgs,il) ) THEN ! artificial breakup has happened, so need to adjust reflectivity and find new shape parameter + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. & + .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + wtest = .false. + IF ( irescalerainopt == 0 ) THEN + wtest = .false. + ELSEIF ( irescalerainopt == 1 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) + ELSEIF ( irescalerainopt == 2 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ELSEIF ( irescalerainopt == 3 ) THEN + wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ENDIF + + IF ( il == lr .and. ( wtest ) ) THEN +! IF ( temcg(mgs) > 0.0 .and. il == lr .and. qx(mgs,lc) > qxmin(lc) ) THEN + ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted + ! drops (i.e., favor preserving Z when alpha tries to go negative) + chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1 + cx(mgs,il) = chw + an(igs(mgs),jy,kgs(mgs),ln(il)) = chw + ELSE + + ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + ENDIF + ENDIF + + + ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then + ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that + ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates + ! stay consistent with dN/dt and dq/dt. +! g1x(mgs,il) = zx(mgs,il)*chw*(pi*xdn(mgs,il))**2/(6.*qr*dn(igs(mgs),jy,kgs(mgs)))**2 +! g1x(mgs,il) = g1 ! zx(mgs,il)*cx(mgs,il)/(qr)**2 + IF ( alp >= alphamax - 0.5 ) THEN +! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2) +! g1x(mgs,il) = (xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,il))**2) + g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2) + ELSE + g1x(mgs,il) = g1 + ENDIF + + ENDIF + +! IF ( ny .eq. 2 ) THEN +! IF ( qr .gt. 1.e-3 ) THEN +! write(0,*) 'alphah at nstep,i,k = ',dtp*(nstep-1),igs(mgs),kgs(mgs),alpha(mgs,il),qr*1000. +! ENDIF +! ENDIF + + + ENDIF ! .true. + + IF ( il == lr ) THEN + +! tmp = alpha(mgs,lr) + 4./3. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +! tmp = alpha(mgs,lr) + 1. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.) +! ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + - xdn(mgs,lhl) = xdn0(lhl) - xdntmp(mgs,lhl) = xdn0(lhl) + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - IF ( lvol(lhl) .gt. 1 ) THEN - IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + gf1palp(mgs) = y - IF ( mixedphase .and. lhlw > 1 ) THEN - ELSE - dnmx = xdnmx(lhl) - ENDIF + IF ( iferwisventr == 2 ) THEN + tmp = alpha(mgs,lr) + 2.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) - vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) - xdntmp(mgs,lhl) = xdn(mgs,lhl) - - ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) - vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) - + ventrxn(mgs) = x/y + ENDIF - ENDIF - - ENDIF + + ENDIF ! il==lr + + + ELSE ! below mass threshold +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) +! z1 = g1*rho0(mgs)**2*(qr)*qr/chw +! z = 1.e18*z1*(6./(pi*1000.))**2 +! z = z1*(6./(pi*1000.))**2 +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF ! ( qx(mgs,il) .gt. qxmin(il) ) + + + +! ENDIF + ENDDO ! mgs +! CALL cld_cpu('Z-DELABK') + +! IF ( il == lr ) THEN +! xnutmp = (alpha(mgs,il) - 2.)/3. +! da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) +! ENDIF + + IF ( .not. ( il == lr .and. imurain == 3 ) ) THEN +! CALL cld_cpu('Z-DELABK') + DO mgs = 1,ngscnt + IF ( qx(mgs,il) > qxmin(il) ) THEN + xnutmp = (alpha(mgs,il) - 2.)/3. + +! IF ( .true. ) THEN + DO ic = lc,lh-1 ! lhab + IF ( il .ne. ic .and. qx(mgs,ic) .gt. qxmin(ic)) THEN + xnuc = xnu(ic) + IF ( ic == lc .and. idiagnosecnu > 0 ) xnuc = alpha(mgs,lc) ! alpha for droplets is actually nu + IF ( il /= lr .and. ic == lr .and. lzr > 1 ) THEN + IF ( imurain == 3 ) THEN + xnuc = alpha(mgs,lr) ! alpha is nu already + ELSE + xnuc = ( alpha(mgs,lr) - 2. )/3. ! convert alpha to nu + ENDIF + ENDIF + ! delabk(ba,bb,nua,nub,mua,mub,k), where a (il) is collector and b (ic) is collected + IF ( .false. ) THEN + dab0lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 0) !dab0(il,ic) + dab1lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 1) !dab1(il,ic) + dab0lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic) + dab1lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic) + ELSE ! use lookup table -- not interpolating yet because table resolution of 0.05 is good enough + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + +! tmp1 = dab0lu(j,i,ic,il) +! tmp2 = dab1lu(j,i,ic,il) +! tmp3 = dab0lu(i,j,il,ic) +! tmp4 = dab1lu(i,j,il,ic) +! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 0) !dab0(il,ic) +! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 1) !dab1(il,ic) +! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic) +! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic) + + IF ( .false. .and. ny <= 2 ) THEN + write(0,*) + write(0,*) 'bb: ', bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic) + write(0,*) 'il,ic = ',il,ic,alpha(mgs,il),i,xnuc,alp,j + write(0,*) 'dab0lh,tmp1 = ',dab0lh(mgs,ic,il),tmp1 + write(0,*) 'dab1lh,tmp2 = ',dab1lh(mgs,ic,il),tmp2 + write(0,*) 'dab0lh,tmp3 = ',dab0lh(mgs,il,ic),tmp3,tmp5 + write(0,*) 'dab1lh,tmp4 = ',dab1lh(mgs,il,ic),tmp4,tmp6 + + ENDIF + + ENDIF + + ENDIF + ENDDO - end do +! ENDIF + + da0lx(mgs,il) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( il .eq. lh ) THEN + da0lh(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( lzr > 1 ) THEN + rzxh(mgs) = 1. + ELSE + rzxh(mgs) = ((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))) + ENDIF + + IF ( lzhl < 1 ) THEN + rzxhlh(mgs) = rzxhl(mgs)/(((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))) + ENDIF + ELSEIF ( il .eq. lhl ) THEN + da0lhl(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( lzr > 1 ) THEN + rzxhl(mgs) = 1. + ELSE + rzxhl(mgs) = ((4.0 + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))) + ENDIF + ELSEIF ( il == lr ) THEN + xnutmp = (alpha(mgs,il) - 2.)/3. + da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + da1lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 1) + ENDIF + + ENDIF ! ( qx(mgs,il) > qxmin(il) ) + ENDDO ! mgs +! CALL cld_cpu('Z-DELABK') + ENDIF ! il /= lr +! CALL cld_cpu('Z-DELABK') + + ENDIF ! lz(il) .gt. 1 + + ENDDO ! il + + ENDIF ! ipconc .ge. 6 - IF ( imurain == 3 ) THEN - IF ( lzr > 1 ) THEN - alphashr = 0.0 - alphamlr = -2.0/3.0 - ELSE - alphashr = xnu(lr) - alphamlr = xnu(lr) - ENDIF -! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor -! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) - massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor - massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) - ELSEIF ( imurain == 1 ) THEN - IF ( lzr > 1 ) THEN - alphashr = 4.0 - alphamlr = 4.0 - ELSE - alphashr = alphar - alphamlr = alphar - ENDIF -! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor -! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) - massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor - massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) - ENDIF - +! CALL cld_cpu('Z-MOMENT-1') ! ! set some values for ice nucleation @@ -12318,7 +15033,7 @@ subroutine nssl_2mom_gs & ! & itype1a,itype2a,temcg,infdo,alpha) - infdo = 0 + infdo = 1 IF ( rimdenvwgt > 0 ) infdo = 1 call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & @@ -12332,9 +15047,9 @@ subroutine nssl_2mom_gs & IF ( lwsm6 .and. ipconc == 0 ) THEN tmp = Max(qxmin(lh), qxmin(ls)) DO mgs = 1,ngscnt - sum = qx(mgs,lh) + qx(mgs,ls) - IF ( sum > tmp ) THEN - vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum + total = qx(mgs,lh) + qx(mgs,ls) + IF ( total > tmp ) THEN + vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/total ELSE vt2ave(mgs) = 0.0 ENDIF @@ -12480,6 +15195,17 @@ subroutine nssl_2mom_gs & + IF ( ipconc >= 6 ) THEN + frac = 0.4d0 + zxmxd(:,:) = 0.0 + DO il = lr,lhab + IF ( lz(il) > 0 .or. ( il == lr ) ) THEN + DO mgs = 1,ngscnt + zxmxd(mgs,il) = frac*zx(mgs,il)*dtpinv + ENDDO + ENDIF + ENDDO + ENDIF @@ -12517,10 +15243,10 @@ subroutine nssl_2mom_gs & vshdgs(mgs,il) = vshd ! base value - IF ( qx(mgs,il) > qxmin(il) ) THEN + IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) THEN ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. - tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 IF ( tmpdiam > sheddiam0 ) THEN vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice @@ -12577,13 +15303,13 @@ subroutine nssl_2mom_gs & ers(mgs) = 0.0 ess(mgs) = 0.0 ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn + ehsfac(mgs) = 1.0 ! factor based on ice saturation ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn ehscnv(mgs) = 0.0 ! ehxs(mgs) = 0.0 ! eiw(mgs) = 0.0 eii(mgs) = 0.0 - ehsclsn(mgs) = 0.0 ehiclsn(mgs) = 0.0 ehlsclsn(mgs) = 0.0 @@ -12678,7 +15404,7 @@ subroutine nssl_2mom_gs & if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then - if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then + if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then ! erm 5/10/2007 test following change: ! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then eiw(mgs) = 0.5 @@ -12802,7 +15528,7 @@ subroutine nssl_2mom_gs & ELSE fac = Abs(ess0) - IF ( .true. .and. ess0 < 0.0 ) THEN + IF ( iessopt == 2 ) THEN ! experimental code ! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN IF ( wvel(mgs) > 2.0 ) THEN ! assume convective cell or downdraft @@ -12810,9 +15536,25 @@ subroutine nssl_2mom_gs & ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values fac = Max(0.0, 2.0 - wvel(mgs))*fac ENDIF + ELSEIF ( iessopt == 3 ) THEN ! factor based on ice supersat + IF ( ssi(mgs) <= 1.0 ) THEN + fac = 0.0 + ehsfac(mgs) = 0.0 + ELSEIF ( ssi(mgs) <= 1.02 ) THEN + fac = fac*(ssi(mgs) - 1.0)/0.02 + ehsfac(mgs) = (ssi(mgs) - 1.0)/0.02 + ENDIF + ELSEIF ( iessopt == 4 ) THEN ! factor based on ice supersat; very roughly based on Hosler et al. 1957 (J. Met.) + IF ( ssi(mgs) <= 1.0 ) THEN + fac = 0.1 + ehsfac(mgs) = 0.1 + ELSEIF ( ssi(mgs) <= 1.005 ) THEN + fac = Max(0.1, fac*(ssi(mgs) - 1.0)/0.005) + ehsfac(mgs) = Max(0.1, (ssi(mgs) - 1.0)/0.005) + ENDIF ENDIF - IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25 + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > esstem1 ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2 ELSEIF ( temcg(mgs) >= esstem2 ) THEN ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) @@ -12923,7 +15665,11 @@ subroutine nssl_2mom_gs & ELSE ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) ENDIF - if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then + + IF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) THEN +! ehsclsn(mgs) = ehs_collsn +! ehs(mgs) = ehscnv(mgs)*ehsfac(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) +! ELSEIF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) then ehsclsn(mgs) = ehs_collsn IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN ehsclsn(mgs) = 0.0 @@ -12933,10 +15679,9 @@ subroutine nssl_2mom_gs & ehsclsn(mgs) = ehs_collsn ENDIF ! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density - ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density; limits scavenging of snow in bright band ! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density ehs(mgs) = Min(ehs(mgs),ehsmax) - IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 end if ENDIF ! @@ -12944,7 +15689,7 @@ subroutine nssl_2mom_gs & ehiclsn(mgs) = ehi_collsn ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 +! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 end if IF ( lis > 1 ) THEN @@ -12952,7 +15697,7 @@ subroutine nssl_2mom_gs & ehisclsn(mgs) = ehi_collsn ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 +! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 end if ENDIF @@ -13089,6 +15834,7 @@ subroutine nssl_2mom_gs & end do + ! ! ! @@ -13162,6 +15908,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qraci(mgs) = 0.0 craci(mgs) = 0.0 + qracs(mgs) = 0.0 IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN IF ( ipconc .ge. 3 ) THEN @@ -13207,8 +15954,9 @@ subroutine nssl_2mom_gs & ENDIF end do ! + IF ( ipconc < 3 ) THEN do mgs = 1,ngscnt - qracs(mgs) = 0.0 + qracs(mgs) = 0.0 IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN IF ( lwsm6 .and. ipconc == 0 ) THEN vt = vt2ave(mgs) @@ -13225,6 +15973,7 @@ subroutine nssl_2mom_gs & & , qsmxd(mgs)) ENDIF end do + ENDIF ! ! @@ -13371,6 +16120,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt qhacw(mgs) = 0.0 + qhacwmlr(mgs) = 0.0 rarx(mgs,lh) = 0.0 vhacw(mgs) = 0.0 vhsoak(mgs) = 0.0 @@ -13437,6 +16187,11 @@ subroutine nssl_2mom_gs & ENDIF + qhacwmlr(mgs) = qhacw(mgs) + IF ( temg(mgs) > tfr .and. iqhacwshr == 0 ) THEN + qhacw(mgs) = 0.0 + ENDIF + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail IF ( temg(mgs) .lt. 273.15) THEN @@ -13466,14 +16221,18 @@ subroutine nssl_2mom_gs & rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) - ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001 tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & & /(temg(mgs)-273.15)) ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + IF ( irimdenopt == 3 ) THEN + rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini + rimdn(mgs,lh) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) + ENDIF ENDIF ELSE @@ -13687,6 +16446,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qhlacw(mgs) = 0.0 + qhlacwmlr(mgs) = 0.0 vhlacw(mgs) = 0.0 vhlsoak(mgs) = 0.0 IF ( lhl > 1 .and. .true.) THEN @@ -13715,10 +16475,15 @@ subroutine nssl_2mom_gs & qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + qhlacwmlr(mgs) = qhlacw(mgs) + IF ( temg(mgs) > tfr .and. iqhlacwshr == 0 ) THEN + qhlacw(mgs) = 0.0 + ENDIF + IF ( lvol(lhl) .gt. 1 ) THEN IF ( temg(mgs) .lt. 273.15) THEN - IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985) + IF ( irimdenopt == 1 ) THEN ! Heymsfeld and Pflaum (1985) rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) & & /(temg(mgs)-273.15))**(rimc2) @@ -13732,13 +16497,17 @@ subroutine nssl_2mom_gs & rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) - ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001 tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & & /(temg(mgs)-273.15) ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + IF ( irimdenopt == 3 ) THEN + rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini + rimdn(mgs,lhl) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) + ENDIF ENDIF ELSE @@ -14053,7 +16822,7 @@ subroutine nssl_2mom_gs & frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) qiacrs(mgs) = (1.-frach)*qiacr(mgs) - ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) + ciacrs(mgs) = (1.-frach)*ciacrf(mgs) ! *rzxh(mgs) ENDIF ENDIF @@ -14083,7 +16852,7 @@ subroutine nssl_2mom_gs & tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass IF ( tmp .lt. essfrac1 ) THEN ec0(mgs) = 1.0 - ELSEIF ( tmp .gt. essfrac2 ) THEN + ELSEIF ( tmp .ge. essfrac2 ) THEN ec0(mgs) = 0.0 ELSE ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1) @@ -14160,7 +16929,21 @@ subroutine nssl_2mom_gs & ec0(mgs) = 2.e9 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN rwrad = 0.5*xdia(mgs,lr,3) - IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + + + ! check median volume diameter + IF ( icracrthresh > 1 ) THEN + IF ( imurain == 1 ) THEN + tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of mm (Ulbrich 1983, JCAM) + ELSE ! imurain == 3, + tmp = (1.678+alpha(mgs,lr))**(1./3.)*xdia(mgs,lr,1) ! units of mm (using method of Ulbrich 1983. See ventillation_stuff.nb) + ENDIF + ELSE + tmp = xdia(mgs,lr,3) - 0.1e-3 + ENDIF + +! IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + IF ( tmp .gt. 1.9e-3 .or. icracr <= 0 ) THEN ec0(mgs) = 0.0 cracr(mgs) = 0.0 ELSE @@ -14242,6 +17025,7 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' chaci(:) = 0.0 + chaci0(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN @@ -14292,6 +17076,7 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' chacs(:) = 0.0 + chacs0(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( ehs(mgs) .gt. 0 ) THEN @@ -14451,7 +17236,7 @@ subroutine nssl_2mom_gs & ! Ziegler (1985) autoconversion ! ! - IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion + IF ( ipconc .ge. 2 ) THEN if (ndebug .gt. 0 ) write(0,*) 'conc 26a' DO mgs = 1,ngscnt @@ -14534,6 +17319,47 @@ subroutine nssl_2mom_gs & IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + IF ( ipconc >= 6 ) THEN + IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN +! vr = rho0(mgs)*qrcnw(mgs)/(1000.*crcnw(mgs)) +! zrcnw(mgs) = 36.*(xnu(lr)+2.0)*crcnw(mgs)*vr**2/((xnu(lr)+1.0)*pi**2) + ! DTD: If rain exists at a grid point already either use the alpha-preserving Z-rate eqn. (dmrauto == 1) + ! or a mass-weighted average of the alpha-preserving Z-rate eqn. and the init. rate eqn. (dmrauto == 2) + ! or the original initiation rate equation (dmrauto == 0). Not sure if this is the correct way to go but seems to work ok. + IF (qx(mgs,lr) .gt. qxmin(lr) .and. ( dmrauto == 1 .or. dmrauto ==2 ) ) THEN + tmp3 = qx(mgs,lr)/cx(mgs,lr) + tmp4 = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) ) + if (imurain == 3) then + vr = rho0(mgs)*qrcnw(mgs)/(1000.) + tmp3 = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + else + tmp3 = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs) + endif + IF ( dmrauto == 1 ) THEN ! Preserve alpha + zrcnw(mgs) = tmp4 + ELSEIF ( dmrauto == 2 ) THEN ! Mass-weighted average + zrcnw(mgs) = (tmp3*qrcnw(mgs)+tmp4*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ENDIF + else ! original formulation + IF ( imurain == 3 ) THEN + vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator + zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + ELSE ! rain in gamma of diameter + IF ( dmropt <= 1 .or. dmropt >= 4 .or. ( qx(mgs,lr) < qxmin(lr) .and. cx(mgs,lr) < cxmin ) ) THEN + zrcnw(mgs) = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs) + ELSE + tmp3 = qx(mgs,lr)/cx(mgs,lr) + zrcnw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) ) + ENDIF +! vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator +! zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + ENDIF + endif +! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + ENDIF + ENDIF ! ipconc >= 6 ! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) ! : THEN ! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), @@ -14744,6 +17570,15 @@ subroutine nssl_2mom_gs & ELSE !{ + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + ! interpolate along x, i.e., ratio; + tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) + tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) + + ! interpolate along alpha; + + zrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv + ENDIF IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN @@ -14753,6 +17588,10 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrz(mgs) qrfrzs(mgs) = qrfrz(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + zrfrzf(mgs) = 0. + ENDIF ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! @@ -14764,6 +17603,10 @@ subroutine nssl_2mom_gs & crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 + IF (ipconc >= 6 .and. lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + zrfrzf(mgs) = 0. + ENDIF ELSE !{ ! recalculate using dhmn for ratio @@ -14803,10 +17646,23 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + ! interpolate along x, i.e., ratio; + tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) + tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) + + ! interpolate along alpha; + + zrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv + zrfrzs(mgs) = zrfrzs(mgs) - zrfrzf(mgs) + zrfrzf(mgs) = (1000./900.)**2*zrfrzf(mgs) + ENDIF ENDIF ! } ELSE crfrzs(mgs) = 0.0 qrfrzs(mgs) = 0.0 + zrfrzs(mgs) = 0.0 ENDIF ! } ENDIF !} @@ -14819,6 +17675,10 @@ subroutine nssl_2mom_gs & crfrz(mgs) = fac*crfrz(mgs) crfrzs(mgs) = fac*crfrzs(mgs) crfrzf(mgs) = fac*crfrzf(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + zrfrz(mgs) = fac*zrfrz(mgs) + zrfrzf(mgs) = fac*zrfrzf(mgs) + ENDIF ENDIF ENDIF !} @@ -15363,8 +18223,16 @@ subroutine nssl_2mom_gs & x = 1. + alpha(mgs,lr) - IF ( lzr > 1 ) THEN ! 3 moment -! + IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! 3 moment + tmp = 1. + alpr ! alpha(mgs,lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lr) + 0.5*bx(lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions ELSE y = ventrxn(mgs) ENDIF @@ -15380,6 +18248,13 @@ subroutine nssl_2mom_gs & & 0.308*fvent(mgs)*y* & & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + rwventz(mgs) = 0.0 + +! rwventz(mgs) = & +! & 0.78*x + & +! & 0.308*fvent(mgs)*y* & +! & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + ELSEIF ( iferwisventr == 2 ) THEN @@ -15392,6 +18267,23 @@ subroutine nssl_2mom_gs & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + IF ( ipconc >= 7 ) THEN + alpr = Min(alpharmax,alpha(mgs,lr) ) + + tmp = alpr + 5.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! rwventz(mgs) = & +! & 0.78*(4. + alpha(mgs,lr))*(3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)) + & + rwventz(mgs) = & + & 0.78*(4. + alpr)*(3. + alpr)*(2. + alpr)*(1. + alpr) + & + & 0.308*fvent(mgs)* & + & Sqrt(ax(lr)*rhovt(mgs))*(y/gf1palp(mgs))*(xdia(mgs,lr,1)**((1.0+br)/2.0)) + + ENDIF + ENDIF ! iferwisventr @@ -15434,6 +18326,9 @@ subroutine nssl_2mom_gs & hwventa = (0.78)*gmoi(igmhwa) hwventb = (0.308)*gmoi(igmhwb) ! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) + hwvent(:) = 0.0 + hwventy(:) = 0.0 + do mgs = 1,ngscnt IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) @@ -15554,6 +18449,8 @@ subroutine nssl_2mom_gs & & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & & / (felf(mgs)) fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) + fmlt1e(mgs) = (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) ) / (felf(mgs)) end do ! ! Vapor Deposition constants @@ -15581,6 +18478,7 @@ subroutine nssl_2mom_gs & qhlmlrlg(:) = 0.0 ENDIF qhfzh(:) = 0.0 + qffzf(:) = 0.0 qhlfzhl(:) = 0.0 qhfzhlg(:) = 0.0 qhlfzhllg(:) = 0.0 @@ -15588,9 +18486,10 @@ subroutine nssl_2mom_gs & vffzf(:) = 0.0 vhlfzhl(:) = 0.0 qsfzs(:) = 0.0 - zsmlr(:) = 0.0 +! zsmlr(:) = 0.0 zhmlr(:) = 0.0 zhmlrr(:) = 0.0 + zsmlrr(:) = 0.0 zhshr(:) = 0.0 zhlmlr(:) = 0.0 zhlshr(:) = 0.0 @@ -15642,7 +18541,7 @@ subroutine nssl_2mom_gs & qhmlr(mgs) = & & meltfac*min( & & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & - & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) & + & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacwmlr(mgs)) & & , 0.0 ) ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results @@ -15674,13 +18573,13 @@ subroutine nssl_2mom_gs & qhlmlr(mgs) = & & meltfac*min( & & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & - & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) & + & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacwmlr(mgs)) & & , 0.0 ) ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results -! #ifdef Z3MOM -! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP ) +! #ifdef 1 +! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP ) ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results @@ -15711,7 +18610,7 @@ subroutine nssl_2mom_gs & chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) ENDIF ! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion - qhmlh(mgs) = 0. + qhmlh(mgs) = 0. ! not used ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding @@ -15788,8 +18687,15 @@ subroutine nssl_2mom_gs & ! ENDIF - IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 + IF ( ipconc >= 6 .and. lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN ! Only compute if rain is 3-moment but graupel is not, otherwise is computed later + tmp = qx(mgs,lh)/cx(mgs,lh) + alp = alpha(mgs,lh) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) + + ENDIF IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN IF ( ihmlt .eq. 1 ) THEN @@ -15895,6 +18801,17 @@ subroutine nssl_2mom_gs & ENDIF !} + IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN + IF ( cx(mgs,lhl) > 0.0 ) THEN + + tmp = qx(mgs,lhl)/cx(mgs,lhl) + alp = alpha(mgs,lhl) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) ) + ENDIF + ENDIF ENDIF ! } ENDIF ! }.not. mixedphase @@ -15932,6 +18849,7 @@ subroutine nssl_2mom_gs & ENDDO ! ! + qhdsv(:) = 0.0 qhldsv(:) = 0.0 do mgs = 1,ngscnt @@ -15941,6 +18859,7 @@ subroutine nssl_2mom_gs & & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac qsdsv(mgs) = & & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac + ! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) ! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN ! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), @@ -16177,20 +19096,41 @@ subroutine nssl_2mom_gs & ! end of qlimit + qhcev(:) = 0.0 + chcev(:) = 0.0 + qhlcev(:) = 0.0 + chlcev(:) = 0.0 + qfcev(:) = 0.0 + do mgs = 1,ngscnt qisbv(mgs) = 0.0 qssbv(mgs) = 0.0 qidpv(mgs) = 0.0 qsdpv(mgs) = 0.0 + qhsbv(mgs) = 0.0 + qscev(mgs) = 0.0 + cscev(mgs) = 0.0 IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & - & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN ! last condition (qr qxmin(lh) ) THEN + IF ( temg(mgs) < tfr .or. .not. qhmlr(mgs) < 0.0 ) THEN + ! no liquid from melting, so evaporation is greater. Thus can calculate sublimation rate qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) - qhdpv(mgs) = Max(qhdsv(mgs), 0.0) + ENDIF + + IF ( .true. .and. qhmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN + ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing) +! qhcev(mgs) = & +! & evapfac*min( & +! & fmlt1e(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1), 0.0 ) + + qhcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* & + & cx(mgs,lh)*xdia(mgs,lh,1)*hwvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) + + qhcev(mgs) = max(qhcev(mgs), -qhmxd(mgs)) + IF ( temg(mgs) > tfr ) qhcev(mgs) = Min(0.0, qhcev(mgs) ) + + ENDIF + ENDIF qhlsbv(mgs) = 0.0 qhldpv(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) > qxmin(lhl) ) THEN + IF ( temg(mgs) < tfr .or. .not. qhlmlr(mgs) < 0.0 ) THEN qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) qhldpv(mgs) = Max(qhldsv(mgs), 0.0) + ENDIF + IF ( qhlmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN + ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing) + qhlcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* & + & cx(mgs,lhl)*xdia(mgs,lhl,1)*hlvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) + + qhlcev(mgs) = max(qhlcev(mgs), -qhlmxd(mgs)) + IF ( temg(mgs) > tfr ) qhlcev(mgs) = Min(0.0, qhlcev(mgs) ) + + ENDIF + ENDIF ENDIF temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) @@ -16345,6 +19318,10 @@ subroutine nssl_2mom_gs & end if end do + + + + ! ! ! compute dry growth rate of snow, graupel, and hail @@ -16371,7 +19348,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt - IF ( temg(mgs) < tfr ) THEN + IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN ! ! qswet(mgs) = ! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) @@ -16382,31 +19359,39 @@ subroutine nssl_2mom_gs & ! IF ( dnu(lh) .ne. 0. ) THEN ! qhwet(mgs) = qhdry(mgs) ! ELSE + IF ( incwet == 0 ) THEN qhwet(mgs) = & & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) qhwet(mgs) = max( 0.0, qhwet(mgs)) + ELSE + ENDIF + ! ENDIF qhlwet(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN - qhlwet(mgs) = & - & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & - & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) - qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + IF ( incwet == 0 ) THEN + qhlwet(mgs) = & + & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) + qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + + ELSE + ENDIF ! incwet ENDIF ELSE qhwet(mgs) = qhdry(mgs) qhlwet(mgs) = qhldry(mgs) - ENDIF ! ! qhlwet(mgs) = qhldry(mgs) end do + ! ! shedding rate ! @@ -16466,7 +19451,7 @@ subroutine nssl_2mom_gs & qhshr(mgs) = -qhdry(mgs) qhlshr(mgs) = -qhldry(mgs) ELSE ! new and correct - + ! note that the qxacr terms should be zero here, so shedding at T > 0 is all from the droplets qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs) qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs) @@ -16802,7 +19787,93 @@ subroutine nssl_2mom_gs & ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter ENDIF - dg0(mgs) = -1. + IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN + dg0(mgs) = -1. + ELSE + IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 & + .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN +! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) +! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & +! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & + 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dwr = 0.01*(exp(arg) - 1.0) + ELSE + dwr = 1.e30 + ENDIF + d = dwr + IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN + sqrtrhovt = Sqrt( rhovt(mgs) ) + fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + ltemq = (tfr-163.15)/fqsat+1.5 + qvs0 = pqs(mgs)*tabqvs(ltemq) + denomdp = felf(mgs) + fcw(mgs)*temcg(mgs) + denominvdp = 1.d0/(felf(mgs) + fcw(mgs)*temcg(mgs)) + +! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs) + h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) ) + h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs) + h3 = Max(dwehwmin, ehw(mgs))*qx(mgs,lc) + h4 = ehr(mgs)* qx(mgs,lr) + ! iterate to find minimum diameter for wet growth. Start with value of dwr + DO n = 1,10 + d = Max(d, 1.e-4) + dold = d + vth = axx(mgs,lh)*d**bxx(mgs,lh) + x2 = fventh*sqrtrhovt*Sqrt(d*vth) + IF ( x2 > 1.4 ) THEN + ah = 0.78 + 0.308*x2 ! heat ventillation + ELSE + ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + IF ( .false. ) THEN ! this option includes 'am' separate from ah, which makes only small differences. Otherwise equivalent to second option + x1 = fventm*sqrtrhovt*Sqrt(d*vth) + IF ( x1 > 1.4 ) THEN + am = 0.78 + 0.308*x1 ! mass ventillation (Beard and Pruppacher 1971, eq. 8) + ELSE + am = 1.0 + 0.108*x1**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + d = 8.*denominvdp*( am*felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qvs0 - qx(mgs,lv)) - ah*ftka(mgs)*temcg(mgs) )/ & + (dtp* ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs) + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2*denominvdp)) + + ELSE + + ! Based on Farley and Orville (1986), eq. 5-9 but neglecting the Ci*(T0-Ts) term in (8) since we want Ts=T0 + ! Simplified mass rates as dm_w/dt = pi/4*d**2*(Vh - Vc)*rhoair*qc*ehw, etc. + d = 8.*ah*h1/ & + ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2) + + ENDIF + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT + + ENDDO + ENDIF + + dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) + ELSE + IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 ) THEN + dg0(mgs) = dwmax + ELSE + dg0(mgs) = dg0thresh + 0.0001 + ENDIF + ENDIF + + IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & + .and. temg(mgs) .le. tfr-2.0 ) THEN + ! set a secondary condition on to capture large graupel that is riming but not in wet growth + dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 ) + ENDIF + + ENDIF wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) @@ -16837,18 +19908,6 @@ subroutine nssl_2mom_gs & tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) ! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) -! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN -! hdia1 = Max(dh0, xdia(mgs,lh,3) ) -! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & -! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & -! & *exp(-hdia1/xdia(mgs,lh,1)) & -! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & -! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) - -! ENDIF - -! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) -! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) IF ( ipconc .ge. 5 ) THEN !{ @@ -16858,8 +19917,6 @@ subroutine nssl_2mom_gs & chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter -! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) -! chlcnh(mgs) = Min( chlcnh(mgs), r ) chlcnh(mgs) = Max( chlcnhhl(mgs), r ) ENDIF !} @@ -16874,12 +19931,119 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 3 ) THEN !{ + IF ( wtest .and. & + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN + ! convert number, mass, and reflectivity for d > dw + IF ( ipconc == 5 ) THEN + ! dg0(mgs) = Min( dg0(mgs), hldia1 ) + !dg0(mgs) = hldia1 + ENDIF + + ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) + + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + IF ( ipconc == 5 ) THEN + ! tmp2 = Min( 0.25, tmp2 ) + ENDIF + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + flim = 1.0 + tmp3 = qxmxd(mgs,lh) + IF (qxd1 > tmp3 ) THEN +! flim = tmp3/(qxd1) +! qhlcnh(mgs) = flim*qhlcnh(mgs) + ENDIF + + + + IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + IF ( ipconc == 5 ) THEN + ! tmp = Min( 0.2, tmp ) + ENDIF + cxd1 = flim*cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN + tmp = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs) + IF ( tmp < xmas(mgs,lhl) ) THEN + ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average + dh0 = (( qxd1*tmp**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average + chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 ) + ELSE +! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size + ENDIF + ENDIF + + + ! reflectivity + IF ( ipconc >= 6 .and. lzh > 1 .and. lzhl > 1 ) THEN + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + zxd1 = flim*zx(mgs,lh)*(tmp3) + zhlcnh(mgs) = dtpinv*zxd1 + ELSE + zxd1 = 0 + ENDIF + + ELSE + qhlcnh(mgs) = 0.0 + ENDIF + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDIF !} ENDDO ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion +! +! Staka and Mansell (2005) type conversion +! +! hldia1 is set in micro_module and namelist +! IF ( .true. ) THEN + + ! convert number, mass, and reflectivity for d > hldia1, + ! regardless of wet growth status, but as long as riming > 0 + DO mgs = 1,ngscnt + IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN + ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + cxd1 = cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + + ! reflectivity + IF ( lzh > 1 .and. lzhl > 1 ) THEN + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + zxd1 = zx(mgs,lh)*(tmp3) + zhlcnh(mgs) = dtpinv*zxd1 + ELSE + zxd1 = 0 + ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDDO +! ENDIF ELSEIF ( ihlcnh == 0 ) THEN do mgs = 1,ngscnt @@ -17115,6 +20279,10 @@ subroutine nssl_2mom_gs & ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) +! IF ( lzh .gt. 1 ) THEN +! zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * & +! ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) +! ENDIF vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) @@ -17154,7 +20322,13 @@ subroutine nssl_2mom_gs & IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN ! qrcev(mgs) = -qrmxd(mgs) ! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) - crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + IF ( icrcev == 1 ) THEN + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + ELSEIF ( icrcev == 2 ) THEN + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)*vtxbar(mgs,lr,2)/vtxbar(mgs,lr,1) + ELSE + crcev(mgs) = 0.0 + ENDIF ELSE crcev(mgs) = 0.0 ENDIF @@ -17166,12 +20340,6 @@ subroutine nssl_2mom_gs & ! ! evaporation/condensation of wet graupel and snow ! - qscev(:) = 0.0 - cscev(:) = 0.0 - qhcev(:) = 0.0 - chcev(:) = 0.0 - qhlcev(:) = 0.0 - chlcev(:) = 0.0 IF ( lhwlg > 1 ) THEN qhcevlg(:) = 0.0 chcevlg(:) = 0.0 @@ -17181,6 +20349,7 @@ subroutine nssl_2mom_gs & chlcevlg(:) = 0.0 ENDIF + ! ! ! @@ -18128,6 +21297,14 @@ subroutine nssl_2mom_gs & pqlwlghld(:) = 0.0 pqlwhli(:) = 0.0 pqlwhld(:) = 0.0 + IF ( ipconc > 5 ) THEN + pzhwi(:) = 0.0 + pzhwd(:) = 0.0 + pzrwi(:) = 0.0 + pzrwd(:) = 0.0 + pzhli(:) = 0.0 + pzhld(:) = 0.0 + ENDIF ! @@ -18366,7 +21543,8 @@ subroutine nssl_2mom_gs & qrcev(mgs) = frac*qrcev(mgs) qhlacr(mgs) = frac*qhlacr(mgs) vhlacr(mgs) = frac*vhlacr(mgs) -! qhcev(mgs) = frac*qhcev(mgs) + qhcev(mgs) = frac*qhcev(mgs) + qhlcev(mgs) = frac*qhlcev(mgs) IF ( warmonly < 0.5 ) THEN @@ -18412,6 +21590,8 @@ subroutine nssl_2mom_gs & ! STOP ENDIF + + end do IF ( warmonly < 0.5 ) THEN @@ -18440,7 +21620,7 @@ subroutine nssl_2mom_gs & & -qhcns(mgs) & & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included ! > +il5(mgs)*(qssbv(mgs)) & - & + (qssbv(mgs)) & + & + qssbv(mgs) & & + Min(0.0, qscev(mgs)) & & -qsmul(mgs) @@ -18555,53 +21735,634 @@ subroutine nssl_2mom_gs & & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included end do -! -! Hail -! - IF ( lhl .gt. 1 ) THEN +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & + & +qhlacr(mgs)+qhlacw(mgs) & +! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + end do + + ENDIF ! lhl + + ENDIF ! warmonly + +! +! Liquid water on snow and graupel +! + + vhmlr(:) = 0.0 + vhlmlr(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel + +! vhshdr(:) = 0.0 + vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation +! vhsoak(:) = 0.0 + +! vhlshdr(:) = 0.0 + vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlsoak(:) = 0.0 + + ENDIF ! mixedphase + + + +! +! Graupel reflectivity +! + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'graupel reflectivity' + + do mgs = 1,ngscnt + +! zhmlr(mgs) = 0.0 +! zhshr(mgs) = 0.0 +! zhmlrr(mgs) = 0.0 +! zhshrr(mgs) = 0.0 + zhdsv(mgs) = 0.0 +! IF ( lf < 1 ) THEN + IF ( ffrzh > 0.0 ) THEN + ziacr(mgs) = 0.0 + ziacrf(mgs) = 0.0 + ENDIF +! ENDIF + zhcns(mgs) = 0.0 + zhcni(mgs) = 0.0 + zhacs(mgs) = 0.0 + zhaci(mgs) = 0.0 + + ENDDO + + IF ( lzh .gt. 1 ) THEN ! + do mgs = 1,ngscnt + + + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) .gt. 0.0 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + alp = Max( alphamin, alpha(mgs,lh) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + + zhaci(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhaci(mgs) ) + zhacs(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacs(mgs) ) + + IF ( .not. mixedphase .and. ibinhmlr < 1 ) THEN + zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) + ENDIF + + zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) + +! IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 .and. ibinhmlr < 1 ) THEN + IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 ) THEN +! IF ( temg(mgs) > tfr + 2.0 ) THEN +! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) ) +! IF ( zhshrr(mgs) > 0. ) THEN +! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) +! ENDIF +! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? +! zhshrr(mgs) = Max( z1, zhshrr(mgs)) +! ELSE +! zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + + + IF ( temg(mgs) >= tfr ) THEN + ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) ) + ! IF ( zhshrr(mgs) > 0.0 ) THEN + ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) + ! ENDIF + IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + ELSE + z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? + ENDIF + zhshrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? +! zhshrr(mgs) = Max( z1, zhshrr(mgs)) + ELSE + zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + ENDIF + + zhshrr(mgs) = Min( 0.0, zhshrr(mgs) ) + ENDIF + + IF ( zhshr(mgs) > 0.0 ) THEN + write(0,*) 'Problem with zhshr! zhshr,qhshr,chshr = ',zhshr(mgs),qhshr(mgs),chshr(mgs) + write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lh),cx(mgs,lh),zx(mgs,lh) + write(0,*) ( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ), 2.*tmp * qhshr(mgs), - tmp**2 * chshr(mgs) + write(0,*) 'temcg = ',temcg(mgs),'chshr recalc = ',(cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) + + STOP + ENDIF + + +! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) ) + + qtmp = qhdpv(mgs) + qhcev(mgs) + qhsbv(mgs) + ctmp = chdpv(mgs) + chcev(mgs) + chsbv(mgs) + + zhdsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + alp = Max( alphahacx, alpha(mgs,lh) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .true. ) THEN ! { + IF ( qhacr(mgs) .gt. 0.0 ) THEN +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) + +! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) + zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) +! zhacrf(mgs) = g1*zhacr + + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*qhacr(mgs))**2)/(cx(mgs,lh)) + + IF ( z > zx(mgs,lh) ) THEN +! zhacr(mgs) = (z - zx(mgs,lh))*dtpinv + ELSE +! zhacr(mgs) = 0.0 + ENDIF + ENDIF + +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( qhacw(mgs) .gt. 0.0 ) THEN +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) + IF ( z > zx(mgs,lh) ) THEN +! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv + ENDIF + ENDIF + + ELSE ! } { ! this is not used because of the 'true' above + + IF ( qhacw(mgs) .gt. 0.0 .or. qhacr(mgs) .gt. 0.0 ) THEN + z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacr(mgs) + qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + IF ( z > zx(mgs,lh) ) THEN + zhacw(mgs) = (z - zx(mgs,lh))*dtpinv + ENDIF + ENDIF + + ENDIF ! } + + IF ( qhlcnh(mgs) .gt. 0.0 .and. ihlcnh < 2 ) THEN + zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) ) + ENDIF + ENDIF +! qsplinter(mgs) + IF ( ffrzh*qiacrf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) +! alp = 3.0 +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( imurain == 3 ) THEN + ! note that 3.6476 = (6/pi)**2 + ziacr(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.))* & + & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) + ELSE ! imurain == 1 + ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* & + & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) + ENDIF + ziacr(mgs) = Min( ziacr(mgs), zxmxd(mgs,lr) ) +! ziacrf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * ziacr(mgs) + ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs) +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qiacrf(mgs) - qsplinter(mgs)) - tmp**2 * ciacrf(mgs) ) +! ziacrf(mgs) = Min( ziacrf(mgs), z ) + ENDIF + + + + IF ( ffrzh*qrfrzf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) +! alp = 3.0 +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( imurain == 3 ) THEN + zrfrz(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * & + & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) + zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs) + ELSEIF ( imurain == 1 .and. ibiggopt /= 2 ) THEN +! zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * & +! & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrz(mgs) ) + zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * & + & ( 2.*tmp * qrfrz(mgs) - tmp**2 * crfrz(mgs) ) + zrfrzf(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(rhofrz**2) * & + & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) + ENDIF + zrfrz(mgs) = Min( zrfrz(mgs), Max(0.4,qrfrz(mgs)/qx(mgs,lr))*zx(mgs,lr)*dtpinv ) +! zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs) +! zrfrzf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * zrfrz(mgs) +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qrfrzf(mgs)-qsplinter2(mgs)) - tmp**2 * crfrzf(mgs) ) +! zrfrzf(mgs) = Min( zrfrzf(mgs), z ) + ! change this to be alpha=0? + ENDIF + + IF ( lhl > 1 .and. qhcnhl(mgs) .gt. 0.0 ) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) + zhcnhl(mgs) = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) ) + + ENDIF + + IF ( qhcns(mgs) > 0.0 .and. chcns(mgs) > 0.0 .and. cx(mgs,ls) > cxmin .and. vhcns(mgs) > 0 ) THEN + tmp = qx(mgs,ls)/cx(mgs,ls) + r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles + IF ( imusnow == 3 ) THEN + zhcns(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,ls)+2.)/(r**2*(alpha(mgs,ls)+1.)) * & + & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcns(mgs) ) + ELSE + write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow + STOP + ENDIF + ENDIF + + IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN + tmp = qx(mgs,li)/cx(mgs,li) + r = rho0(mgs)*qhcni(mgs)/vhcni(mgs) ! density of new graupel particles + zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * & + & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcni(mgs) ) + ENDIF + + + pzhwi(mgs) = & + & +ifrzg*ffrzh*(zrfrzf(mgs) & + & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) & +! : + zhcnsh(mgs) + zhcnih(mgs) & + & + zhacw(mgs) & + & + zhacr(mgs) & + & + zhcnhl(mgs) & + & + zhacs(mgs) & + & + zhaci(mgs) & + & + f2h*zhcni(mgs) + f2h*zhcns(mgs) & + & + Max( 0.0, zhdsv(mgs) ) + + pzhwd(mgs) = 0.0 & + & + (1-il5(mgs))*zhmlr(mgs) & + & + zhshr(mgs) & + & + Min( 0.0, zhdsv(mgs) ) & + & - il5(mgs)*zhlcnh(mgs) + + + IF ( igs(mgs) == 44 .and. kgs(mgs) == 23 .or. dtp*( pqhwi(mgs) + pqhwd(mgs) ) > qxmin(lh) ) THEN +! write(0,*) 'i,k,time = ',igs(mgs),kgs(mgs),time_real +! write(0,*) 'pzhwi,d = ',pzhwi(mgs),pzhwd(mgs),dtp*( pzhwi(mgs) + pzhwd(mgs) ),zx(mgs,lh) +! write(0,*) 'pqhwi,d = ',pqhwi(mgs),pqhwd(mgs),dtp*( pqhwi(mgs) + pqhwd(mgs) ),qx(mgs,lh) +! write(0,*) 'pchwi,d = ',pchwi(mgs),pchwd(mgs),dtp*( pchwi(mgs) + pchwd(mgs) ),cx(mgs,lh) + ENDIF + + +! IF ( zhcnhl(mgs) < 0.0 ) THEN +! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs) +! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp +! write(0,*) ( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) ) +! +!! STOP +! ENDIF + end do + + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'end graupel reflectivity' + + ENDIF + +! +! Hail reflectivity +! + + do mgs = 1,ngscnt + + zhldsv(mgs) = 0.0 + zhlacr(mgs) = 0.0 + zhlacw(mgs) = 0.0 + + ENDDO + + IF ( lzhl .gt. 1 .or. ( lzr > 1 .and. lnhl > 1 ) ) THEN ! also run for 2-moment hail for 3-moment rain sources + + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'hail reflectivity' + + do mgs = 1,ngscnt + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) .gt. 0.0 ) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) + alp = Max( alphamin, alpha(mgs,lhl) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .not. mixedphase .and. qhlmlr(mgs) /= 0.0 .and. chlmlr(mgs) /= 0.0 .and. ibinhlmlr < 1 ) THEN + zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) ) + ENDIF + + zhlshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) + IF ( lzr > 1 .and. qhlshr(mgs) /= 0.0 .and. chlshrr(mgs) /= 0.0 ) THEN + IF ( temg(mgs) >= tfr ) THEN + ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshrr(mgs) ) + ! IF ( zhlshrr(mgs) > 0.0 ) THEN + ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) + ! ENDIF + IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) + ELSE + z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr? + ENDIF + zhlshrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr? +! zhlshrr(mgs) = Max( z1, zhlshrr(mgs)) + ELSE + zhlshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) + ENDIF + + zhlshrr(mgs) = Min( 0.0, zhlshrr(mgs) ) + ENDIF + + IF ( zhlshr(mgs) > 0.0 ) THEN + write(0,*) 'Problem with zhlshr! zhlshr,qhlshr,chlshr = ',zhlshr(mgs),qhlshr(mgs),chlshr(mgs) + write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lhl),cx(mgs,lhl),zx(mgs,lhl) + write(0,*) ( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ), 2.*tmp * qhlshr(mgs), - tmp**2 * chlshr(mgs) + write(0,*) 'temcg = ',temcg(mgs),'chlshr recalc = ',(cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + + STOP + ENDIF +! zhlshr(mgs) = Min( 0.0, zhlshr(mgs) ) + +! zhlshr(mgs) = (xdn0(lr)/(xdn(mgs,lhl)))**2*( zx(mgs,lhl) * qhlshr(mgs) ) + + qtmp = qhldpv(mgs) + qhlcev(mgs) + ctmp = chldpv(mgs) + chlcev(mgs) + + zhldsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + alp = Max( alphahacx, alpha(mgs,lhl) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .true. ) THEN ! { + IF ( qhlacr(mgs) .gt. 0.0 ) THEN +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*qhlacr(mgs))**2)/(cx(mgs,lhl)) + zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) ) +! zhlacr(mgs) = Min( zxmxd(mgs,lr), zhlacr(mgs) ) + +! IF ( z > zx(mgs,lhl) ) THEN +! zhlacr(mgs) = (z - zx(mgs,lhl))*dtpinv +! ELSE +! zhlacr(mgs) = 0.0 +! ENDIF + ENDIF + +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + + IF ( qhlacw(mgs) .gt. 0.0 ) THEN + alp = Max( 3.0, alpha(mgs,lhl)+1. ) + g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) +! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) + zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) ) + +! IF ( z > zx(mgs,lhl) ) THEN +! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv +! ENDIF + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + ENDIF + + ELSE ! } .false. { + + IF ( qhlacw(mgs) .gt. 0.0 .or. qhlacr(mgs) .gt. 0.0 ) THEN + z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacr(mgs) + qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) +! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) + IF ( z > zx(mgs,lhl) ) THEN + zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv + ENDIF + ENDIF + + ENDIF ! } + + ENDIF +! qsplinter(mgs) + + IF ( lzhl > 1 ) THEN + pzhli(mgs) = ffrzh*(((1.0-ifrzg)*zrfrzf(mgs) & + & +il5(mgs)*(1.0-ifiacrg)*ziacrf(mgs) )) & + & + il5(mgs)*zhlcnh(mgs) & + & + zhlacw(mgs) & + & + zhlacr(mgs) & +! : + zhlacs(mgs) & + & + Max( 0.0, zhldsv(mgs) ) + + pzhld(mgs) = 0.0 & + & + (1-il5(mgs))*zhlmlr(mgs) & + & + zhlshr(mgs) & + & - zhcnhl(mgs) & + & + Min( 0.0, zhldsv(mgs) ) + + + IF ( .not. ( -1.0 < pzhli(mgs) .and. pzhli(mgs) < 1.e20 ) ) THEN + write(iunit,*) 'Problem with pzhli!' + write(iunit,*) 'zhlcnh,zhlacw,zhlacr,zhldsv = ',zhlcnh(mgs),zhlacw(mgs),zhlacr(mgs),zhldsv(mgs) + ENDIF + + IF ( .not. ( -1.0e20 < pzhld(mgs) .and. pzhld(mgs) < 1. ) ) THEN + write(iunit,*) 'Problem with pzhld!' + write(iunit,*) 'zhlmlr,zhlshr,zhldsv = ',zhlmlr(mgs),zhlshr(mgs),zhldsv(mgs) + ENDIF + + ENDIF ! lzhl > 1 + + end do + + ENDIF + +! +! rain reflectivity +! + if (ndebug .gt. 0 ) write(0,*) 'WARMZIEG: dbg = 11' + + IF ( lzr .gt. 1 ) THEN ! + + DO mgs = 1,ngscnt + + zracw(mgs) = 0.0 + zracr(mgs) = 0.0 + zrcev(mgs) = 0.0 + zrach(mgs) = 0.0 + zrachl(mgs) = 0.0 + zsshr(mgs) = 0.0 + zsshrr(mgs) = 0.0 +! zsmlr(mgs) = 0.0 + zsmlrr(mgs) = 0.0 + + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. ( csmlr(mgs) /= 0.0 .or. csshr(mgs) /= 0.0 .or. & + csmlrr(mgs) /= 0.0 .or. csshrr(mgs) /= 0.0) ) THEN !{ + tmp = qx(mgs,ls)/cx(mgs,ls) + g1 = 36.*(xnu(ls)+2.0)/((xnu(ls)+1.0)*pi**2) + IF ( .not. mixedphase ) THEN +! zsmlr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & +! & ( 2.*tmp * qsmlr(mgs) - tmp**2 * csmlr(mgs) ) + + IF ( csmlrr(mgs) /= 0.0 ) THEN + z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsmlr(mgs)**2/ csmlrr(mgs) ) + zsmlrr(mgs) = z1 + ENDIF + ENDIF + +! zsshr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & +! & ( 2.*tmp * qsshr(mgs) - tmp**2 * csshr(mgs) ) + + IF ( csshrr(mgs) /= 0.0 ) THEN + z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsshr(mgs)**2/ csshrr(mgs) ) + zsshrr(mgs) = z1 + ENDIF + + ENDIF !} + + IF ( .not. mixedphase ) THEN !{ + IF ( zhmlr(mgs) < 0.0 .and. chmlrr(mgs) /= 0.0 .and. ibinhmlr == 0 ) THEN !{ + tmp = qx(mgs,lh)/cx(mgs,lh) +! zhmlrr(mgs) = Min(0.0, (xdn(mgs,lh)/xdn(mgs,lr))**2 * & +! & g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlrr(mgs) ) ) + +! IF ( zhmlrr(mgs) >= 0. ) THEN +! zhmlrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhmlr(mgs) +! ENDIF + IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of graupel + z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) + ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha) + z1 = Min(g1x(mgs,lh),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) + ENDIF + zhmlrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) +! zhmlrr(mgs) = Max( z1, zhmlrr(mgs)) + ENDIF !} + + +! zhshrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhshr(mgs) + + IF ( lhl > 1 .and. qhlmlr(mgs) /= 0 .and. ibinhlmlr == 0) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) +! zhlmlrr(mgs) = Min(0.0, (xdn(mgs,lhl)/xdn(mgs,lr))**2 * & +! & g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlrr(mgs) ) ) + +! IF ( zhlmlrr(mgs) >= 0. ) THEN ! should be negative, if not, then use alternate calculation +! zhlmlrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlmlr(mgs) +! ENDIF + + IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) + ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha) + z1 = Min(g1x(mgs,lhl),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) +! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) + ENDIF + zhlmlrr(mgs) = z1 + +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) +! zhlmlrr(mgs) = Max( z1, zhlmlrr(mgs)) +! zhlmlr(mgs) = +! zhlshrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlshr(mgs) + ENDIF + + ENDIF ! } + + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) .gt. 0.0 ) THEN + + tmp = qx(mgs,lr)/cx(mgs,lr) + g1 = g1x(mgs,lr) ! 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + + + IF ( qracw(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN + zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) ) + ENDIF + + IF ( cracr(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN + zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) ) + ENDIF + + qtmp = qrcev(mgs) + ctmp = crcev(mgs) + +! IF ( .false. .or. iferwisventr == 2 ) THEN +! zrcev(mgs) = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs) ) +! ELSE + zrcev(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + + IF ( iferwisventr == 2 ) THEN + vent1 = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs)) + zrcev(mgs) = Max( zrcev(mgs), vent1 ) + ENDIF +! IF ( ny == 2 .and. igs(mgs) == 20 ) THEN +! write(0,*) 'k,zrcevold,new,maxdep : ',kgs(mgs),zrcev(mgs),vent1,-zxmxd(mgs,lr),alpha(mgs,lr),cx(mgs,lr) +! ENDIF + - do mgs = 1,ngscnt - pqhli(mgs) = & - & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & - & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & - & +qhlacr(mgs)+qhlacw(mgs) & -! & +qhlacs(mgs)+qhlaci(mgs) & - & + qhlcnh(mgs) - pqhld(mgs) = & - & qhlshr(mgs) & - & +(1-il5(mgs))*qhlmlr(mgs) & -! > +il5(mgs)*qhlsbv(mgs) & - & + qhlsbv(mgs) & - & -qhlmul1(mgs) - qhcnhl(mgs) +! ENDIF + zrcev(mgs) = Max( zrcev(mgs), -zxmxd(mgs,lr) ) - end do + IF ( qhacr(mgs) > 0.0 ) THEN + zrach(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + zrach(mgs) = Min( zrach(mgs), zxmxd(mgs,lr) ) + + ENDIF - ENDIF ! lhl + IF ( lhl > 1 .and. qhlacr(mgs) > 0.0 ) THEN + zrachl(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhlacr(mgs) - tmp**2 * chlacr(mgs) ) + zrachl(mgs) = Min( zrachl(mgs), zxmxd(mgs,lr) ) + ENDIF - ENDIF ! warmonly -! -! Liquid water on snow and graupel -! + + ENDIF - vhmlr(:) = 0.0 - vhlmlr(:) = 0.0 - vhfzh(:) = 0.0 - vhlfzhl(:) = 0.0 + pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) & + & + Max( 0.,zrcev(mgs) ) & + & - (1-il5(mgs))*zsmlrr(mgs) & + & - zsshrr(mgs) & + & - (1-il5(mgs))*zhmlrr(mgs) & + & - zhshrr(mgs) & + & - (1-il5(mgs))*zhlmlrr(mgs) & + & - zhlshrr(mgs) - IF ( mixedphase ) THEN - ELSE ! set arrays for non-mixedphase graupel - -! vhshdr(:) = 0.0 - vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation -! vhsoak(:) = 0.0 -! vhlshdr(:) = 0.0 - vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation -! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) -! vhlsoak(:) = 0.0 + pzrwd(mgs) = 0.0 & + & + Min(0.,zrcev(mgs) ) & + & - zrach(mgs) & + & - zrachl(mgs) & + & - zrfrz(mgs) & + & - il5(mgs)*(ziacr(mgs) ) - ENDIF ! mixedphase + + IF ( zx(mgs,lr) + dtp*(pzrwi(mgs)+pzrwd(mgs)) <= 0.0 & + .and. qx(mgs,lr) > qxmin(lr) ) THEN + pzrwd(mgs) = -zx(mgs,lr)*dtpinv - pzrwi(mgs) + ENDIF + + ENDDO + + ENDIF @@ -18678,6 +22439,33 @@ subroutine nssl_2mom_gs & ! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) ! ENDIF + IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN +! Calculate change in reflectivity due to density changes + + xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ & + & (vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) ) + + IF ( mixedphase ) THEN + IF ( qxw(mgs,lh) .gt. 0.0 ) THEN + dnmx = xdnmx(lr) + ELSE + dnmx = xdnmx(lh) + ENDIF + ELSE + dnmx = xdnmx(lh) + ENDIF + + xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lh) ) + + drhodt = (xdn_new - xdn(mgs,lh))*dtpinv + + zhwdn(mgs) = -2.*g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh)*6.*pii )**2/(cx(mgs,lh)*xdn(mgs,lh)**3)*drhodt + + pzhwi(mgs) = pzhwi(mgs) + Max(0.0, zhwdn(mgs)) + pzhwd(mgs) = pzhwd(mgs) + Min(0.0, zhwdn(mgs)) + + + ENDIF IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN write(iunit,*) @@ -18760,6 +22548,32 @@ subroutine nssl_2mom_gs & & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & & + vhlshdr(mgs) - vhlsoak(mgs) + IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) ) THEN +! Calculate change in reflectivity due to density changes + + xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ & + & (vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) ) + + IF ( mixedphase ) THEN + IF ( qxw(mgs,lhl) .gt. 0.0 ) THEN + dnmx = xdnmx(lr) + ELSE + dnmx = xdnmx(lhl) + ENDIF + ELSE + dnmx = xdnmx(lhl) + ENDIF + xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lhl) ) + + drhodt = (xdn_new - xdn(mgs,lhl))*dtpinv + + zhldn(mgs) = -2.*g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl)*6.*pii )**2/(cx(mgs,lhl)*xdn(mgs,lhl)**3)*drhodt + + pzhli(mgs) = pzhli(mgs) + Max(0.0, zhldn(mgs)) + pzhld(mgs) = pzhld(mgs) + Min(0.0, zhldn(mgs)) + + + ENDIF ENDDO @@ -18989,7 +22803,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) write(iunit,*) -qhcns(mgs) write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) - write(iunit,*) (qssbv(mgs)) + write(iunit,*) qssbv(mgs) write(iunit,*) Min(0.0, qscev(mgs)) write(iunit,*) -qsmul(mgs) ! @@ -19061,33 +22875,37 @@ subroutine nssl_2mom_gs & IF ( warmonly < 0.5 ) THEN pfrz(mgs) = & & (1-il5(mgs))* & - & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & - & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & + & (qhmlr(mgs)+ & + & qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & & +il5(mgs)*(1-imixedphase)*( & & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & & +qsshr(mgs) & & +qhshr(mgs) & - & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & + & +qhlshr(mgs) & + & +qrfrz(mgs)+qiacr(mgs) & & ) & & +il5(mgs)*(qwfrz(mgs) & & +qwctfz(mgs)+qiihr(mgs) & & +qiacw(mgs)) pmlt(mgs) = & & (1-il5(mgs))* & - & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + & (qhmlr(mgs)+qsmlr(mgs)+ & + & qhlmlr(mgs)) !+qhmlh(mgs)) ! NOTE: psub is sum of sublimation and deposition psub(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & & + qhldpv(mgs) & & + qidpv(mgs) + qisbv(mgs) ) & - & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & + & + qssbv(mgs) + qhsbv(mgs) & + & + qhlsbv(mgs) & & +il5(mgs)*(qiint(mgs)) pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + qfcev(mgs) pevap(mgs) = & - & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) & + + Min(0.0,qfcev(mgs)) ! NOTE: pdep is the deposition part only pdep(mgs) = & & il5(mgs)*( & @@ -19115,7 +22933,7 @@ subroutine nssl_2mom_gs & & + qidpv(mgs) + qisbv(mgs) ) & & +il5(mgs)*(qiint(mgs)) pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs) ELSE pfrz(mgs) = 0.0 psub(mgs) = 0.0 @@ -19143,6 +22961,8 @@ subroutine nssl_2mom_gs & ! ! do mgs = 1,ngscnt + + qwvp(mgs) = qwvp(mgs) + & & dtp*(pqwvi(mgs)+pqwvd(mgs)) qx(mgs,lc) = qx(mgs,lc) + & @@ -19155,6 +22975,7 @@ subroutine nssl_2mom_gs & & dtp*(pqswi(mgs)+pqswd(mgs)) qx(mgs,lh) = qx(mgs,lh) + & & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN qx(mgs,lhl) = qx(mgs,lhl) + & & dtp*(pqhli(mgs)+pqhld(mgs)) @@ -19224,12 +23045,32 @@ subroutine nssl_2mom_gs & + ENDIF + ENDIF + IF ( ipconc .ge. 6 ) THEN + IF ( lzr .gt. 1 ) THEN + zx(mgs,lr) = zx(mgs,lr) + & + & dtp*(pzrwi(mgs)+pzrwd(mgs)) + ENDIF + IF ( lzs .gt. 1 ) THEN + zx(mgs,ls) = zx(mgs,ls) + & + & dtp*(pzswi(mgs)+pzswd(mgs)) + ENDIF + IF ( lzh .gt. 1 ) THEN + zx(mgs,lh) = zx(mgs,lh) + & + & dtp*(pzhwi(mgs)+pzhwd(mgs)) + ENDIF + IF ( lzhl .gt. 1 ) THEN + zx(mgs,lhl) = zx(mgs,lhl) + & + & dtp*(pzhli(mgs)+pzhld(mgs)) +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF ENDIF ENDIF end do end if - IF ( has_wetscav ) THEN DO mgs = 1,ngscnt evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) @@ -19471,41 +23312,9 @@ subroutine nssl_2mom_gs & tqvcon = temg(mgs)-cbw ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) -! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN -! C$PAR CRITICAL SECTION -! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), -! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), -! : ltemq,igs(mgs),jy,kgs(mgs) -! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), -! : ab(igs(mgs),jy,kgs(mgs),lt), -! : t0(igs(mgs),jy,kgs(mgs)) -! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) -! STOP -! C$PAR END CRITICAL SECTION -! END IF + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) qis(mgs) = pqs(mgs)*tabqis(ltemq) -! qss(kz) = qvs(kz) -! if ( temg(kz) .lt. tfr ) then -! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = qis(kz) -! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / -! > (qcw(kz) + qci(kz)) -! qss(kz) = qis(kz) -! end if -! dont get enough condensation with qcw .le./.gt. qxmin(lc) -! if ( temg(mgs) .lt. tfr ) then -! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) -! > qss(mgs) = qvs(mgs) -! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = qis(mgs) -! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / -! > (qx(mgs,lc) + qitmp(mgs)) -! else -! qss(mgs) = qvs(mgs) -! end if qss(mgs) = qvs(mgs) if ( temg(mgs) .lt. tfr ) then if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & @@ -19744,7 +23553,6 @@ subroutine nssl_2mom_gs & - if (ndebug .gt. 0 ) write(0,*) 'gs 11' do mgs = 1,ngscnt @@ -19775,6 +23583,29 @@ subroutine nssl_2mom_gs & ENDIF + + + +! +! 6th moments +! + + IF ( ipconc .ge. 6 ) THEN + DO il = lr,lhab + IF ( lz(il) .gt. 1 ) THEN + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,3) = an(igs(mgs),jy,kgs(mgs),lz(il)) + lfsave(mgs,4) = zx(mgs,il) + ENDIF + + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + & + & min( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 ) + zx(mgs,il) = an(igs(mgs),jy,kgs(mgs),lz(il)) + + ENDIF + ENDDO + + ENDIF ! end do ! @@ -19839,7 +23670,455 @@ subroutine nssl_2mom_gs & ENDIF !} ENDDO ! mgs + ELSE ! } { is three-moment, so have to adjust Z if size is too large + IF ( il == lr .and. imurain == 3 ) THEN ! { { RAIN + +! rdmx = +! rdmn = + + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN + IF ( zx(mgs,lr) <= zxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + qx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) + ELSEIF ( cx(mgs,lr) <= cxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + +! check for artificial breakup (rain larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter == 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) ) THEN + tmp = cx(mgs,il) +! write(0,*) 'MY limiter: xv: ',xv(mgs,il), xv(mgs,il)/(xvmx(il)/8.) +! STOP + IF ( ioldlimiter == 2 ) THEN ! MY-style active breakup + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE ! simple cutoff + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + + + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + + + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r') + + + ELSEIF ( il == lh .or. il == lhl .or. il == lf .or. (il == lr .and. imurain == 1 )) THEN ! } { Rain, GRAUPEL OR HAIL + + + + DO mgs = 1,ngscnt + + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,5) = an(igs(mgs),jy,kgs(mgs),ln(il)) + lfsave(mgs,6) = cx(mgs,il) + ENDIF + + IF ( il == lhl .and. lnhlf > 1 ) THEN + IF ( cx(mgs,lhl) > cxmin ) THEN + frac = chxf(mgs,lhl)/cx(mgs,lhl) + ELSE + frac = 0.0 + ENDIF + ENDIF + + IF ( il == lh .and. lnhf > 1 ) THEN + IF ( cx(mgs,lh) > cxmin ) THEN + frach = chxf(mgs,lh)/cx(mgs,lh) + ELSE + frach = 0.0 + ENDIF + ENDIF + + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! { .or. qx(mgs,il) <= qxmin(il) + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ELSE + IF ( zx(mgs,il) < 0.0 ) THEN ! .and. qx(mgs,il) > 0.05e-3 + zx(mgs,il) = 0.0 + ENDIF + ENDIF !} + + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN !{ + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN !{ +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ & + & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax)) + zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + +! write(0,*) 'GS: moment problem! il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il) + + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + +! write(0,*) 'GS: moment problem! reset il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il) + + ELSE + ! have all valid moments, so find shape parameter + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN !{ + +! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv + DO i = 1,10 +! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + +! check for artificial breakup (graupel/hail larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) ) THEN !{ + tmp = cx(mgs,il) + + + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF !} + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN !{ + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. & + .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + + wtest = .false. + IF ( irescalerainopt == 0 ) THEN + wtest = .false. + ELSEIF ( irescalerainopt == 1 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) + ELSEIF ( irescalerainopt == 2 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ELSEIF ( irescalerainopt == 3 ) THEN + wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ENDIF + + IF ( il == lr .and. ( wtest .or. .not. rescale_low_alphar ) ) THEN + ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted + ! drops (i.e., favor preserving Z when alpha tries to go negative) + chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1 + cx(mgs,il) = chw + an(igs(mgs),jy,kgs(mgs),ln(il)) = chw + ELSE + ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + +! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! z = z1*(6./(pi*xdn(mgs,il)))**2 +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + + ENDIF !} + + + ENDIF !} + + + ENDIF ! !} + + + ENDIF !} + + IF ( lzr > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),1) = Max(alphamin, Min(alphamax, alpha(mgs,lr) )) + ENDIF + IF ( lzh > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),2) = Max(alphamin, Min(alphamax, alpha(mgs,lh) )) + ENDIF + IF ( lzhl > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),3) = Max(alphamin, Min(alphamax, alpha(mgs,lhl) )) + ENDIF + + IF ( il == lhl .and. lnhlf > 1 ) THEN + ! update chxf in case cx has changed + chxf(mgs,lhl) = frac*cx(mgs,lhl) + ENDIF + IF ( il == lh .and. lnhf > 1 ) THEN + ! update chxf in case cx has changed + chxf(mgs,lh) = frach*cx(mgs,lh) + ENDIF + + +! IF ( lf > 0 .and. il == lf .and. kgs(mgs) <= 20 .and. ( cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ) > 200. .or. cx(mgs,lf) > 400. )) THEN +! write(0,*) 'ix,jy, kz, cf = ',igs(mgs)+ixbeg,jy+jybeg,kgs(mgs), an(igs(mgs),jy,kgs(mgs),ln(lf)),lfsave(mgs,5),lfsave(mgs,6) +! write(0,*) 'qold,qxold,zold,zxold = ',lfsave(mgs,1),lfsave(mgs,2),lfsave(mgs,3),lfsave(mgs,4) +! write(0,*) 'cf_new,pcfwi,pcfwd = ',cx(mgs,lf),cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ),pcfwi(mgs) + pcfwd(mgs) +! +! ENDIF + + ENDDO ! mgs + +! CALL cld_cpu('Z-DELABK') + + +! CALL cld_cpu('Z-DELABK') + + + + + ENDIF ! } } + ENDIF ! }} ENDIF ! } diff --git a/physics/mp_nssl.F90 b/physics/MP/NSSL/mp_nssl.F90 similarity index 75% rename from physics/mp_nssl.F90 rename to physics/MP/NSSL/mp_nssl.F90 index 59ca877fa..e79376709 100644 --- a/physics/mp_nssl.F90 +++ b/physics/MP/NSSL/mp_nssl.F90 @@ -26,13 +26,13 @@ module mp_nssl !! \htmlinclude mp_nssl_init.html !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & - mpirank, mpiroot, & - con_g, con_rd, con_cp, con_rv, & - con_t0c, con_cliq, con_csol, con_eps, & - imp_physics, imp_physics_nssl, & - nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_alphar, nssl_ehw0, nssl_ehlw0, & - nssl_ccn_on, nssl_hail_on, nssl_invertccn ) + mpirank, mpiroot, & + con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps, & + imp_physics, imp_physics_nssl, & + nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_alphar, nssl_ehw0, nssl_ehlw0, & + nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment ) use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const @@ -53,13 +53,13 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl - real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0 - logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0 + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment ! Local variables: dimensions used in nssl_init integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k real :: nssl_params(20) - integer :: ihailv + integer :: ihailv,ipc ! Initialize the CCPP error handling variables @@ -104,9 +104,9 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & nssl_params(:) = 0.0 - nssl_params(1) = nssl_cccn - nssl_params(2) = nssl_alphah - nssl_params(3) = nssl_alphahl + ! nssl_params(1) = nssl_cccn ! use direct interface instead + ! nssl_params(2) = nssl_alphah ! use direct interface instead + ! nssl_params(3) = nssl_alphahl ! use direct interface instead nssl_params(4) = 4.e5 ! nssl_cnoh -- not used for 2-moment nssl_params(5) = 4.e4 ! nssl_cnohl-- not used for 2-moment nssl_params(6) = 4.e5 ! nssl_cnor-- not used for 2-moment @@ -114,10 +114,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & nssl_params(8) = 500. ! nssl_rho_qh nssl_params(9) = 800. ! nssl_rho_qhl nssl_params(10) = 100. ! nssl_rho_qs - nssl_params(11) = 0 ! nssl_ipelec_tmp - nssl_params(12) = 11 ! nssl_isaund - nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off - nssl_params(15) = nssl_alphar nssl_qccn = nssl_cccn/1.225 ! if (mpirank==mpiroot) then @@ -129,10 +125,21 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ELSE ihailv = -1 ENDIF + + IF ( nssl_3moment ) THEN + ipc = 8 + ELSE + ipc = 5 + ENDIF ! write(0,*) 'call nssl_2mom_init' - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & - ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=ipc,mixphase=0, & + ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg, & + nssl_alphar=nssl_alphar, & + nssl_alphah=nssl_alphah, & + nssl_alphahl=nssl_alphahl, & + nssl_cccn=nssl_cccn, & + errflg=errflg,myrank=mpirank,mpiroot=mpiroot) ! For restart runs, the init is done here if (restart) then @@ -158,17 +165,18 @@ end subroutine mp_nssl_init !! \htmlinclude mp_nssl_run.html !! subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & -! spechum, cccn, qc, qr, qi, qs, qh, qhl, & - spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & - ccw, crw, cci, csw, chw, chl, vh, vhl, & - tgrs, prslk, prsl, phii, omega, dtp, & - prcp, rain, graupel, ice, snow, sr, & + spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & + ccw, crw, cci, csw, chw, chl, vh, vhl, & + zrw, zhw, zhl, & + tgrs, prslk, prsl, phii, omega, dtp, & + prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, restart, & - re_cloud, re_ice, re_snow, re_rain, & - nleffr, nieffr, nseffr, nreffr, & - imp_physics, convert_dry_rho, & - imp_physics_nssl, nssl_ccn_on, & - nssl_hail_on, nssl_invertccn, ntccn, ntccna, & + re_cloud, re_ice, re_snow, re_rain, & + nleffr, nieffr, nseffr, nreffr, & + imp_physics, convert_dry_rho, & + imp_physics_nssl, nssl_ccn_on, & + nssl_hail_on, nssl_invertccn, nssl_3moment, & + ntccn, ntccna, & errflg, errmsg) use module_mp_nssl_2mom, only: calcnfromq, na @@ -197,6 +205,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & real(kind_phys), intent(inout) :: chl(:,:) !(1:ncol,1:nlev) hail number real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume real(kind_phys), intent(inout) :: vhl(:,:) !(1:ncol,1:nlev) hail volume + real(kind_phys), intent(inout) :: zrw(:,:) !(1:ncol,1:nlev) rain reflectivity + real(kind_phys), intent(inout) :: zhw(:,:) !(1:ncol,1:nlev) graupel reflectivity + real(kind_phys), intent(inout) :: zhl(:,:) !(1:ncol,1:nlev) hail reflectivity ! State variables and timestep information real(kind_phys), intent(inout) :: tgrs (:,:) !(1:ncol,1:nlev) real(kind_phys), intent(in ) :: prsl (:,:) !(1:ncol,1:nlev) @@ -223,7 +234,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & integer, intent(in) :: nleffr, nieffr, nseffr, nreffr integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment integer, intent(in) :: ntccn, ntccna integer, intent(out) :: errflg @@ -256,6 +267,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ! create temporaries for hail in case it does not exist !real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + real(kind_phys) :: zrw_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity) + real(kind_phys) :: zhw_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity) + real(kind_phys) :: zhl_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity) ! Vertical velocity and level width real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1 real(kind_phys) :: dz(1:ncol,1:nlev) !< m @@ -342,10 +356,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ns_mp = csw/(1.0_kind_phys-spechum) nh_mp = chw/(1.0_kind_phys-spechum) vh_mp = vh/(1.0_kind_phys-spechum) + IF ( nssl_3moment ) THEN + zrw_mp = zrw/(1.0_kind_phys-spechum) + zhw_mp = zhw/(1.0_kind_phys-spechum) + ENDIF IF ( nssl_hail_on ) THEN qhl_mp = qhl/(1.0_kind_phys-spechum) nhl_mp = chl/(1.0_kind_phys-spechum) vhl_mp = vhl/(1.0_kind_phys-spechum) + IF ( nssl_3moment ) THEN + zhl_mp = zhl/(1.0_kind_phys-spechum) + ENDIF ENDIF ELSE ! qv_mp = spechum ! /(1.0_kind_phys-spechum) @@ -361,10 +382,18 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ni_mp = cci ns_mp = csw nh_mp = chw + vh_mp = vh + IF ( nssl_3moment ) THEN + zrw_mp = zrw + zhw_mp = zhw + ENDIF IF ( nssl_hail_on ) THEN qhl_mp = qhl ! /(1.0_kind_phys-spechum) nhl_mp = chl vhl_mp = vhl + IF ( nssl_3moment ) THEN + zhl_mp = zhl + ENDIF ENDIF ENDIF @@ -572,110 +601,114 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & IF ( nssl_ccn_on ) THEN - - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - ! TH=th, & - tt=tgrs, & - QV=qv_mp, & - QC=qc_mp, & - QR=qr_mp, & - QI=qi_mp, & - QS=qs_mp, & - QH=qh_mp, & - QHL=qhl_mp, & - CCW=nc_mp, & - CRW=nr_mp, & - CCI=ni_mp, & - CSW=ns_mp, & - CHW=nh_mp, & - CHL=nhl_mp, & - VHW=vh_mp, & - VHL=vhl_mp, & - cn=cn_mp, & -! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use - cna=cna_mp, f_cna=.false. , & - PII=prslk, & - P=prsl, & - W=w, & - DZ=dz, & - DTP=dtptmp, & - DN=rho, & - rainnc=xrain_mp, rainncv=xdelta_rain_mp, & - snownc=xsnow_mp, snowncv=xdelta_snow_mp, & -! icenc=ice_mp, icencv=delta_ice_mp, & - GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & - dbz = refl_10cm, & -! nssl_progn=.false., & - diagflag = diagflag, & - errmsg=errmsg,errflg=errflg, & - re_cloud=re_cloud_mp, & - re_ice=re_ice_mp, & - re_snow=re_snow_mp, & - re_rain=re_rain_mp, & - has_reqc=has_reqc, & ! ala G. Thompson - has_reqi=has_reqi, & ! ala G. Thompson - has_reqs=has_reqs, & ! ala G. Thompson - has_reqr=has_reqr, & + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & + VHL=vhl_mp, & + cn=cn_mp, & + ZRW=zrw_mp, & + ZHW=zhw_mp, & + ZHL=zhl_mp, & +! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use + cna=cna_mp, f_cna=.false. , & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & + GRPLNC=xgraupel_mp, & + GRPLNCV=xdelta_graupel_mp, & + sr=sr, & + dbz = refl_10cm, & + diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + re_rain=re_rain_mp, & + has_reqc=has_reqc, & + has_reqi=has_reqi, & + has_reqs=has_reqs, & + has_reqr=has_reqr, & IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & ) - ELSE - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - ! TH=th, & - tt=tgrs, & - QV=qv_mp, & - QC=qc_mp, & - QR=qr_mp, & - QI=qi_mp, & - QS=qs_mp, & - QH=qh_mp, & - QHL=qhl_mp, & -! CCW=qnc_mp, & - CCW=nc_mp, & - CRW=nr_mp, & - CCI=ni_mp, & - CSW=ns_mp, & - CHW=nh_mp, & - CHL=nhl_mp, & - VHW=vh_mp, & - VHL=vhl_mp, & - ! cn=cccn, & - PII=prslk, & - P=prsl, & - W=w, & - DZ=dz, & - DTP=dtptmp, & - DN=rho, & - rainnc=xrain_mp, rainncv=xdelta_rain_mp, & - snownc=xsnow_mp, snowncv=xdelta_snow_mp, & -! icenc=ice_mp, icencv=delta_ice_mp, & - GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & - dbz = refl_10cm, & -! nssl_progn=.false., & - diagflag = diagflag, & - errmsg=errmsg,errflg=errflg, & - re_cloud=re_cloud_mp, & - re_ice=re_ice_mp, & - re_snow=re_snow_mp, & - re_rain=re_rain_mp, & - has_reqc=has_reqc, & ! ala G. Thompson - has_reqi=has_reqi, & ! ala G. Thompson - has_reqs=has_reqs, & ! ala G. Thompson - has_reqr=has_reqr, & + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & + VHL=vhl_mp, & +! cn=cn_mp, & + ZRW=zrw_mp, & + ZHW=zhw_mp, & + ZHL=zhl_mp, & +! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use +! cna=cna_mp, f_cna=.false. , & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & + GRPLNC=xgraupel_mp, & + GRPLNCV=xdelta_graupel_mp, & + sr=sr, & + dbz = refl_10cm, & + diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + re_rain=re_rain_mp, & + has_reqc=has_reqc, & + has_reqi=has_reqi, & + has_reqs=has_reqs, & + has_reqr=has_reqr, & IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & ) - + ENDIF - - + DO i = 1,ncol delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) ! this is liquid equivalent of all precip delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) ! this is liquid equivalent of graupel @@ -684,7 +717,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ENDDO ENDDO - + ENDIF @@ -750,10 +783,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & csw = ns_mp/(1.0_kind_phys+qv_mp) chw = nh_mp/(1.0_kind_phys+qv_mp) vh = vh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_3moment ) THEN + zrw = zrw_mp/(1.0_kind_phys+qv_mp) + zhw = zhw_mp/(1.0_kind_phys+qv_mp) + ENDIF IF ( nssl_hail_on ) THEN qhl = qhl_mp/(1.0_kind_phys+qv_mp) chl = nhl_mp/(1.0_kind_phys+qv_mp) vhl = vhl_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_3moment ) THEN + zhl = zhl_mp/(1.0_kind_phys+qv_mp) + ENDIF ENDIF ELSE ! spechum = qv_mp ! /(1.0_kind_phys+qv_mp) @@ -770,10 +810,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & csw = ns_mp chw = nh_mp vh = vh_mp + IF ( nssl_3moment ) THEN + zrw = zrw_mp + zhw = zhw_mp + ENDIF IF ( nssl_hail_on ) THEN qhl = qhl_mp ! /(1.0_kind_phys+qv_mp) chl = nhl_mp vhl = vhl_mp + IF ( nssl_3moment ) THEN + zhl = zhl_mp + ENDIF ENDIF ENDIF diff --git a/physics/mp_nssl.meta b/physics/MP/NSSL/mp_nssl.meta similarity index 94% rename from physics/mp_nssl.meta rename to physics/MP/NSSL/mp_nssl.meta index 6bbf92c73..1f2023ea9 100644 --- a/physics/mp_nssl.meta +++ b/physics/MP/NSSL/mp_nssl.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mp_nssl type = scheme - dependencies = machine.F,module_mp_nssl_2mom.F90 + dependencies = ../../hooks/machine.F,module_mp_nssl_2mom.F90 [ccpp-arg-table] name = mp_nssl_init @@ -210,6 +210,13 @@ dimensions = () type = logical intent = in +[nssl_3moment] + standard_name = nssl_3moment + long_name = 3-moment activation flag in NSSL microphysics scheme + units = flag + dimensions = () + type = logical + intent = in ######################################################################## [ccpp-arg-table] name = mp_nssl_run @@ -387,6 +394,30 @@ type = real kind = kind_phys intent = inout +[zrw] + standard_name = reflectivity_of_rain_of_new_state + long_name = rain reflectivity + units = m6 kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[zhw] + standard_name = reflectivity_of_graupel_of_new_state + long_name = graupel reflectivity + units = m6 kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[zhl] + standard_name = reflectivity_of_hail_of_new_state + long_name = hail reflectivity + units = m6 kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [tgrs] standard_name = air_temperature_of_new_state long_name = model layer mean temperature @@ -614,6 +645,13 @@ dimensions = () type = logical intent = in +[nssl_3moment] + standard_name = nssl_3moment + long_name = 3-moment activation flag in NSSL microphysics scheme + units = flag + dimensions = () + type = logical + intent = in [ntccn] standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration diff --git a/physics/module_mp_thompson.F90 b/physics/MP/Thompson/module_mp_thompson.F90 similarity index 98% rename from physics/module_mp_thompson.F90 rename to physics/MP/Thompson/module_mp_thompson.F90 index 4d823d2f4..44e552160 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/MP/Thompson/module_mp_thompson.F90 @@ -993,6 +993,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rainprod, evapprod, & #endif refl_10cm, diagflag, do_radar_ref, & + max_hail_diam_sfc, & vt_dbz_wt, first_time_step, & re_cloud, re_ice, re_snow, & has_reqc, has_reqi, has_reqs, & @@ -1046,7 +1047,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch, n_var_spp REAL, DIMENSION(:,:), INTENT(IN) :: rand_pert REAL, DIMENSION(:), INTENT(IN) :: spp_prt_list, spp_stddev_cutoff - CHARACTER(len=3), DIMENSION(:), INTENT(IN) :: spp_var_list + CHARACTER(len=10), DIMENSION(:), INTENT(IN) :: spp_var_list INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs #if ( WRF_CHEM == 1 ) REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & @@ -1062,6 +1063,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & GRAUPELNC, GRAUPELNCV REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & refl_10cm + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & + max_hail_diam_sfc REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & vt_dbz_wt LOGICAL, INTENT(IN) :: first_time_step @@ -1416,6 +1419,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qcten1(k) = 0. endif initialize_extended_diagnostics enddo + lsml = lsm(i,j) if (is_aerosol_aware .or. merra2_aerosol_aware) then do k = kts, kte nc1d(k) = nc(i,k,j) @@ -1423,7 +1427,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nifa1d(k) = nifa(i,k,j) enddo else - lsml = lsm(i,j) do k = kts, kte if(lsml == 1) then nc1d(k) = Nt_c_l/rho(k) @@ -1509,6 +1512,14 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & enddo endif + if (merra2_aerosol_aware) then + do k = kts, kte + nc(i,k,j) = nc1d(k) + nwfa(i,k,j) = nwfa1d(k) + nifa(i,k,j) = nifa1d(k) + enddo + endif + do k = kts, kte qv(i,k,j) = qv1d(k) qc(i,k,j) = qc1d(k) @@ -1671,6 +1682,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & (nsteps>1 .and. istep==nsteps) .or. & (nsteps==1 .and. ndt==1)) THEN + max_hail_diam_sfc(i,j) = hail_mass_99th_percentile(kts, kte, qg1d, t1d, p1d, qv1d) + !> - Call calc_refl10cm() diagflag_present: IF ( PRESENT (diagflag) ) THEN @@ -2456,17 +2469,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ - do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 - N0_exp = 10.**(zans1) - N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - enddo - + call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) endif !+---+-----------------------------------------------------------------+ @@ -3533,17 +3536,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ - do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 - N0_exp = 10.**(zans1) - N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - enddo - + call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) endif !+---+-----------------------------------------------------------------+ @@ -3581,7 +3574,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ ! DROPLET NUCLEATION if (clap .gt. eps) then if (is_aerosol_aware .or. merra2_aerosol_aware) then - xnc = MAX(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k))) + xnc = MAX(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k), lsml)) else if(lsml == 1) then xnc = Nt_c_l @@ -5358,14 +5351,15 @@ end subroutine table_ccnAct ! TO_DO ITEM: For radiation cooling producing fog, in which case the !.. updraft velocity could easily be negative, we could use the temp !.. and its tendency to diagnose a pretend postive updraft velocity. - real function activ_ncloud(Tt, Ww, NCCN) + real function activ_ncloud(Tt, Ww, NCCN, lsm_in) implicit none REAL, INTENT(IN):: Tt, Ww, NCCN + INTEGER, INTENT(IN):: lsm_in REAL:: n_local, w_local INTEGER:: i, j, k, l, m, n REAL:: A, B, C, D, t, u, x1, x2, y1, y2, nx, wy, fraction - + REAL:: lower_lim_nuc_frac ! ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) ntb_arc ! ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) ntb_arw @@ -5412,6 +5406,14 @@ real function activ_ncloud(Tt, Ww, NCCN) l = 3 m = 2 + if (lsm_in .eq. 1) then ! land + lower_lim_nuc_frac = 0. + else if (lsm_in .eq. 0) then ! water + lower_lim_nuc_frac = 0.15 + else + lower_lim_nuc_frac = 0.15 ! catch-all for anything else + endif + A = tnccn_act(i-1,j-1,k,l,m) B = tnccn_act(i,j-1,k,l,m) C = tnccn_act(i,j,k,l,m) @@ -5426,7 +5428,8 @@ real function activ_ncloud(Tt, Ww, NCCN) ! u = (w_local-ta_Ww(j-1))/(ta_Ww(j)-ta_Ww(j-1)) fraction = (1.0-t)*(1.0-u)*A + t*(1.0-u)*B + t*u*C + (1.0-t)*u*D - + fraction = MAX(fraction, lower_lim_nuc_frac) + ! if (NCCN*fraction .gt. 0.75*Nt_c_max) then ! write(*,*) ' DEBUG-GT ', n_local, w_local, Tt, i, j, k ! endif @@ -6077,16 +6080,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ if (ANY(L_qg .eqv. .true.)) then - do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 - N0_exp = 10.**(zans1) - N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - enddo + call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) endif !+---+-----------------------------------------------------------------+ @@ -6463,6 +6457,88 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,pfsan,dt,R1) END SUBROUTINE semi_lagrange_sedim +!>\ingroup aathompson +!! @brief Calculates graupel size distribution parameters +!! +!! Calculates graupel intercept and slope parameters for +!! for a vertical column +!! +!! @param[in] kts integer start index for vertical column +!! @param[in] kte integer end index for vertical column +!! @param[in] rand1 real random number for stochastic physics +!! @param[in] rg real array, size(kts:kte) for graupel mass concentration [kg m^3] +!! @param[out] ilamg double array, size(kts:kte) for inverse graupel slope parameter [m] +!! @param[out] N0_g double array, size(kts:kte) for graupel intercept paramter [m-4] +subroutine graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) + + implicit none + + integer, intent(in) :: kts, kte + real, intent(in) :: rand1 + real, intent(in) :: rg(:) + double precision, intent(out) :: ilamg(:), N0_g(:) + + integer :: k + real :: ygra1, zans1 + double precision :: N0_exp, lam_exp, lamg + + do k = kte, kts, -1 + ygra1 = alog10(max(1.e-9, rg(k))) + zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 + N0_exp = 10.**(zans1) + N0_exp = max(dble(gonv_min), min(N0_exp, dble(gonv_max))) + lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 + lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg + ilamg(k) = 1./lamg + N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) + enddo + +end subroutine graupel_psd_parameters + +!>\ingroup aathompson +!! @brief Calculates graupel/hail maximum diameter +!! +!! Calculates graupel/hail maximum diameter (currently the 99th percentile of mass distribtuion) +!! for a vertical column +!! +!! @param[in] kts integer start index for vertical column +!! @param[in] kte integer end index for vertical column +!! @param[in] qg real array, size(kts:kte) for graupel mass mixing ratio [kg kg^-1] +!! @param[in] temperature double array, size(kts:kte) temperature [K] +!! @param[in] pressure double array, size(kts:kte) pressure [Pa] +!! @param[in] qv real array, size(kts:kte) water vapor mixing ratio [kg kg^-1] +!! @param[out] max_hail_diam real maximum hail diameter [m] +function hail_mass_99th_percentile(kts, kte, qg, temperature, pressure, qv) result(max_hail_diam) + + implicit none + + integer, intent(in) :: kts, kte + real, intent(in) :: qg(:), temperature(:), pressure(:), qv(:) + real :: max_hail_diam + + integer :: k + real :: rho(kts:kte), rg(kts:kte), max_hail_column(kts:kte) + double precision :: ilamg(kts:kte), N0_g(kts:kte) + real, parameter :: random_number = 0. + + max_hail_column = 0. + rg = 0. + do k = kts, kte + rho(k) = 0.622*pressure(k)/(R*temperature(k)*(max(1.e-10, qv(k))+0.622)) + if (qg(k) .gt. R1) then + rg(k) = qg(k)*rho(k) + else + rg(k) = R1 + endif + enddo + + call graupel_psd_parameters(kts, kte, random_number, rg, ilamg, N0_g) + + where(rg .gt. 1.e-9) max_hail_column = 10.05 * ilamg + max_hail_diam = max_hail_column(kts) + +end function hail_mass_99th_percentile + !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ END MODULE module_mp_thompson diff --git a/physics/module_mp_thompson_make_number_concentrations.F90 b/physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 similarity index 100% rename from physics/module_mp_thompson_make_number_concentrations.F90 rename to physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 diff --git a/physics/mp_thompson.F90 b/physics/MP/Thompson/mp_thompson.F90 similarity index 99% rename from physics/mp_thompson.F90 rename to physics/MP/Thompson/mp_thompson.F90 index 6a95a706c..7b5b83b37 100644 --- a/physics/mp_thompson.F90 +++ b/physics/MP/Thompson/mp_thompson.F90 @@ -329,6 +329,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & first_time_step, istep, nsteps, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, fullradar_diag, & + max_hail_diam_sfc, & do_radar_ref, aerfld, & mpicomm, mpirank, mpiroot, blkno, & ext_diag, diag3d, reset_diag3d, & @@ -387,6 +388,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), intent( out) :: sr(:) ! Radar reflectivity real(kind_phys), intent(inout) :: refl_10cm(:,:) + real(kind_phys), intent(inout) :: max_hail_diam_sfc(:) logical, intent(in ) :: do_radar_ref logical, intent(in) :: sedi_semi integer, intent(in) :: decfl @@ -409,7 +411,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer, intent(in) :: n_var_spp real(kind_phys), intent(in) :: spp_wts_mp(:,:) real(kind_phys), intent(in) :: spp_prt_list(:) - character(len=3), intent(in) :: spp_var_list(:) + character(len=10), intent(in) :: spp_var_list(:) real(kind_phys), intent(in) :: spp_stddev_cutoff(:) logical, intent (in) :: cplchm @@ -698,6 +700,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & refl_10cm=refl_10cm, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + max_hail_diam_sfc=max_hail_diam_sfc, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & aero_ind_fdb=aero_ind_fdb, rand_perturb_on=spp_mp_opt, & kme_stoch=kme_stoch, & @@ -738,6 +741,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & refl_10cm=refl_10cm, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + max_hail_diam_sfc=max_hail_diam_sfc, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & rand_perturb_on=spp_mp_opt, kme_stoch=kme_stoch, & rand_pert=spp_wts_mp, spp_var_list=spp_var_list, & diff --git a/physics/mp_thompson.meta b/physics/MP/Thompson/mp_thompson.meta similarity index 98% rename from physics/mp_thompson.meta rename to physics/MP/Thompson/mp_thompson.meta index 691698281..ffe34bafb 100644 --- a/physics/mp_thompson.meta +++ b/physics/MP/Thompson/mp_thompson.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = mp_thompson type = scheme - dependencies = machine.F,module_mp_radar.F90,module_mp_thompson.F90,module_mp_thompson_make_number_concentrations.F90 + dependencies = ../../hooks/machine.F + dependencies = ../module_mp_radar.F90 + dependencies = module_mp_thompson.F90,module_mp_thompson_make_number_concentrations.F90 ######################################################################## [ccpp-arg-table] @@ -610,6 +612,14 @@ type = real kind = kind_phys intent = out +[max_hail_diam_sfc] + standard_name = max_hail_diameter_sfc + long_name = instantaneous maximum hail diameter at lowest model level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [fullradar_diag] standard_name = do_full_radar_reflectivity long_name = flag for computing full radar reflectivity @@ -725,7 +735,7 @@ units = none dimensions = (number_of_perturbed_spp_schemes) type = character - kind = len=3 + kind = len=10 intent = in [cplchm] standard_name = flag_for_chemistry_coupling diff --git a/physics/mp_thompson_post.F90 b/physics/MP/Thompson/mp_thompson_post.F90 similarity index 100% rename from physics/mp_thompson_post.F90 rename to physics/MP/Thompson/mp_thompson_post.F90 diff --git a/physics/mp_thompson_post.meta b/physics/MP/Thompson/mp_thompson_post.meta similarity index 98% rename from physics/mp_thompson_post.meta rename to physics/MP/Thompson/mp_thompson_post.meta index 82b035e99..43e89b29c 100644 --- a/physics/mp_thompson_post.meta +++ b/physics/MP/Thompson/mp_thompson_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mp_thompson_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/mp_thompson_pre.F90 b/physics/MP/Thompson/mp_thompson_pre.F90 similarity index 100% rename from physics/mp_thompson_pre.F90 rename to physics/MP/Thompson/mp_thompson_pre.F90 diff --git a/physics/mp_thompson_pre.meta b/physics/MP/Thompson/mp_thompson_pre.meta similarity index 97% rename from physics/mp_thompson_pre.meta rename to physics/MP/Thompson/mp_thompson_pre.meta index 12e812bb3..563eb2809 100644 --- a/physics/mp_thompson_pre.meta +++ b/physics/MP/Thompson/mp_thompson_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mp_thompson_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/zhaocarr_gscond.f b/physics/MP/Zhao_Carr/zhaocarr_gscond.f similarity index 100% rename from physics/zhaocarr_gscond.f rename to physics/MP/Zhao_Carr/zhaocarr_gscond.f diff --git a/physics/zhaocarr_gscond.meta b/physics/MP/Zhao_Carr/zhaocarr_gscond.meta similarity index 98% rename from physics/zhaocarr_gscond.meta rename to physics/MP/Zhao_Carr/zhaocarr_gscond.meta index 493397722..ed57ca909 100644 --- a/physics/zhaocarr_gscond.meta +++ b/physics/MP/Zhao_Carr/zhaocarr_gscond.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = zhaocarr_gscond type = scheme - dependencies = funcphys.f90,machine.F,physcons.F90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/zhaocarr_precpd.f b/physics/MP/Zhao_Carr/zhaocarr_precpd.f similarity index 100% rename from physics/zhaocarr_precpd.f rename to physics/MP/Zhao_Carr/zhaocarr_precpd.f diff --git a/physics/zhaocarr_precpd.meta b/physics/MP/Zhao_Carr/zhaocarr_precpd.meta similarity index 98% rename from physics/zhaocarr_precpd.meta rename to physics/MP/Zhao_Carr/zhaocarr_precpd.meta index 67f1a530b..86e6c7d67 100644 --- a/physics/zhaocarr_precpd.meta +++ b/physics/MP/Zhao_Carr/zhaocarr_precpd.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = zhaocarr_precpd type = scheme - dependencies = funcphys.f90,machine.F,physcons.F90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/calpreciptype.f90 b/physics/MP/calpreciptype.f90 similarity index 100% rename from physics/calpreciptype.f90 rename to physics/MP/calpreciptype.f90 diff --git a/physics/module_mp_radar.F90 b/physics/MP/module_mp_radar.F90 similarity index 100% rename from physics/module_mp_radar.F90 rename to physics/MP/module_mp_radar.F90 diff --git a/physics/hedmf.f b/physics/PBL/HEDMF/hedmf.f similarity index 100% rename from physics/hedmf.f rename to physics/PBL/HEDMF/hedmf.f diff --git a/physics/hedmf.meta b/physics/PBL/HEDMF/hedmf.meta similarity index 99% rename from physics/hedmf.meta rename to physics/PBL/HEDMF/hedmf.meta index c2d873065..be0c83741 100644 --- a/physics/hedmf.meta +++ b/physics/PBL/HEDMF/hedmf.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = hedmf type = scheme - dependencies = funcphys.f90,machine.F,mfpbl.f,physcons.F90,tridi.f + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90,../mfpbl.f,../tridi.f ######################################################################## [ccpp-arg-table] diff --git a/physics/module_BL_MYJPBL.F90 b/physics/PBL/MYJ/module_BL_MYJPBL.F90 similarity index 100% rename from physics/module_BL_MYJPBL.F90 rename to physics/PBL/MYJ/module_BL_MYJPBL.F90 diff --git a/physics/myjpbl_wrapper.F90 b/physics/PBL/MYJ/myjpbl_wrapper.F90 similarity index 100% rename from physics/myjpbl_wrapper.F90 rename to physics/PBL/MYJ/myjpbl_wrapper.F90 diff --git a/physics/myjpbl_wrapper.meta b/physics/PBL/MYJ/myjpbl_wrapper.meta similarity index 99% rename from physics/myjpbl_wrapper.meta rename to physics/PBL/MYJ/myjpbl_wrapper.meta index 427088b86..281396eed 100644 --- a/physics/myjpbl_wrapper.meta +++ b/physics/PBL/MYJ/myjpbl_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = myjpbl_wrapper type = scheme - dependencies = module_BL_MYJPBL.F90 + dependencies = ../../hooks/machine.F,module_BL_MYJPBL.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/bl_mynn_common.f90 b/physics/PBL/MYNN_EDMF/bl_mynn_common.f90 similarity index 100% rename from physics/bl_mynn_common.f90 rename to physics/PBL/MYNN_EDMF/bl_mynn_common.f90 diff --git a/physics/module_bl_mynn.F90 b/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 similarity index 86% rename from physics/module_bl_mynn.F90 rename to physics/PBL/MYNN_EDMF/module_bl_mynn.F90 index ec6b5700d..6840f80bf 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 @@ -232,6 +232,18 @@ ! bl_mynn_cloudpdf = 2 (Chab-Becht). ! Removed WRF_CHEM dependencies. ! Many miscellaneous tweaks. +! v4.5.2 / CCPP +! Some code optimization. Removed many conditions from loops. Redesigned the mass- +! flux scheme to use 8 plumes instead of a variable n plumes. This results in +! the removal of the output variable "nudprafts" and adds maxwidth and ztop_plume. +! Revision option bl_mynn_cloudpdf = 2, which now ensures cloud fractions for all +! optically relevant mixing ratios (tip from Greg Thompson). Also, added flexibility +! for tuning near-surface cloud fractions to remove excess fog/low ceilings. +! Now outputs all SGS cloud mixing ratios as grid-mean values, not in-cloud. This +! results in a change in the pre-radiation code to no longer multiply mixing ratios +! by cloud fractions. +! Lots of code cleanup: removal of test code, comments, changing text case, etc. +! Many misc tuning/tweaks. ! ! Many of these changes are now documented in references listed above. !==================================================================== @@ -256,11 +268,11 @@ MODULE module_bl_mynn !=================================================================== ! From here on, these are MYNN-specific parameters: ! The parameters below depend on stability functions of module_sf_mynn. - real(kind_phys), PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & + real(kind_phys), parameter :: cphm_st=5.0, cphm_unst=16.0, & cphh_st=5.0, cphh_unst=16.0 ! Closure constants - real(kind_phys), PARAMETER :: & + real(kind_phys), parameter :: & &pr = 0.74, & &g1 = 0.235, & ! NN2009 = 0.235 &b1 = 24.0, & @@ -275,7 +287,7 @@ MODULE module_bl_mynn &a2 = a1*( g1-c1 )/( g1*pr ), & &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) - real(kind_phys), PARAMETER :: & + real(kind_phys), parameter :: & &cc2 = 1.0-c2, & &cc3 = 1.0-c3, & &e1c = 3.0*a2*b2*cc3, & @@ -286,15 +298,15 @@ MODULE module_bl_mynn ! 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(kind_phys), PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 + real(kind_phys), 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.2 - real(kind_phys), PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 - real(kind_phys), PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq + real(kind_phys), parameter :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + real(kind_phys), parameter :: tliq = 269. !all hydrometeors are liquid when T > tliq ! Constants for cloud PDF (mym_condensation) - real(kind_phys), PARAMETER :: rr2=0.7071068, rrp=0.3989423 + real(kind_phys), parameter :: rr2=0.7071068, rrp=0.3989423 !>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 @@ -304,35 +316,35 @@ MODULE module_bl_mynn !!(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(kind_phys), PARAMETER :: CKmod=1. + real(kind_phys), 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(kind_phys), PARAMETER :: scaleaware=1. + real(kind_phys), parameter :: scaleaware=1. !>Of the following the options, use one OR the other, not both. !>Adding top-down diffusion driven by cloud-top radiative cooling - INTEGER, PARAMETER :: bl_mynn_topdown = 0 + integer, parameter :: bl_mynn_topdown = 0 !>Option to activate downdrafts, from Elynn Wu (0: deactive, 1: active) - INTEGER, PARAMETER :: bl_mynn_edmf_dd = 0 + integer, parameter :: bl_mynn_edmf_dd = 0 !>Option to activate heating due to dissipation of TKE (to activate, set to 1.0) - INTEGER, PARAMETER :: dheat_opt = 1 + integer, parameter :: dheat_opt = 1 !Option to activate environmental subsidence in mass-flux scheme - LOGICAL, PARAMETER :: env_subs = .false. + logical, parameter :: env_subs = .false. !Option to switch flux-profile relationship for surface (from Puhales et al. 2020) !0: use original Dyer-Hicks, 1: use Cheng-Brustaert and Blended COARE - INTEGER, PARAMETER :: bl_mynn_stfunc = 1 + integer, parameter :: bl_mynn_stfunc = 1 !option to print out more stuff for debugging purposes - LOGICAL, PARAMETER :: debug_code = .false. - INTEGER, PARAMETER :: idbg = 23 !specific i-point to write out + logical, parameter :: debug_code = .false. + integer, parameter :: idbg = 23 !specific i-point to write out ! Used in WRF-ARW module_physics_init.F - INTEGER :: mynn_level + integer :: mynn_level CONTAINS @@ -388,7 +400,8 @@ SUBROUTINE mynn_bl_driver( & &edmf_thl,edmf_ent,edmf_qc, & &sub_thl3D,sub_sqv3D, & &det_thl3D,det_sqv3D, & - &nupdraft,maxMF,ktop_plume, & + &maxwidth,maxMF,ztop_plume, & + &ktop_plume, & &spp_pbl,pattern_spp_pbl, & &rthraten, & &FLAG_QC,FLAG_QI,FLAG_QNC, & @@ -401,30 +414,30 @@ SUBROUTINE mynn_bl_driver( & !------------------------------------------------------------------- - INTEGER, INTENT(in) :: initflag + integer, intent(in) :: initflag !INPUT NAMELIST OPTIONS: - LOGICAL, INTENT(in) :: restart,cycling - INTEGER, INTENT(in) :: tke_budget - 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_output - INTEGER, INTENT(in) :: bl_mynn_cloudmix - INTEGER, INTENT(in) :: bl_mynn_mixqt - INTEGER, INTENT(in) :: icloud_bl - real(kind_phys), INTENT(in) :: closure - - LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& + logical, intent(in) :: restart,cycling + integer, intent(in) :: tke_budget + 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_output + integer, intent(in) :: bl_mynn_cloudmix + integer, intent(in) :: bl_mynn_mixqt + integer, intent(in) :: icloud_bl + real(kind_phys), intent(in) :: closure + + logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & FLAG_OZONE,FLAG_QS - LOGICAL, INTENT(IN) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg + logical, intent(in) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg - INTEGER, INTENT(in) :: & + integer, intent(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & &,ITS,ITE,JTS,JTE,KTS,KTE @@ -444,81 +457,82 @@ SUBROUTINE mynn_bl_driver( & ! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs ! on Cheyenne with the GNU compiler. - real(kind_phys), INTENT(in) :: delt - real(kind_phys), DIMENSION(:), INTENT(in) :: dx - real(kind_phys), DIMENSION(:,:), INTENT(in) :: dz, & + real(kind_phys), intent(in) :: delt + real(kind_phys), dimension(:), intent(in) :: dx + real(kind_phys), dimension(:,:), intent(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - real(kind_phys), DIMENSION(:,:), INTENT(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & &sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca - real(kind_phys), DIMENSION(:,:), INTENT(in):: ozone - real(kind_phys), DIMENSION(:), INTENT(in):: ust, & + real(kind_phys), dimension(:,:), intent(in):: ozone + real(kind_phys), dimension(:), intent(in):: ust, & &ch,qsfc,ps,wspd - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & &rublten,rvblten,rthblten,rqvblten,rqcblten, & &rqiblten,rqsblten,rqniblten,rqncblten, & &rqnwfablten,rqnifablten,rqnbcablten - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone - real(kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten + real(kind_phys), dimension(:,:), intent(inout) :: dozone + real(kind_phys), dimension(:,:), intent(in) :: rthraten - real(kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m - real(kind_phys), DIMENSION(:), INTENT(in) :: xland, & + real(kind_phys), dimension(:,:), intent(out) :: exch_h,exch_m + real(kind_phys), dimension(:), intent(in) :: xland, & &ts,znt,hfx,qfx,uoce,voce !These 10 arrays are only allocated when bl_mynn_output > 0 - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D -! real, DIMENSION(IMS:IME,KMS:KME) :: & +! real, dimension(ims:ime,kms:kme) :: & ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - real(kind_phys), DIMENSION(:), INTENT(inout) :: Pblh - real(kind_phys), DIMENSION(:), INTENT(inout) :: rmol + real(kind_phys), dimension(:), intent(inout) :: Pblh + real(kind_phys), dimension(:), intent(inout) :: rmol - real(kind_phys), DIMENSION(IMS:IME) :: psig_bl,psig_shcu + real(kind_phys), dimension(ims:ime) :: psig_bl,psig_shcu - INTEGER,DIMENSION(:),INTENT(INOUT) :: & - &KPBL,nupdraft,ktop_plume + integer,dimension(:),intent(INOUT) :: & + &KPBL,ktop_plume - real(kind_phys), DIMENSION(:), INTENT(out) :: maxmf + real(kind_phys), dimension(:), intent(out) :: & + &maxmf,maxwidth,ztop_plume - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl + real(kind_phys), dimension(:,:), intent(inout) :: el_pbl - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when tke_budget == 0 ! 1D (local) budget arrays are used for passing between subroutines. - real(kind_phys), DIMENSION(kts:kte) :: & + real(kind_phys), dimension(kts:kte) :: & &qwt1,qshear1,qbuoy1,qdiss1,dqke1,diss_heat - real(kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D + real(kind_phys), dimension(:,:), intent(out) :: Sh3D,Sm3D - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & &qc_bl,qi_bl,cldfra_bl - real(kind_phys), DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D, & + real(kind_phys), dimension(kts:kte) :: qc_bl1D,qi_bl1D, & &cldfra_bl1D,qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old ! smoke/chemical arrays - INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel - real(kind_phys), DIMENSION(:,:,:), INTENT(INOUT) :: chem3d - real(kind_phys), DIMENSION(:,:), INTENT(IN) :: vdep - real(kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO + integer, intent(IN ) :: nchem, kdvel, ndvel + real(kind_phys), dimension(:,:,:), intent(INOUT) :: chem3d + real(kind_phys), dimension(:,:), intent(IN) :: vdep + real(kind_phys), dimension(:), intent(IN) :: frp,EMIS_ANT_NO !local - real(kind_phys), DIMENSION(kts:kte ,nchem) :: chem1 - real(kind_phys), DIMENSION(kts:kte+1,nchem) :: s_awchem1 - real(kind_phys), DIMENSION(ndvel) :: vd1 - INTEGER :: ic + real(kind_phys), dimension(kts:kte ,nchem) :: chem1 + real(kind_phys), dimension(kts:kte+1,nchem) :: s_awchem1 + real(kind_phys), dimension(ndvel) :: vd1 + integer :: ic !local vars - INTEGER :: ITF,JTF,KTF, IMD,JMD - INTEGER :: i,j,k,kproblem - real(kind_phys), DIMENSION(KTS:KTE) :: & + integer :: ITF,JTF,KTF, IMD,JMD + integer :: i,j,k,kproblem + real(kind_phys), dimension(kts:kte) :: & &thl,tl,qv1,qc1,qi1,qs1,sqw, & &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, & - &vt, vq, sgm - real(kind_phys), DIMENSION(KTS:KTE) :: & + &vt, vq, sgm, kzero + real(kind_phys), dimension(kts:kte) :: & &thetav,sh,sm,u1,v1,w1,p1, & &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & &sqv,sqi,sqc,sqs, & @@ -527,45 +541,45 @@ SUBROUTINE mynn_bl_driver( & &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1 !mass-flux variables - real(kind_phys), DIMENSION(KTS:KTE) :: & + real(kind_phys), dimension(kts:kte) :: & &dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - real(kind_phys), DIMENSION(KTS:KTE) :: & + real(kind_phys), dimension(kts:kte) :: & &edmf_a1,edmf_w1,edmf_qt1,edmf_thl1, & &edmf_ent1,edmf_qc1 - real(kind_phys), DIMENSION(KTS:KTE) :: & + real(kind_phys), dimension(kts:kte) :: & &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1, & &edmf_ent_dd1,edmf_qc_dd1 - real(kind_phys), DIMENSION(KTS:KTE) :: & + real(kind_phys), dimension(kts:kte) :: & &sub_thl,sub_sqv,sub_u,sub_v, & &det_thl,det_sqv,det_sqc,det_u,det_v - real(kind_phys), DIMENSION(KTS:KTE+1) :: & + real(kind_phys), 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, & &s_awqnbca1 - real(kind_phys), DIMENSION(KTS:KTE+1) :: & + real(kind_phys), dimension(kts:kte+1) :: & &sd_aw1,sd_awthl1,sd_awqt1, & &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 - real(kind_phys), DIMENSION(KTS:KTE+1) :: zw + real(kind_phys), dimension(kts:kte+1) :: zw real(kind_phys) :: cpm,sqcg,flt,fltv,flq,flqv,flqc, & &pmz,phh,exnerg,zet,phi_m, & &afk,abk,ts_decay, qc_bl2, qi_bl2, & - &th_sfc,ztop_plume,wsp + &th_sfc,wsp !top-down diffusion - real(kind_phys), DIMENSION(ITS:ITE) :: maxKHtopdown - real(kind_phys), DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD + real(kind_phys), dimension(ITS:ITE) :: maxKHtopdown + real(kind_phys), dimension(kts:kte) :: KHtopdown,TKEprodTD - LOGICAL :: INITIALIZE_QKE,problem + logical :: INITIALIZE_QKE,problem ! Stochastic fields - INTEGER, INTENT(IN) :: spp_pbl - real(kind_phys), DIMENSION(:,:), INTENT(IN) :: pattern_spp_pbl - real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + integer, intent(IN) :: spp_pbl + real(kind_phys), dimension(:,:), intent(IN) :: pattern_spp_pbl + real(kind_phys), dimension(KTS:KTE) :: rstoch_col ! Substepping TKE - INTEGER :: nsub + integer :: nsub real(kind_phys) :: delt2 @@ -629,9 +643,11 @@ SUBROUTINE mynn_bl_driver( & !edmf_qc_dd(its:ite,kts:kte)=0. ENDIF ktop_plume(its:ite)=0 !int - nupdraft(its:ite)=0 !int + ztop_plume(its:ite)=0. + maxwidth(its:ite)=0. maxmf(its:ite)=0. maxKHtopdown(its:ite)=0. + kzero(kts:kte)=0. ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS !> - Within the MYNN-EDMF, there is a dependecy check for the first time step, @@ -740,7 +756,7 @@ SUBROUTINE mynn_bl_driver( & !keep snow out for now - increases ceiling bias sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k) thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*(sqi(k)+sqs(k)) + & - xlscp/ex1(k)*(sqi(k))!+sqs(k)) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & @@ -987,10 +1003,10 @@ SUBROUTINE mynn_bl_driver( & else zw(k)=zw(k-1)+dz(i,k-1) endif - !keep snow out for now - increases ceiling bias + !keep snow out for now - increases ceiling bias sqw(k)= sqv(k)+sqc(k)+sqi(k)!+sqs(k) thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*(sqi(k)+sqs(k)) + & - xlscp/ex1(k)*(sqi(k))!+sqs(k)) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & @@ -1021,7 +1037,7 @@ SUBROUTINE mynn_bl_driver( & endif s_awchem1 = 0.0 -!> - Call get_pblh() to calculate the hybrid \f$\theta_{vli}-TKE\f$ +!> - Call get_pblh() to calculate the hybrid \f$\theta_{v}-TKE\f$ !! PBL height diagnostic. CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& & Qke1,zw,dz1,xland(i),KPBL(i)) @@ -1147,8 +1163,8 @@ SUBROUTINE mynn_bl_driver( & &FLAG_QNC,FLAG_QNI, & &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & &Psig_shcu(i), & - &nupdraft(i),ktop_plume(i), & - &maxmf(i),ztop_plume, & + &maxwidth(i),ktop_plume(i), & + &maxmf(i),ztop_plume(i), & &spp_pbl,rstoch_col ) endif @@ -1220,9 +1236,9 @@ SUBROUTINE mynn_bl_driver( & call mynn_tendencies(kts,kte,i, & &delt, dz1, rho1, & &u1, v1, th1, tk1, qv1, & - &qc1, qi1, qs1, qnc1, qni1, & + &qc1, qi1, kzero, qnc1, qni1, & !kzero replaces qs1 - not mixing snow &ps(i), p1, ex1, thl, & - &sqv, sqc, sqi, sqs, sqw, & + &sqv, sqc, sqi, kzero, sqw, & !kzero replaces sqs - not mixing snow &qnwfa1, qnifa1, qnbca1, ozone1, & &ust(i),flt,flq,flqv,flqc, & &wspd(i),uoce(i),voce(i), & @@ -1295,27 +1311,27 @@ SUBROUTINE mynn_bl_driver( & &dfm, dfh, dz1, K_m1, K_h1 ) !UPDATE 3D ARRAYS - exch_m(i,:) =k_m1(:) - exch_h(i,:) =k_h1(:) - rublten(i,:) =du1(:) - rvblten(i,:) =dv1(:) - rthblten(i,:)=dth1(:) - rqvblten(i,:)=dqv1(:) + exch_m(i,kts:kte) =k_m1(kts:kte) + exch_h(i,kts:kte) =k_h1(kts:kte) + rublten(i,kts:kte) =du1(kts:kte) + rvblten(i,kts:kte) =dv1(kts:kte) + rthblten(i,kts:kte)=dth1(kts:kte) + rqvblten(i,kts:kte)=dqv1(kts:kte) if (bl_mynn_cloudmix > 0) then - if (flag_qc) rqcblten(i,:)=dqc1(:) - if (flag_qi) rqiblten(i,:)=dqi1(:) - if (flag_qs) rqsblten(i,:)=dqs1(:) + if (flag_qc) rqcblten(i,kts:kte)=dqc1(kts:kte) + if (flag_qi) rqiblten(i,kts:kte)=dqi1(kts:kte) + if (flag_qs) rqsblten(i,kts:kte)=dqs1(kts:kte) else if (flag_qc) rqcblten(i,:)=0. if (flag_qi) rqiblten(i,:)=0. if (flag_qs) rqsblten(i,:)=0. endif if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then - if (flag_qnc) rqncblten(i,:) =dqnc1(:) - if (flag_qni) rqniblten(i,:) =dqni1(:) - if (flag_qnwfa) rqnwfablten(i,:)=dqnwfa1(:) - if (flag_qnifa) rqnifablten(i,:)=dqnifa1(:) - if (flag_qnbca) rqnbcablten(i,:)=dqnbca1(:) + if (flag_qnc) rqncblten(i,kts:kte) =dqnc1(kts:kte) + if (flag_qni) rqniblten(i,kts:kte) =dqni1(kts:kte) + if (flag_qnwfa) rqnwfablten(i,kts:kte)=dqnwfa1(kts:kte) + if (flag_qnifa) rqnifablten(i,kts:kte)=dqnifa1(kts:kte) + if (flag_qnbca) rqnbcablten(i,kts:kte)=dqnbca1(kts:kte) else if (flag_qnc) rqncblten(i,:) =0. if (flag_qni) rqniblten(i,:) =0. @@ -1323,19 +1339,19 @@ SUBROUTINE mynn_bl_driver( & if (flag_qnifa) rqnifablten(i,:)=0. if (flag_qnbca) rqnbcablten(i,:)=0. endif - dozone(i,:)=dozone1(:) + dozone(i,kts:kte)=dozone1(kts:kte) if (icloud_bl > 0) then - qc_bl(i,:) =qc_bl1D(:) - qi_bl(i,:) =qi_bl1D(:) - cldfra_bl(i,:)=cldfra_bl1D(:) + qc_bl(i,kts:kte) =qc_bl1D(kts:kte) + qi_bl(i,kts:kte) =qi_bl1D(kts:kte) + cldfra_bl(i,kts:kte)=cldfra_bl1D(kts:kte) endif - el_pbl(i,:)=el(:) - qke(i,:) =qke1(:) - tsq(i,:) =tsq1(:) - qsq(i,:) =qsq1(:) - cov(i,:) =cov1(:) - sh3d(i,:) =sh(:) - sm3d(i,:) =sm(:) + el_pbl(i,kts:kte)=el(kts:kte) + qke(i,kts:kte) =qke1(kts:kte) + tsq(i,kts:kte) =tsq1(kts:kte) + qsq(i,kts:kte) =qsq1(kts:kte) + cov(i,kts:kte) =cov1(kts:kte) + sh3d(i,kts:kte) =sh(kts:kte) + sm3d(i,kts:kte) =sm(kts:kte) if (tke_budget .eq. 1) then !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) @@ -1363,24 +1379,24 @@ SUBROUTINE mynn_bl_driver( & !update updraft/downdraft properties if (bl_mynn_output > 0) then !research mode == 1 if (bl_mynn_edmf > 0) then - edmf_a(i,:) =edmf_a1(:) - edmf_w(i,:) =edmf_w1(:) - edmf_qt(i,:) =edmf_qt1(:) - edmf_thl(i,:) =edmf_thl1(:) - edmf_ent(i,:) =edmf_ent1(:) - edmf_qc(i,:) =edmf_qc1(:) - sub_thl3D(i,:)=sub_thl(:) - sub_sqv3D(i,:)=sub_sqv(:) - det_thl3D(i,:)=det_thl(:) - det_sqv3D(i,:)=det_sqv(:) + edmf_a(i,kts:kte) =edmf_a1(kts:kte) + edmf_w(i,kts:kte) =edmf_w1(kts:kte) + edmf_qt(i,kts:kte) =edmf_qt1(kts:kte) + edmf_thl(i,kts:kte) =edmf_thl1(kts:kte) + edmf_ent(i,kts:kte) =edmf_ent1(kts:kte) + edmf_qc(i,kts:kte) =edmf_qc1(kts:kte) + sub_thl3D(i,kts:kte)=sub_thl(kts:kte) + sub_sqv3D(i,kts:kte)=sub_sqv(kts:kte) + det_thl3D(i,kts:kte)=det_thl(kts:kte) + det_sqv3D(i,kts:kte)=det_sqv(kts:kte) endif !if (bl_mynn_edmf_dd > 0) THEN - ! edmf_a_dd(i,:) =edmf_a_dd1(:) - ! edmf_w_dd(i,:) =edmf_w_dd1(:) - ! edmf_qt_dd(i,:) =edmf_qt_dd1(:) - ! edmf_thl_dd(i,:)=edmf_thl_dd1(:) - ! edmf_ent_dd(i,:)=edmf_ent_dd1(:) - ! edmf_qc_dd(i,:) =edmf_qc_dd1(:) + ! edmf_a_dd(i,kts:kte) =edmf_a_dd1(kts:kte) + ! edmf_w_dd(i,kts:kte) =edmf_w_dd1(kts:kte) + ! edmf_qt_dd(i,kts:kte) =edmf_qt_dd1(kts:kte) + ! edmf_thl_dd(i,kts:kte)=edmf_thl_dd1(kts:kte) + ! edmf_ent_dd(i,kts:kte)=edmf_ent_dd1(kts:kte) + ! edmf_qc_dd(i,kts:kte) =edmf_qc_dd1(kts:kte) !endif endif @@ -1509,27 +1525,27 @@ SUBROUTINE mym_initialize ( & ! !------------------------------------------------------------------- - integer, INTENT(IN) :: kts,kte - integer, INTENT(IN) :: bl_mynn_mixlength - logical, INTENT(IN) :: INITIALIZE_QKE -! real(kind_phys), INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - real(kind_phys), INTENT(IN) :: rmo, Psig_bl, xland - real(kind_phys), INTENT(IN) :: dx, ust, zi - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz - real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,thl,& + integer, intent(in) :: kts,kte + integer, intent(in) :: bl_mynn_mixlength + logical, intent(in) :: INITIALIZE_QKE +! real(kind_phys), intent(in) :: ust, rmo, pmz, phh, flt, flq + real(kind_phys), intent(in) :: rmo, Psig_bl, xland + real(kind_phys), intent(in) :: dx, ust, zi + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,& &qw,cldfra_bl1D,edmf_w1,edmf_a1 - real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov - real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: el,qke - real(kind_phys), DIMENSION(kts:kte) :: & + real(kind_phys), dimension(kts:kte), intent(out) :: tsq,qsq,cov + real(kind_phys), dimension(kts:kte), intent(inout) :: el,qke + real(kind_phys), dimension(kts:kte) :: & &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv, & &gm,gh,sm,sh,qkw,vt,vq - INTEGER :: k,l,lmax + integer :: k,l,lmax real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1., & &flt=0.,fltv=0.,flq=0.,tmpq - real(kind_phys), DIMENSION(kts:kte) :: theta,thetav - real(kind_phys), DIMENSION(kts:kte) :: rstoch_col - INTEGER ::spp_pbl + real(kind_phys), dimension(kts:kte) :: theta,thetav + real(kind_phys), dimension(kts:kte) :: rstoch_col + integer ::spp_pbl !> - At first ql, vt and vq are set to zero. DO k = kts,kte @@ -1706,17 +1722,17 @@ SUBROUTINE mym_level2 (kts,kte, & ! !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v, & + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte), intent(in) :: u,v, & &thl,qw,ql,vt,vq,thetav - real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: & + real(kind_phys), dimension(kts:kte), intent(out) :: & &dtl,dqw,dtv,gm,gh,sm,sh integer :: k @@ -1844,25 +1860,25 @@ SUBROUTINE mym_length ( & !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz - real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw - real(kind_phys), INTENT(in) :: rmo,flt,fltv,flq,Psig_bl,xland - real(kind_phys), INTENT(IN) :: dx,zi - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: u1,v1, & + integer, intent(in) :: bl_mynn_mixlength + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: rmo,flt,fltv,flq,Psig_bl,xland + real(kind_phys), intent(in) :: dx,zi + real(kind_phys), dimension(kts:kte), intent(in) :: u1,v1, & &qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1 - real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: qkw, el - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dtv + real(kind_phys), dimension(kts:kte), intent(out) :: qkw, el + real(kind_phys), dimension(kts:kte), intent(in) :: dtv real(kind_phys):: elt,vsc - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: theta - real(kind_phys), DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw + real(kind_phys), dimension(kts:kte), intent(in) :: theta + real(kind_phys), dimension(kts:kte) :: qtke,elBLmin,elBLavg,thetaw real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE @@ -1879,22 +1895,22 @@ SUBROUTINE mym_length ( & !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(kind_phys), PARAMETER :: minzi = 300. !< min mixed-layer height - real(kind_phys), PARAMETER :: maxdz = 750. !< max (half) transition layer depth + real(kind_phys), parameter :: minzi = 300. !< min mixed-layer height + real(kind_phys), 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(kind_phys), PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth + real(kind_phys), parameter :: mindz = 300. !< 300 !min (half) transition layer depth !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER - real(kind_phys), PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m) - real(kind_phys), PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1) + real(kind_phys), parameter :: ZSLH = 100. !< Max height correlated to surface conditions (m) + real(kind_phys), parameter :: CSL = 2. !< CSL = constant of proportionality to L O(1) - INTEGER :: i,j,k + integer :: i,j,k real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud, & & wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf, & & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les - real(kind_phys), PARAMETER :: ctau = 1000. !constant for tau_cloud + real(kind_phys), parameter :: ctau = 1000. !constant for tau_cloud ! tv0 = 0.61*tref ! gtr = 9.81/tref @@ -2254,13 +2270,13 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) ! lb2 = the average of the length up and length down !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: k,kts,kte - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - real(kind_phys), INTENT(OUT) :: lb1,lb2 - real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw + integer, intent(in) :: k,kts,kte + real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta + real(kind_phys), intent(out) :: lb1,lb2 + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw !LOCAL VARS - INTEGER :: izz, found + integer :: izz, found real(kind_phys):: dlu,dld real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz @@ -2404,15 +2420,15 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) ! lb2 = the average of the length up and length down !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - real(kind_phys), DIMENSION(kts:kte), INTENT(OUT):: lb1,lb2 - real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw + integer, intent(in) :: kts,kte + real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta + real(kind_phys), dimension(kts:kte), intent(out):: lb1,lb2 + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw !LOCAL VARS - INTEGER :: iz, izz, found - real(kind_phys), DIMENSION(kts:kte) :: dlu,dld - real(kind_phys), PARAMETER :: Lmax=2000. !soft limit + integer :: iz, izz, found + real(kind_phys), dimension(kts:kte) :: dlu,dld + real(kind_phys), parameter :: Lmax=2000. !soft limit real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz !print*,"IN MYNN-BouLac",kts, kte @@ -2618,40 +2634,40 @@ SUBROUTINE mym_turbulence ( & !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength,tke_budget - real(kind_phys), INTENT(IN) :: closure - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz - real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw - real(kind_phys), INTENT(in) :: rmo,flt,fltv,flq, & + integer, intent(in) :: bl_mynn_mixlength,tke_budget + real(kind_phys), intent(in) :: closure + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: rmo,flt,fltv,flq, & &Psig_bl,Psig_shcu,xland,dx,zi - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw, & + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,thetav,qw, & &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, & &TKEprodTD - real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq, & + real(kind_phys), dimension(kts:kte), intent(out) :: dfm,dfh,dfq, & &pdk,pdt,pdq,pdc,tcd,qcd,el - real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: & + real(kind_phys), dimension(kts:kte), intent(inout) :: & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp - real(kind_phys), DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh + real(kind_phys), dimension(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh - INTEGER :: k + integer :: k ! real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq, & &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh real(kind_phys):: cldavg - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: theta + real(kind_phys), dimension(kts:kte), intent(in) :: theta real(kind_phys):: a2fac, duz, ri !JOE-Canuto/Kitamura mod @@ -2664,10 +2680,10 @@ SUBROUTINE mym_turbulence ( & DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col real(kind_phys):: Prnum, shb - real(kind_phys), PARAMETER :: Prlimit = 5.0 + real(kind_phys), parameter :: Prlimit = 5.0 ! ! tv0 = 0.61*tref @@ -3042,7 +3058,7 @@ SUBROUTINE mym_turbulence ( & ! q-variance (pdq), and covariance (pdc) pdk(k) = elq*( sm(k)*gm(k) & & +sh(k)*gh(k)+gamv ) + & - & TKEprodTD(k) + & 0.5*TKEprodTD(k) ! xmchen 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 ) & @@ -3086,9 +3102,9 @@ SUBROUTINE mym_turbulence ( & !qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE !! Buoyncy term takes the TKEprodTD(k) production now - qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggered + qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+0.5*TKEprodTD(k) ! xmchen - !!!Dissipation Term (now it evaluated on mym_predict) + !!!Dissipation Term (now it evaluated in mym_predict) !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE !! >> EOB @@ -3113,8 +3129,6 @@ SUBROUTINE mym_turbulence ( & qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) END DO ! - - 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) @@ -3181,43 +3195,43 @@ SUBROUTINE mym_predict (kts,kte, & & delt, & & dz, & & ust, flt, flq, pmz, phh, & - & el, dfq, rho, & + & el, dfq, rho, & & pdk, pdt, pdq, pdc, & & qke, tsq, qsq, cov, & & s_aw,s_awqke,bl_mynn_edmf_tke, & & qWT1D, qDISS1D,tke_budget) !! TKE budget (Puhales, 2020) !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - real(kind_phys), INTENT(IN) :: closure - INTEGER, INTENT(IN) :: bl_mynn_edmf_tke,tke_budget - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho - real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - real(kind_phys), INTENT(IN) :: flt, flq, pmz, phh - real(kind_phys), INTENT(IN) :: ust, delt - real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov + real(kind_phys), intent(in) :: closure + integer, intent(in) :: bl_mynn_edmf_tke,tke_budget + real(kind_phys), dimension(kts:kte), intent(in) :: dz, dfq, el, rho + real(kind_phys), dimension(kts:kte), intent(inout) :: pdk, pdt, pdq, pdc + real(kind_phys), intent(in) :: flt, flq, pmz, phh + real(kind_phys), intent(in) :: ust, delt + real(kind_phys), dimension(kts:kte), intent(inout) :: qke,tsq, qsq, cov ! WA 8/3/15 - real(kind_phys), DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw + real(kind_phys), dimension(kts:kte+1), intent(inout) :: s_awqke,s_aw !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - real(kind_phys), DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D - real(kind_phys), DIMENSION(kts:kte) :: tke_up,dzinv + real(kind_phys), dimension(kts:kte), intent(out) :: qWT1D, qDISS1D + real(kind_phys), dimension(kts:kte) :: tke_up,dzinv !! >> EOB - INTEGER :: k - real(kind_phys), DIMENSION(kts:kte) :: qkw, bp, rp, df3q + integer :: k + real(kind_phys), dimension(kts:kte) :: qkw, bp, rp, df3q real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff - real(kind_phys), DIMENSION(kts:kte) :: dtz - real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x + real(kind_phys), dimension(kts:kte) :: dtz + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x - real(kind_phys), DIMENSION(kts:kte) :: rhoinv - real(kind_phys), DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz + real(kind_phys), dimension(kts:kte) :: rhoinv + real(kind_phys), dimension(kts:kte+1) :: rhoz,kqdz,kmdz ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) IF (bl_mynn_edmf_tke == 0) THEN @@ -3263,7 +3277,7 @@ SUBROUTINE mym_predict (kts,kte, & kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k)) kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO -!JOE-end conservation mods + !end conservation mods pdk1 = 2.0*ust**3*pmz/( vkz ) phm = 2.0/ust *phh/( vkz ) @@ -3271,8 +3285,8 @@ SUBROUTINE mym_predict (kts,kte, & 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) +! ** pdk(1)+pdk(2) corresponds to pdk1. ** + pdk(kts) = pdk1 - pdk(kts+1) !! pdt(kts) = pdt1 -pdt(kts+1) !! pdq(kts) = pdq1 -pdq(kts+1) @@ -3367,7 +3381,7 @@ SUBROUTINE mym_predict (kts,kte, & ENDDO k=kte qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) & - & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggared + & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggered !! >> EOBvt qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered END IF @@ -3596,39 +3610,43 @@ SUBROUTINE mym_condensation (kts,kte, & !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf + integer, intent(in) :: kts,kte, bl_mynn_cloudpdf #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - real(kind_phys), INTENT(IN) :: HFX1,rmo,xland - real(kind_phys), INTENT(IN) :: dx,pblh1 - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dz - real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw, & + real(kind_phys), intent(in) :: HFX1,rmo,xland + real(kind_phys), intent(in) :: dx,pblh1 + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), dimension(kts:kte), intent(in) :: p,exner,thl,qw, & &qv,qc,qi,qs,tsq,qsq,cov,th - real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm + real(kind_phys), dimension(kts:kte), intent(inout) :: vt,vq,sgm - real(kind_phys), DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH - real(kind_phys), DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & + real(kind_phys), dimension(kts:kte) :: alp,a,bet,b,ql,q1,RH + real(kind_phys), dimension(kts:kte), intent(out) :: qc_bl1D,qi_bl1D, & &cldfra_bl1D DOUBLE PRECISION :: t3sq, r3sq, c3sq real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, & &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, & - &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & - &qmq,qsat_tk,q1_rh,rh_hack - real(kind_phys), PARAMETER :: rhcrit=0.83 !for hom pdf min sigma - INTEGER :: i,j,k + &ls,wt,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & + &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc + real(kind_phys), parameter :: qpct_sfc=0.025 + real(kind_phys), parameter :: qpct_pbl=0.030 + real(kind_phys), parameter :: qpct_trp=0.040 + real(kind_phys), parameter :: rhcrit =0.83 !for cloudpdf = 2 + real(kind_phys), parameter :: rhmax =1.01 !for cloudpdf = 2 + integer :: i,j,k real(kind_phys):: erf !VARIABLES FOR ALTERNATIVE SIGMA real:: dth,dtl,dqw,dzk,els - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: Sh,el + real(kind_phys), dimension(kts:kte), intent(in) :: Sh,el !variables for SGS BL clouds real(kind_phys) :: zagl,damp,PBLH2 @@ -3636,11 +3654,11 @@ SUBROUTINE mym_condensation (kts,kte, & !JAYMES: variables for tropopause-height estimation real(kind_phys) :: theta1, theta2, ht1, ht2 - INTEGER :: k_tropo + integer :: k_tropo ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col real(kind_phys) :: qw_pert ! First, obtain an estimate for the tropopause height (k), using the method employed in the @@ -3794,29 +3812,31 @@ SUBROUTINE mym_condensation (kts,kte, & !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS !but with use of higher-order moments to estimate sigma - PBLH2=MAX(10.,PBLH1) + pblh2=MAX(10._kind_phys,pblh1) zagl = 0. + dzm1 = 0. DO k = kts,kte-1 - zagl = zagl + dz(k) - t = th(k)*exner(k) + zagl = zagl + 0.5*(dz(k) + dzm1) + dzm1 = dz(k) - xl = xl_blend(t) ! obtain latent heat - qsat_tk = qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p - rh(k)=MAX(MIN(1.00,qw(k)/MAX(1.E-10,qsat_tk)),0.001) + t = th(k)*exner(k) + xl = xl_blend(t) ! obtain latent heat + qsat_tk= qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p + rh(k) = MAX(MIN(rhmax, qw(k)/MAX(1.E-10,qsat_tk)),0.001_kind_phys) !dqw/dT: Clausius-Clapeyron - dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) + dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) alp(k) = 1.0/( 1.0+dqsl*xlvcp ) bet(k) = dqsl*exner(k) - rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) + rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) ! CB02, Eqn. 4 - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - b(k) = a(k)*rsl ! CB02 variable "b" + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + b(k) = a(k)*rsl ! CB02 variable "b" !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) + qw_pert= qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) !This form of qmq (the numerator of Q1) no longer uses the a(k) factor qmq = qw_pert - qsat_tk ! saturation deficit/excess; @@ -3826,28 +3846,46 @@ SUBROUTINE mym_condensation (kts,kte, & r3sq = max( qsq(k), 0.0 ) !Calculate sigma using higher-order moments: sgm(k) = SQRT( r3sq ) - !Set limits on sigma relative to saturation water vapor + !Set constraints on sigma relative to saturation water vapor sgm(k) = min( sgm(k), qsat_tk*0.666 ) - sgm(k) = max( sgm(k), qsat_tk*0.035 ) + !sgm(k) = max( sgm(k), qsat_tk*0.035 ) + + !introduce vertical grid spacing dependence on min sgm + wt = max(500. - max(dz(k)-100.,0.0), 0.0_kind_phys)/500. !=1 for dz < 100 m, =0 for dz > 600 m + sgm(k) = sgm(k) + sgm(k)*0.2*(1.0-wt) !inflate sgm for coarse dz + + !allow min sgm to vary with dz and z. + qpct = qpct_pbl*wt + qpct_trp*(1.0-wt) + qpct = min(qpct, max(qpct_sfc, qpct_pbl*zagl/500.) ) + sgm(k) = max( sgm(k), qsat_tk*qpct ) + q1(k) = qmq / sgm(k) ! Q1, the normalized saturation !Add condition for falling/settling into low-RH layers, so at least - !some cloud fraction is applied for all qc and qi. - rh_hack = rh(k) - !ensure adequate RH & q1 when qi is at least 1e-9 - if (qi(k)>1.e-9) then - rh_hack =min(1.0, rhcrit + 0.06*(9.0 + log10(qi(k)))) + !some cloud fraction is applied for all qc, qs, and qi. + rh_hack= rh(k) + !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH) + if (qi(k)>1.e-9 .and. zagl .gt. pblh2) then + rh_hack =min(rhmax, rhcrit + 0.07*(9.0 + log10(qi(k)))) rh(k) =max(rh(k), rh_hack) !add rh-based q1 - q1_rh =-3. + 3.*(rh_hack-rhcrit)/(1.-rhcrit) + q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) q1(k) =max(q1_rh, q1(k) ) endif !ensure adequate RH & q1 when qc is at least 1e-6 if (qc(k)>1.e-6) then - rh_hack =min(1.0, rhcrit + 0.09*(6.0 + log10(qc(k)))) + rh_hack =min(rhmax, rhcrit + 0.09*(6.0 + log10(qc(k)))) + rh(k) =max(rh(k), rh_hack) + !add rh-based q1 + q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) + q1(k) =max(q1_rh, q1(k) ) + endif + !ensure adequate RH & q1 when qs is at least 1e-8 (above the PBLH) + if (qs(k)>1.e-8 .and. zagl .gt. pblh2) then + rh_hack =min(rhmax, rhcrit + 0.07*(8.0 + log10(qs(k)))) rh(k) =max(rh(k), rh_hack) !add rh-based q1 - q1_rh =-3. + 3.*(rh_hack-rhcrit)/(1.-rhcrit) + q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) q1(k) =max(q1_rh, q1(k) ) endif @@ -3864,20 +3902,17 @@ SUBROUTINE mym_condensation (kts,kte, & ! Specify hydrometeors ! JAYMES- this option added 8 May 2015 ! The cloud water formulations are taken from CB02, Eq. 8. - IF (q1k < 0.) THEN !unsaturated -#ifdef SINGLE_PREC - ql_water = sgm(k)*EXP(1.2*q1k-1.) -#else - ql_water = sgm(k)*EXP(1.2*q1k-1.) -#endif - ql_ice = sgm(k)*EXP(1.2*q1k-1.) - ELSE IF (q1k > 2.) THEN !supersaturated - ql_water = sgm(k)*q1k - ql_ice = sgm(k)*q1k - ELSE !slightly saturated (0 > q1 < 2) - ql_water = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - ql_ice = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - ENDIF + maxqc = max(qw(k) - qsat_tk, 0.0) + if (q1k < 0.) then !unsaturated + ql_water = sgm(k)*exp(1.2*q1k-1.) + ql_ice = sgm(k)*exp(1.2*q1k-1.) + elseif (q1k > 2.) then !supersaturated + ql_water = min(sgm(k)*q1k, maxqc) + ql_ice = sgm(k)*q1k + else !slightly saturated (0 > q1 < 2) + ql_water = min(sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2), maxqc) + ql_ice = sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2) + endif !In saturated grid cells, use average of SGS and resolved values !if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) ) @@ -3922,17 +3957,22 @@ SUBROUTINE mym_condensation (kts,kte, & ! Fng = 1.-1.5*q1k !ENDIF ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS) - IF (q1k .GE. 1.0) THEN + if (q1k .ge. 1.0) then Fng = 1.0 - ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN - Fng = EXP(-0.4*(q1k-1.0)) - ELSEIF (q1k .GE. -2.5 .AND. q1k .LT. -1.7) THEN - Fng = 3.0 + EXP(-3.8*(q1k+1.7)) - ELSE - Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.) - ENDIF + elseif (q1k .ge. -1.7 .and. q1k .lt. 1.0) then + Fng = exp(-0.4*(q1k-1.0)) + elseif (q1k .ge. -2.5 .and. q1k .lt. -1.7) then + Fng = 3.0 + exp(-3.8*(q1k+1.7)) + else + Fng = min(23.9 + exp(-1.6*(q1k+2.5)), 60._kind_phys) + endif + + cfmax = min(cldfra_bl1D(k), 0.6_kind_phys) + !Further limit the cf going into vt & vq near the surface + zsl = min(max(25., 0.1*pblh2), 100.) + wt = min(zagl/zsl, 1.0) !=0 at z=0 m, =1 above ekman layer + cfmax = cfmax*wt - cfmax= min(cldfra_bl1D(k), 0.6) 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 @@ -4023,17 +4063,17 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & &bl_mynn_mixscalars ) !------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte,i + integer, intent(in) :: kts,kte,i #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, & + 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_QS, & + logical, intent(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, & &FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA ! thl - liquid water potential temperature @@ -4043,47 +4083,47 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! flq - surface flux of qw ! mass-flux plumes - real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: s_aw, & + real(kind_phys), 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,s_awqnbca, & &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv ! tendencies from mass-flux environmental subsidence and detrainment - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & + real(kind_phys), dimension(kts:kte), intent(in) :: sub_thl,sub_sqv, & &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,& + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,th,tk,qv,qc,qi,& &qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd, & &cldfra_bl1d,diss_heat - real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,& + real(kind_phys), dimension(kts:kte), intent(inout) :: thl,sqw,sqv,sqc,& &sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh - real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv, & + real(kind_phys), dimension(kts:kte), intent(inout) :: du,dv,dth,dqv, & &dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone - real(kind_phys), INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce - real(kind_phys), INTENT(IN) :: ust,delt,psfc,wspd + real(kind_phys), intent(in) :: flt,flq,flqv,flqc,uoce,voce + real(kind_phys), intent(in) :: ust,delt,psfc,wspd !debugging real(kind_phys):: wsp,wsp2,tk2,th2 - LOGICAL :: problem + logical :: problem integer :: kproblem -! real(kind_phys), INTENT(IN) :: gradu_top,gradv_top,gradth_top,gradqv_top +! real(kind_phys), intent(in) :: gradu_top,gradv_top,gradth_top,gradqv_top !local vars - real(kind_phys), DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp - real(kind_phys), DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, & + real(kind_phys), dimension(kts:kte) :: dtz,dfhc,dfmc,delp + real(kind_phys), dimension(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, & &qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2 - real(kind_phys), DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv - real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x - real(kind_phys), DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface + real(kind_phys), dimension(kts:kte) :: zfac,plumeKh,rhoinv + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x + real(kind_phys), dimension(kts:kte+1) :: rhoz, & !rho on model interface &khdz,kmdz real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc real(kind_phys):: ustdrag,ustdiff,qvflux real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat - INTEGER :: k,kk + integer :: k,kk !Activate nonlocal mixing from the mass-flux scheme for !number concentrations and aerosols (0.0 = no; 1.0 = yes) - real(kind_phys), PARAMETER :: nonloc = 1.0 + real(kind_phys), parameter :: nonloc = 1.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -4586,7 +4626,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !============================================ ! MIX SNOW ( sqs ) !============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QS) THEN +!hard-code to not mix snow +IF (bl_mynn_cloudmix > 0 .AND. .false.) THEN k=kts !rho-weighted: @@ -4813,8 +4854,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnbca(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnbca2(k)=d(k-kts+1) @@ -4891,9 +4932,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & sqi2(k) = 0.0 ! if sqw2 > qsat sqc2(k) = 0.0 ENDIF - !dqv(k) = (sqv2(k) - sqv(k))/delt - !dqc(k) = (sqc2(k) - sqc(k))/delt - !dqi(k) = (sqi2(k) - sqi(k))/delt ENDDO ENDIF @@ -4902,7 +4940,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! WATER VAPOR TENDENCY !===================== DO k=kts,kte - Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt + Dqv(k)=(sqv2(k) - sqv(k))/delt !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k ENDDO @@ -4913,7 +4951,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !print*,"FLAG_QC:",FLAG_QC IF (FLAG_QC) THEN DO k=kts,kte - Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt + Dqc(k)=(sqc2(k) - sqc(k))/delt !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k ENDDO ELSE @@ -4941,7 +4979,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !=================== IF (FLAG_QI) THEN DO k=kts,kte - Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt + Dqi(k)=(sqi2(k) - sqi(k))/delt !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k ENDDO ELSE @@ -4953,9 +4991,9 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !=================== ! CLOUD SNOW TENDENCY !=================== - IF (FLAG_QS) THEN + IF (.false.) THEN !disabled DO k=kts,kte - Dqs(k)=(sqs2(k)/(1.-sqs2(k)) - qs(k))/delt + Dqs(k)=(sqs2(k) - sqs(k))/delt ENDDO ELSE DO k=kts,kte @@ -4979,10 +5017,11 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ELSE !-MIX CLOUD SPECIES? !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0) DO k=kts,kte - Dqc(k)=0. + Dqc(k) =0. Dqnc(k)=0. - Dqi(k)=0. + Dqi(k) =0. Dqni(k)=0. + Dqs(k) =0. ENDDO ENDIF @@ -5207,36 +5246,36 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & enh_mix, smoke_dbg ) !------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte,i - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd - real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: rho - real(kind_phys), INTENT(IN) :: flt - real(kind_phys), INTENT(IN) :: delt,pblh - INTEGER, INTENT(IN) :: nchem, kdvel, ndvel - real(kind_phys), DIMENSION( kts:kte+1), INTENT(IN) :: s_aw - real(kind_phys), DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 - real(kind_phys), DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem - real(kind_phys), DIMENSION( ndvel ), INTENT(IN) :: vd1 - real(kind_phys), INTENT(IN) :: emis_ant_no,frp - LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg + integer, intent(in) :: kts,kte,i + real(kind_phys), dimension(kts:kte), intent(in) :: dfh,dz,tcd,qcd + real(kind_phys), dimension(kts:kte), intent(inout) :: rho + real(kind_phys), intent(in) :: flt + real(kind_phys), intent(in) :: delt,pblh + integer, intent(in) :: nchem, kdvel, ndvel + real(kind_phys), dimension( kts:kte+1), intent(in) :: s_aw + real(kind_phys), dimension( kts:kte, nchem ), intent(inout) :: chem1 + real(kind_phys), dimension( kts:kte+1,nchem), intent(in) :: s_awchem + real(kind_phys), dimension( ndvel ), intent(in) :: vd1 + real(kind_phys), intent(in) :: emis_ant_no,frp + logical, intent(in) :: rrfs_sd,enh_mix,smoke_dbg !local vars - real(kind_phys), DIMENSION(kts:kte) :: dtz - real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x + real(kind_phys), dimension(kts:kte) :: dtz + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x real(kind_phys):: rhs,dztop real(kind_phys):: t,dzk real(kind_phys):: hght real(kind_phys):: khdz_old, khdz_back - INTEGER :: k,kk,kmaxfire ! JLS 12/21/21 - INTEGER :: ic ! Chemical array loop index + integer :: k,kk,kmaxfire ! JLS 12/21/21 + integer :: ic ! Chemical array loop index - INTEGER, SAVE :: icall + integer, SAVE :: icall - real(kind_phys), DIMENSION(kts:kte) :: rhoinv - real(kind_phys), DIMENSION(kts:kte+1) :: rhoz,khdz - real(kind_phys), PARAMETER :: NO_threshold = 10.0 ! For anthropogenic sources - real(kind_phys), PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires - real(kind_phys), PARAMETER :: pblh_threshold = 100.0 + real(kind_phys), dimension(kts:kte) :: rhoinv + real(kind_phys), dimension(kts:kte+1) :: rhoz,khdz + real(kind_phys), parameter :: NO_threshold = 10.0 ! For anthropogenic sources + real(kind_phys), parameter :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires + real(kind_phys), parameter :: pblh_threshold = 100.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5335,14 +5374,14 @@ SUBROUTINE retrieve_exchange_coeffs(kts,kte,& !------------------------------------------------------------------- - INTEGER , INTENT(in) :: kts,kte + integer , intent(in) :: kts,kte - real(kind_phys), DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh + real(kind_phys), dimension(KtS:KtE), intent(in) :: dz,dfm,dfh - real(kind_phys), DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h + real(kind_phys), dimension(KtS:KtE), intent(out) :: K_m, K_h - INTEGER :: k + integer :: k real(kind_phys):: dzk K_m(kts)=0. @@ -5368,13 +5407,13 @@ SUBROUTINE tridiag(n,a,b,c,d) !------------------------------------------------------------------- - INTEGER, INTENT(in):: n - real(kind_phys), DIMENSION(n), INTENT(in) :: a,b - real(kind_phys), DIMENSION(n), INTENT(inout) :: c,d + integer, intent(in):: n + real(kind_phys), dimension(n), intent(in) :: a,b + real(kind_phys), dimension(n), intent(inout) :: c,d - INTEGER :: i + integer :: i real(kind_phys):: p - real(kind_phys), DIMENSION(n) :: q + real(kind_phys), dimension(n) :: q c(n)=0. q(1)=-c(1)/b(1) @@ -5508,23 +5547,23 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) !value could be found to work best in all conditions. !--------------------------------------------------------------- - INTEGER,INTENT(IN) :: KTS,KTE + integer,intent(in) :: KTS,KTE #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - real(kind_phys), INTENT(OUT) :: zi - real(kind_phys), INTENT(IN) :: landsea - real(kind_phys), DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D - real(kind_phys), DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D + real(kind_phys), intent(out) :: zi + real(kind_phys), intent(in) :: landsea + real(kind_phys), dimension(kts:kte), intent(in) :: thetav1D, qke1D, dz1D + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw1D !LOCAL VARS real(kind_phys):: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv real(kind_phys):: delt_thv !delta theta-v; dependent on land/sea point - real(kind_phys), PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m). - real(kind_phys), PARAMETER :: sbl_damp = 400. !transition length for blending (m). - INTEGER :: I,J,K,kthv,ktke,kzi + real(kind_phys), parameter :: sbl_lim = 200. !upper limit of stable BL height (m). + real(kind_phys), parameter :: sbl_damp = 400. !transition length for blending (m). + integer :: I,J,K,kthv,ktke,kzi !Initialize KPBL (kzi) kzi = 2 @@ -5689,12 +5728,12 @@ SUBROUTINE DMP_mf( & & F_QNWFA,F_QNIFA,F_QNBCA, & & Psig_shcu, & ! output info - & nup2,ktop,maxmf,ztop, & + & maxwidth,ktop,maxmf,ztop, & ! inputs for stochastic perturbations & spp_pbl,rstoch_col ) ! inputs: - INTEGER, INTENT(IN) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt + integer, intent(in) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt #ifdef HARDCODE_VERTICAL # define kts 1 @@ -5702,133 +5741,137 @@ SUBROUTINE DMP_mf( & #endif ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col - real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: & + real(kind_phys),dimension(kts:kte), intent(in) :: & &U,V,W,TH,THL,TK,QT,QV,QC, & &exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca - real(kind_phys),DIMENSION(KTS:KTE+1), INTENT(IN) :: zw !height at full-sigma - real(kind_phys), INTENT(IN) :: flt,fltv,flq,flqv,Psig_shcu, & + real(kind_phys),dimension(kts:kte+1), intent(in) :: zw !height at full-sigma + real(kind_phys), intent(in) :: flt,fltv,flq,flqv,Psig_shcu, & &landsea,ts,dx,dt,ust,pblh - LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA + logical, optional :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA ! outputs - updraft properties - real(kind_phys),DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & + real(kind_phys),dimension(kts:kte), intent(out) :: edmf_a,edmf_w, & & edmf_qt,edmf_thl,edmf_ent,edmf_qc !add one local edmf variable: - real(kind_phys),DIMENSION(KTS:KTE) :: edmf_th + real(kind_phys),dimension(kts:kte) :: edmf_th ! output - INTEGER, INTENT(OUT) :: nup2,ktop - real(kind_phys), INTENT(OUT) :: maxmf - real(kind_phys), INTENT(OUT) :: ztop + integer, intent(out) :: ktop + real(kind_phys), intent(out) :: maxmf,ztop,maxwidth ! outputs - variables needed for solver - real(kind_phys),DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi + real(kind_phys),dimension(kts:kte+1) :: s_aw, & !sum ai*rho*wis_awphi &s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni, & &s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv, & &s_awqke,s_aw2 - real(kind_phys),DIMENSION(KTS:KTE), INTENT(INOUT) :: & + real(kind_phys),dimension(kts:kte), intent(inout) :: & &qc_bl1d,cldfra_bl1d,qc_bl1d_old,cldfra_bl1d_old - INTEGER, PARAMETER :: nup=10, debug_mf=0 + integer, parameter :: nup=8, debug_mf=0 + real(kind_phys) :: nup2 !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the ! first model layer - real(kind_phys),DIMENSION(KTS:KTE+1,1:NUP) :: & + real(kind_phys),dimension(kts:kte+1,1:NUP) :: & &UPW,UPTHL,UPQT,UPQC,UPQV, & &UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & &UPQNI,UPQNWFA,UPQNIFA,UPQNBCA ! entrainment variables - real(kind_phys),DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf - INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi + real(kind_phys),dimension(kts:kte,1:NUP) :: ENT,ENTf + integer,dimension(kts:kte,1:NUP) :: ENTi ! internal variables - INTEGER :: K,I,k50 + integer :: K,I,k50 real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT, & &sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & - QNWFAn,QNIFAn,QNBCAn, & - Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int + & QNWFAn,QNIFAn,QNBCAn, & + & Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters - real(kind_phys), PARAMETER :: & + real(kind_phys), 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(kind_phys),PARAMETER :: & - & L0=100., & - & ENT0=0.1 - - ! Implement ideas from Neggers (2016, JAMES): - real(kind_phys), PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts - real(kind_phys), PARAMETER :: lmax = 1000.! diameter of largest plume - real(kind_phys), PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand - real(kind_phys), PARAMETER :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) - real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). + real(kind_phys),parameter :: & + & L0=100., & + & ENT0=0.1 + + ! Parameters/variables for regulating plumes: + real(kind_phys), parameter :: Atot = 0.10 ! Maximum total fractional area of all updrafts + real(kind_phys), parameter :: lmax = 1000.! diameter of largest plume (absolute maximum, can be smaller) + real(kind_phys), parameter :: lmin = 300. ! diameter of smallest plume (absolute minimum, can be larger) + real(kind_phys), parameter :: dlmin = 0. ! delta increase in the diameter of smallest plume (large fltv) + real(kind_phys) :: minwidth ! actual width of smallest plume + real(kind_phys) :: dl ! variable increment of plume size + real(kind_phys), parameter :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) + real(kind_phys):: 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(kind_phys):: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx + real(kind_phys):: cn,c,l,n,an2,hux,wspd_pbl,cloud_base,width_flx ! chem/smoke - INTEGER, INTENT(IN) :: nchem - real(kind_phys),DIMENSION(:, :) :: chem1 - real(kind_phys),DIMENSION(kts:kte+1, nchem) :: s_awchem - real(kind_phys),DIMENSION(nchem) :: chemn - real(kind_phys),DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM - INTEGER :: ic - real(kind_phys),DIMENSION(KTS:KTE+1, nchem) :: edmf_chem - LOGICAL, INTENT(IN) :: mix_chem + integer, intent(in) :: nchem + real(kind_phys),dimension(:, :) :: chem1 + real(kind_phys),dimension(kts:kte+1, nchem) :: s_awchem + real(kind_phys),dimension(nchem) :: chemn + real(kind_phys),dimension(kts:kte+1,1:NUP, nchem) :: UPCHEM + integer :: ic + real(kind_phys),dimension(kts:kte+1, nchem) :: edmf_chem + logical, intent(in) :: mix_chem !JOE: add declaration of ERF real(kind_phys):: ERF - LOGICAL :: superadiabatic + logical :: superadiabatic ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION - real(kind_phys),DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm + real(kind_phys),dimension(kts:kte), intent(inout) :: vt, vq, sgm real(kind_phys):: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & Ac_mf,Ac_strat,qc_mf - real(kind_phys), PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value + real(kind_phys), parameter :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value ! Variables for plume interpolation/saturation check - real(kind_phys),DIMENSION(KTS:KTE) :: exneri,dzi + real(kind_phys),dimension(kts:kte) :: exneri,dzi,rhoz real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl - real(kind_phys):: csigma,acfac,ac_wsp,ac_cld + real(kind_phys):: csigma,acfac,ac_wsp !plume overshoot - INTEGER :: overshoot + integer :: overshoot real(kind_phys):: bvf, Frz, dzp !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(kind_phys):: adjustment, flx1 - real(kind_phys), PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact + real(kind_phys), parameter :: fluxportion=0.75 ! set liberally, so has minimal impact. Note that + ! 0.5 starts to have a noticeable impact ! over land (decrease maxMF by 10-20%), but no impact over water. !Subsidence - real(kind_phys),DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence + real(kind_phys),dimension(kts:kte) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & envm_u,envm_v !environmental variables defined at middle of layer - real(kind_phys),DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface + real(kind_phys),dimension(kts:kte+1) :: envi_a,envi_w !environmental variables defined at model interface real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs, & - qc_plume,exc_heat,exc_moist,tk_int - real(kind_phys), PARAMETER :: Cdet = 1./45. - real(kind_phys), PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers + qc_plume,exc_heat,exc_moist,tk_int,tvs + real(kind_phys), parameter :: Cdet = 1./45. + real(kind_phys), parameter :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers !parameter "Csub" determines the propotion of upward vertical velocity that contributes to !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme !is compensated by "gentle" environmental subsidence. - real(kind_phys), PARAMETER :: Csub=0.25 + real(kind_phys), parameter :: Csub=0.25 !Factor for the pressure gradient effects on momentum transport - real(kind_phys), PARAMETER :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere + real(kind_phys), parameter :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa ! check the inputs @@ -5859,9 +5902,9 @@ SUBROUTINE DMP_mf( & UPQNWFA=0. UPQNIFA=0. UPQNBCA=0. - IF ( mix_chem ) THEN - UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 - ENDIF + if ( mix_chem ) then + UPCHEM(kts:kte+1,1:NUP,1:nchem)=0.0 + endif ENT=0.001 ! Initialize mean updraft properties @@ -5871,9 +5914,9 @@ SUBROUTINE DMP_mf( & edmf_thl=0. edmf_ent=0. edmf_qc =0. - IF ( mix_chem ) THEN + if ( mix_chem ) then edmf_chem(kts:kte+1,1:nchem) = 0.0 - ENDIF + endif ! Initialize the variables needed for implicit solver s_aw=0. @@ -5889,153 +5932,163 @@ SUBROUTINE DMP_mf( & s_awqnwfa=0. s_awqnifa=0. s_awqnbca=0. - IF ( mix_chem ) THEN + if ( mix_chem ) then s_awchem(kts:kte+1,1:nchem) = 0.0 - ENDIF + endif ! Initialize explicit tendencies for subsidence & detrainment sub_thl = 0. sub_sqv = 0. - sub_u = 0. - sub_v = 0. + sub_u = 0. + sub_v = 0. det_thl = 0. det_sqv = 0. det_sqc = 0. - det_u = 0. - det_v = 0. + det_u = 0. + det_v = 0. + nup2 = nup !start with nup, but set to zero if activation criteria fails ! Taper off MF scheme when significant resolved-scale motions ! are present This function needs to be asymetric... - k = 1 - maxw = 0.0 + maxw = 0.0 cloud_base = 9000.0 -! DO WHILE (ZW(k) < pblh + 500.) - DO k=1,kte-1 - IF(zw(k) > pblh + 500.) exit + 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)) + 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 + if (ZW(k)<=50.)k50=k !Search for cloud base - qc_sgs = MAX(qc(k), qc_bl1d(k)*cldfra_bl1d(k)) - IF(qc_sgs> 1E-5 .AND. cloud_base == 9000.0)THEN + qc_sgs = max(qc(k), qc_bl1d(k)) + if (qc_sgs> 1E-5 .and. (cldfra_bl1d(k) .ge. 0.5) .and. cloud_base == 9000.0) then cloud_base = 0.5*(ZW(k)+ZW(k+1)) - ENDIF + endif + enddo - !k = k + 1 - ENDDO - !print*," maxw before manipulation=", maxw - maxw = MAX(0.,maxw - 1.0) ! do nothing for small w (< 1 m/s), but - Psig_w = MAX(0.0, 1.0 - maxw) ! linearly taper off for w > 1.0 m/s - Psig_w = MIN(Psig_w, Psig_shcu) - !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu + !do nothing for small w (< 1 m/s), but linearly taper off for w > 1.0 m/s + maxw = max(0.,maxw - 1.0) + Psig_w = max(0.0, 1.0 - maxw) + Psig_w = min(Psig_w, Psig_shcu) !Completely shut off MF scheme for strong resolved-scale vertical velocities. fltv2 = fltv - IF(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv + if(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv ! If surface buoyancy is positive we do integration, otherwise no. ! Also, ensure that it is at least slightly superadiabatic up through 50 m superadiabatic = .false. - IF((landsea-1.5).GE.0)THEN + if ((landsea-1.5).ge.0) then hux = -0.001 ! WATER ! dT/dz must be < - 0.1 K per 100 m. - ELSE + else hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m. - ENDIF - DO k=1,MAX(1,k50-1) !use "-1" because k50 used interface heights (zw). - IF (k == 1) then - IF ((th(k)-ts)/(0.5*dz(k)) < hux) THEN + endif + tvs = ts*(1.0+p608*qv(kts)) + do k=1,max(1,k50-1) !use "-1" because k50 used interface heights (zw). + if (k == 1) then + if ((thv(k)-tvs)/(0.5*dz(k)) < hux) then superadiabatic = .true. - ELSE + else superadiabatic = .false. exit - ENDIF - ELSE - IF ((th(k)-th(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) THEN + endif + else + if ((thv(k)-thv(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) then superadiabatic = .true. - ELSE + else superadiabatic = .false. exit - ENDIF - ENDIF - ENDDO + 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. + ! (1) largest plume = 1.2 * dx. + ! (2) Apply a scale-break, assuming no plumes with diameter larger than 1.1*PBLH can exist. ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base. ! (4) add wspd-dependent limit, when plume model breaks down. (hurricanes) ! (5) limit to reduce max plume sizes in weakly forced conditions. This is only ! meant to "soften" the activation of the mass-flux scheme. ! Criteria (1) - NUP2 = max(1,min(NUP,INT(dx*dcut/dl))) + maxwidth = min(dx*dcut, lmax) !Criteria (2) - maxwidth = 1.1*PBLH + maxwidth = min(maxwidth, 1.1_kind_phys*PBLH) ! Criteria (3) - maxwidth = MIN(maxwidth,0.5*cloud_base) + if ((landsea-1.5) .lt. 0) then !land + maxwidth = MIN(maxwidth, 0.5_kind_phys*cloud_base) + else !water + maxwidth = MIN(maxwidth, 0.9_kind_phys*cloud_base) + endif ! Criteria (4) - wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01)) + wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01_kind_phys)) !Note: area fraction (acfac) is modified below ! Criteria (5) - only a function of flt (not fltv) if ((landsea-1.5).LT.0) then !land - !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((fltv - 0.040)/0.04) + .5),1000._kind_phys), 0._kind_phys) else !water - width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.003)/0.01) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.007)/0.02) + .5),1000._kind_phys), 0._kind_phys) + endif + maxwidth = MIN(maxwidth, width_flx) + minwidth = lmin + !allow min plume size to increase in large flux conditions (eddy diffusivity should be + !large enough to handle the representation of small plumes). + if (maxwidth .ge. (lmax - 1.0) .and. fltv .gt. 0.2)minwidth = lmin + dlmin*min((fltv-0.2)/0.3, 1._kind_phys) + + if (maxwidth .le. minwidth) then ! deactivate MF component + nup2 = 0 + maxwidth = 0.0 endif - maxwidth = MIN(maxwidth,width_flx) - ! Convert maxwidth to number of plumes - NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2) - !Initialize values for 2d output fields: - ktop = 0 - ztop = 0.0 - maxmf= 0.0 + ! Initialize values for 2d output fields: + ktop = 0 + ztop = 0.0 + maxmf= 0.0 - IF ( fltv2 > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then - !PRINT*," Conditions met to run mass-flux scheme",fltv2,pblh +!Begin plume processing if passes criteria +if ( fltv2 > 0.002 .AND. (maxwidth > minwidth) .AND. superadiabatic) then ! 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((fltv2 - 0.05)/0.15) - do I=1,NUP !NUP2 - IF(I > NUP2) exit - l = dl*I ! diameter of plume + d =-1.9 !set d to value suggested by Neggers 2015 (JAMES). + dl = (maxwidth - minwidth)/real(nup-1,kind=kind_phys) + do i=1,NUP + ! diameter of plume + l = minwidth + dl*real(i-1) 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) ! Make updraft area (UPA) a function of the buoyancy flux if ((landsea-1.5).LT.0) then !land - !acfac = .5*tanh((fltv2 - 0.03)/0.09) + .5 - !acfac = .5*tanh((fltv2 - 0.02)/0.09) + .5 acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 else !water acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5 endif !add a windspeed-dependent adjustment to acfac that tapers off - !the mass-flux scheme linearly above sfc wind speeds of 20 m/s: - ac_wsp = 1.0 - min(max(wspd_pbl - 20.0, 0.0), 10.0)/10.0 - !reduce area fraction beneath cloud bases < 1200 m AGL - ac_cld = min(cloud_base/1200., 1.0) - acfac = acfac * min(ac_wsp, ac_cld) + !the mass-flux scheme linearly above sfc wind speeds of 10 m/s. + !Note: this effect may be better represented by an increase in + !entrainment rate for high wind consitions (more ambient turbulence). + if (wspd_pbl .le. 10.) then + ac_wsp = 1.0 + else + ac_wsp = 1.0 - min((wspd_pbl - 10.0)/15., 1.0) + endif + acfac = acfac * ac_wsp ! 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 + do i=1,NUP + ! diameter of plume + l = minwidth + dl*real(i-1) N = C*l**d ! number density of plume n - UPA(1,I) = N*l*l/(dx*dx) * dl ! fractional area of plume n + UPA(1,i) = N*l*l/(dx*dx) * dl ! fractional area of plume n - UPA(1,I) = UPA(1,I)*acfac - An2 = An2 + UPA(1,I) ! total fractional area of all plumes + 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 @@ -6048,23 +6101,25 @@ SUBROUTINE DMP_mf( & qstar=max(flq,1.0E-5)/wstar thstar=flt/wstar - IF((landsea-1.5).GE.0)THEN + if ((landsea-1.5) .ge. 0) then csigma = 1.34 ! WATER - ELSE + else csigma = 1.34 ! LAND - ENDIF + endif if (env_subs) then exc_fac = 0.0 else if ((landsea-1.5).GE.0) then !water: increase factor to compensate for decreased pwmin/pwmax - exc_fac = 0.58*4.0*min(cloud_base/1000., 1.0) + exc_fac = 0.58*4.0 else !land: no need to increase factor - already sufficiently large superadiabatic layers exc_fac = 0.58 endif endif + !decrease excess for large wind speeds + exc_fac = exc_fac * ac_wsp !Note: sigmaW is typically about 0.5*wstar sigmaW =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh) @@ -6077,14 +6132,11 @@ SUBROUTINE DMP_mf( & wmax=MIN(sigmaW*pwmax,0.5) !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + do i=1,NUP wlv=wmin+(wmax-wmin)/NUP2*(i-1) !SURFACE UPDRAFT VERTICAL VELOCITY 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 - 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.0 @@ -6093,21 +6145,11 @@ SUBROUTINE DMP_mf( & exc_heat = exc_fac*UPW(1,I)*sigmaTH/sigmaW UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & & + exc_heat -!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)) & & + exc_heat !calculate exc_moist by use of surface fluxes exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW - !calculate exc_moist by conserving rh: -! tk_int =(tk(kts)*dz(kts+1)+tk(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) -! pk =(p(kts)*dz(kts+1)+p(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) -! qtk =(qt(kts)*dz(kts+1)+qt(kts+1)*dz(kts))/(dz(kts)+dz(kts+1)) -! qsat_tk = qsat_blend(tk_int, pk) ! saturation water vapor mixing ratio at tk and p -! rhgrid =MAX(MIN(1.0,qtk/MAX(1.E-8,qsat_tk)),0.001) -! tk_int = tk_int + exc_heat -! qsat_tk = qsat_blend(tk_int, pk) -! exc_moist= max(rhgrid*qsat_tk - qtk, 0.0) UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& & +exc_moist @@ -6117,36 +6159,36 @@ SUBROUTINE DMP_mf( & 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)) UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - ENDDO + enddo - IF ( mix_chem ) THEN - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + if ( mix_chem ) then + do i=1,NUP do ic = 1,nchem - UPCHEM(1,I,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPCHEM(1,i,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) enddo - ENDDO - ENDIF + enddo + endif !Initialize environmental variables which can be modified by detrainment - DO k=kts,kte - envm_thl(k)=THL(k) - envm_sqv(k)=QV(k) - envm_sqc(k)=QC(k) - envm_u(k)=U(k) - envm_v(k)=V(k) - ENDDO + envm_thl(kts:kte)=THL(kts:kte) + envm_sqv(kts:kte)=QV(kts:kte) + envm_sqc(kts:kte)=QC(kts:kte) + envm_u(kts:kte)=U(kts:kte) + envm_v(kts:kte)=V(kts:kte) + do k=kts,kte-1 + rhoz(k) = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) + enddo + rhoz(kte) = rho(kte) !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.) ! do integration updraft - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + do i=1,NUP QCn = 0. overshoot = 0 - l = dl*I ! diameter of plume - DO k=KTS+1,KTE-1 + l = minwidth + dl*real(i-1) ! diameter of plume + do k=kts+1,kte-1 !Entrainment from Tian and Kuang (2016) !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l) wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh @@ -6161,7 +6203,7 @@ SUBROUTINE DMP_mf( & 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. + !increase entrainment for plumes extending very high. IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,4000.))*5.0E-6 ENDIF @@ -6339,6 +6381,7 @@ SUBROUTINE DMP_mf( & 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 @@ -6358,30 +6401,26 @@ SUBROUTINE DMP_mf( & ENDIF ENDIF ENDDO - ELSE +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 +END IF !end criteria check for mass-flux scheme - ktop=MIN(ktop,KTE-1) ! Just to be safe... - IF (ktop == 0) THEN - ztop = 0.0 - ELSE - ztop=zw(ktop) - ENDIF - - IF(nup2 > 0) THEN +ktop=MIN(ktop,KTE-1) +IF (ktop == 0) THEN + ztop = 0.0 +ELSE + ztop=zw(ktop) +ENDIF - !Calculate the fluxes for each variable - !All s_aw* variable are == 0 at k=1 - DO i=1,NUP !NUP2 - IF(I > NUP2) exit +IF (nup2 > 0) THEN + !Calculate the fluxes for each variable + !All s_aw* variable are == 0 at k=1 + DO i=1,NUP DO k=KTS,KTE-1 - IF(k > ktop) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - s_aw(k+1) = s_aw(k+1) + rho_int*UPA(K,i)*UPW(K,i)*Psig_w - s_awthl(k+1)= s_awthl(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w - s_awqt(k+1) = s_awqt(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w + s_aw(k+1) = s_aw(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*Psig_w + s_awthl(k+1)= s_awthl(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w + s_awqt(k+1) = s_awqt(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w !to conform to grid mean properties, move qc to qv in grid mean !saturated layers, so total water fluxes are preserved but !negative qc fluxes in unsaturated layers is reduced. @@ -6390,72 +6429,76 @@ SUBROUTINE DMP_mf( & ! else ! qc_plume = 0.0 ! endif - s_awqc(k+1) = s_awqc(k+1) + rho_int*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w - IF (momentum_opt > 0) THEN - s_awu(k+1) = s_awu(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w - s_awv(k+1) = s_awv(k+1) + rho_int*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) + rho_int*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w - ENDIF + s_awqc(k+1) = s_awqc(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) ENDDO - ENDDO - - IF ( mix_chem ) THEN - DO k=KTS,KTE - IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - DO i=1,NUP !NUP2 - IF(I > NUP2) exit - do ic = 1,nchem - s_awchem(k+1,ic) = s_awchem(k+1,ic) + rho_int*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w - enddo - ENDDO - ENDDO - ENDIF - - IF (scalar_opt > 0) THEN - DO k=KTS,KTE - IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - DO I=1,NUP !NUP2 - IF (I > NUP2) exit - s_awqnc(k+1)= s_awqnc(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w - s_awqni(k+1)= s_awqni(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w - s_awqnwfa(k+1)= s_awqnwfa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w - s_awqnifa(k+1)= s_awqnifa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w - s_awqnbca(k+1)= s_awqnbca(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w - ENDDO - ENDDO - ENDIF + ENDDO + !momentum + if (momentum_opt > 0) then + do i=1,nup + do k=kts,kte-1 + s_awu(k+1) = s_awu(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w + s_awv(k+1) = s_awv(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w + enddo + enddo + endif + !tke + if (tke_opt > 0) then + do i=1,nup + do k=kts,kte-1 + s_awqke(k+1)= s_awqke(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w + enddo + enddo + endif + !chem + if ( mix_chem ) then + do k=kts,kte + do i=1,nup + do ic = 1,nchem + s_awchem(k+1,ic) = s_awchem(k+1,ic) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w + enddo + enddo + enddo + endif + + if (scalar_opt > 0) then + do k=kts,kte + do I=1,nup + s_awqnc(k+1) = s_awqnc(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w + s_awqni(k+1) = s_awqni(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w + s_awqnwfa(k+1)= s_awqnwfa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w + s_awqnifa(k+1)= s_awqnifa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w + s_awqnbca(k+1)= s_awqnbca(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w + enddo + enddo + endif - !Flux limiter: Check ratio of heat flux at top of first model layer - !and at the surface. Make sure estimated flux out of the top of the - !layer is < fluxportion*surface_heat_flux - IF (s_aw(kts+1) /= 0.) THEN + !Flux limiter: Check ratio of heat flux at top of first model layer + !and at the surface. Make sure estimated flux out of the top of the + !layer is < fluxportion*surface_heat_flux + IF (s_aw(kts+1) /= 0.) THEN dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) !dz centered at model interface flx1 = MAX(s_aw(kts+1)*(TH(kts)-TH(kts+1))/dzi(kts),1.0e-5) - ELSE + ELSE flx1 = 0.0 !print*,"ERROR: s_aw(kts+1) == 0, NUP=",NUP," NUP2=",NUP2,& ! " superadiabatic=",superadiabatic," KTOP=",KTOP - ENDIF - adjustment=1.0 - !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1 - !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1) - IF (flx1 > fluxportion*flt/dz(kts) .AND. flx1>0.0) THEN + ENDIF + adjustment=1.0 + !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1 + !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1) + IF (flx1 > fluxportion*flt/dz(kts) .AND. flx1>0.0) THEN adjustment= fluxportion*flt/dz(kts)/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 - s_awqnbca= s_awqnbca*adjustment + 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 + s_awqnbca = s_awqnbca*adjustment IF (momentum_opt > 0) THEN s_awu = s_awu*adjustment s_awv = s_awv*adjustment @@ -6467,62 +6510,57 @@ SUBROUTINE DMP_mf( & s_awchem = s_awchem*adjustment ENDIF UPA = UPA*adjustment - ENDIF - !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt - - !Calculate mean updraft properties for output: - !all edmf_* variables at k=1 correspond to the interface at top of first model layer - DO k=KTS,KTE-1 - IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - DO I=1,NUP !NUP2 - IF(I > NUP2) exit - edmf_a(K) =edmf_a(K) +UPA(K,i) - edmf_w(K) =edmf_w(K) +rho_int*UPA(K,i)*UPW(K,i) - edmf_qt(K) =edmf_qt(K) +rho_int*UPA(K,i)*UPQT(K,i) - edmf_thl(K)=edmf_thl(K)+rho_int*UPA(K,i)*UPTHL(K,i) - edmf_ent(K)=edmf_ent(K)+rho_int*UPA(K,i)*ENT(K,i) - edmf_qc(K) =edmf_qc(K) +rho_int*UPA(K,i)*UPQC(K,i) - ENDDO - + ENDIF + !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt + + !Calculate mean updraft properties for output: + !all edmf_* variables at k=1 correspond to the interface at top of first model layer + do k=kts,kte-1 + do I=1,nup + edmf_a(K) =edmf_a(K) +UPA(K,i) + edmf_w(K) =edmf_w(K) +rhoz(k)*UPA(K,i)*UPW(K,i) + edmf_qt(K) =edmf_qt(K) +rhoz(k)*UPA(K,i)*UPQT(K,i) + edmf_thl(K)=edmf_thl(K)+rhoz(k)*UPA(K,i)*UPTHL(K,i) + edmf_ent(K)=edmf_ent(K)+rhoz(k)*UPA(K,i)*ENT(K,i) + edmf_qc(K) =edmf_qc(K) +rhoz(k)*UPA(K,i)*UPQC(K,i) + enddo + enddo + do k=kts,kte-1 !Note that only edmf_a is multiplied by Psig_w. This takes care of the !scale-awareness of the subsidence below: - 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) - 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 ! end k - - !smoke/chem - IF ( mix_chem ) THEN - DO k=kts,kte-1 - IF(k > KTOP) exit - rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + 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) + 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 ! end k + + !smoke/chem + if ( mix_chem ) then + do k=kts,kte-1 + do I=1,nup do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic) + rho_int*UPA(K,I)*UPCHEM(k,i,ic) + edmf_chem(k,ic) = edmf_chem(k,ic) + rhoz(k)*UPA(K,I)*UPCHEM(k,i,ic) enddo - ENDDO - - IF (edmf_a(k)>0.) THEN + enddo + enddo + do k=kts,kte-1 + if (edmf_a(k)>0.) then do ic = 1,nchem edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) enddo - ENDIF - ENDDO ! end k - ENDIF + endif + enddo ! end k + endif - !Calculate the effects environmental subsidence. - !All envi_*variables are valid at the interfaces, like the edmf_* variables - IF (env_subs) THEN + !Calculate the effects environmental subsidence. + !All envi_*variables are valid at the interfaces, like the edmf_* variables + IF (env_subs) THEN DO k=kts+1,kte-1 !First, smooth the profiles of w & a, since sharp vertical gradients !in plume variables are not likely extended to env variables @@ -6557,18 +6595,16 @@ SUBROUTINE DMP_mf( & !calculate tendencies from subsidence and detrainment valid at the middle of !each model layer. The lowest model layer uses an assumes w=0 at the surface. dzi(kts) = 0.5*(dz(kts)+dz(kts+1)) - rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rho_int + (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rhoz(k) sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rho_int + (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rhoz(k) DO k=kts+1,kte-1 dzi(k) = 0.5*(dz(k)+dz(k+1)) - rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rho_int + (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rhoz(k) sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rho_int + (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rhoz(k) ENDDO DO k=KTS,KTE-1 @@ -6578,17 +6614,15 @@ SUBROUTINE DMP_mf( & ENDDO IF (momentum_opt > 0) THEN - rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rho_int + (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rhoz(k) sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rho_int + (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rhoz(k) DO k=kts+1,kte-1 - rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rho_int + (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rhoz(k) sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rho_int + (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rhoz(k) ENDDO DO k=KTS,KTE-1 @@ -6596,23 +6630,23 @@ SUBROUTINE DMP_mf( & det_v(k) = Cdet*(envm_v(k)-v(k))*envi_a(k)*Psig_w ENDDO ENDIF - ENDIF !end subsidence/env detranment + ENDIF !end subsidence/env detranment - !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)) + !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 + 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 .and. (cldfra_bl1d(k) < cf_thresh))THEN + do k=kts+1,kte-2 + if (k > KTOP) exit + if(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN !interpolate plume quantities to mass levels Aup = (edmf_a(k)*dzi(k-1)+edmf_a(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)) @@ -6686,8 +6720,8 @@ SUBROUTINE DMP_mf( & !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) !Original CB mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) - mf_cf = max(mf_cf, 1.75 * Aup) - mf_cf = min(mf_cf, 5.0 * Aup) + mf_cf = max(mf_cf, 1.8 * Aup) + mf_cf = min(mf_cf, 5.0 * Aup) endif !IF ( debug_code ) THEN @@ -6705,10 +6739,7 @@ SUBROUTINE DMP_mf( & if (QCp * Aup > 5e-5) then qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 else - qc_bl1d(k) = 1.18 * (QCp * Aup) - endif - if (mf_cf .ge. Aup) then - qc_bl1d(k) = qc_bl1d(k) / mf_cf + qc_bl1d(k) = 1.18 * (QCp * Aup) endif cldfra_bl1d(k) = mf_cf Ac_mf = mf_cf @@ -6718,9 +6749,6 @@ SUBROUTINE DMP_mf( & else qc_bl1d(k) = 1.18 * (QCp * Aup) endif - if (mf_cf .ge. Aup) then - qc_bl1d(k) = qc_bl1d(k) / mf_cf - endif cldfra_bl1d(k) = mf_cf Ac_mf = mf_cf endif @@ -6752,13 +6780,13 @@ SUBROUTINE DMP_mf( & endif !check for (qc in plume) .and. (cldfra_bl < threshold) enddo !k-loop - ENDIF !end nup2 > 0 +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 +!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 @@ -6927,62 +6955,68 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & &qc_bl1d,cldfra_bl1d, & &rthraten ) - INTEGER, INTENT(IN) :: KTS,KTE,KPBL - real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& - THV,P,rho,exner,dz - real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten + integer, intent(in) :: KTS,KTE,KPBL + real(kind_phys), dimension(kts:kte), intent(in) :: & + U,V,TH,THL,TK,QT,QV,QC,THV,P,rho,exner,dz + real(kind_phys), dimension(kts:kte), intent(in) :: rthraten ! zw .. heights of the downdraft levels (edges of boxes) - real(kind_phys),DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW - real(kind_phys), INTENT(IN) :: WTHL,WQT - real(kind_phys), INTENT(IN) :: dt,ust,pblh + real(kind_phys), dimension(kts:kte+1), intent(in) :: ZW + real(kind_phys), intent(in) :: WTHL,WQT + real(kind_phys), intent(in) :: dt,ust,pblh ! outputs - downdraft properties - real(kind_phys),DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & - & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd + real(kind_phys), dimension(kts:kte), intent(out) :: & + edmf_a_dd,edmf_w_dd, & + edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd ! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii) - real(kind_phys),DIMENSION(KTS:KTE+1) :: sd_aw, sd_awthl, sd_awqt, sd_awu, & - sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2 + real(kind_phys), dimension(kts:kte+1) :: & + sd_aw, sd_awthl, sd_awqt, sd_awu, & + sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2 - real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: qc_bl1d, cldfra_bl1d + real(kind_phys), dimension(kts:kte), intent(in) :: & + qc_bl1d, cldfra_bl1d - INTEGER, PARAMETER :: NDOWN=5, debug_mf=0 !fixing number of plumes to 5 + integer, parameter:: ndown = 5 ! draw downdraft starting height randomly between cloud base and cloud top - INTEGER, DIMENSION(1:NDOWN) :: DD_initK - real(kind_phys) , DIMENSION(1:NDOWN) :: randNum + integer, dimension(1:NDOWN) :: DD_initK + real(kind_phys), dimension(1:NDOWN) :: randNum ! downdraft properties - real(kind_phys),DIMENSION(KTS:KTE+1,1:NDOWN) :: DOWNW,DOWNTHL,DOWNQT,& - DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV + real(kind_phys), dimension(kts:kte+1,1:NDOWN) :: & + DOWNW,DOWNTHL,DOWNQT,DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV ! entrainment variables - Real(Kind_phys),DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf - INTEGER,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENTi + real(kind_phys), dimension(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf + integer, dimension(KTS+1:KTE+1,1:NDOWN) :: ENTi ! internal variables - INTEGER :: K,I,ki, kminrad, qlTop, p700_ind, qlBase - real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & - pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw - real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,THVk,Pk, & - EntEXP,EntW, Beta_dm, EntExp_M, rho_int - real(kind_phys):: jump_thetav, jump_qt, jump_thetal, & + integer :: K,I,ki, kminrad, qlTop, p700_ind, qlBase + real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT, & + sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw + real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn, & + THVk,Pk,EntEXP,EntW,beta_dm,EntExp_M,rho_int + real(kind_phys):: jump_thetav, jump_qt, jump_thetal, & refTHL, refTHV, refQT ! DD specific internal variables real(kind_phys):: minrad,zminrad, radflux, F0, wst_rad, wst_dd logical :: cloudflg - - real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt,& + real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt, & Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid ! w parameters - real(kind_phys),PARAMETER :: & - &Wa=1., & - &Wb=1.5,& - &Z00=100.,& - &BCOEFF=0.2 + real(kind_phys),parameter :: & + &Wa=1., Wb=1.5, Z00=100., BCOEFF=0.2 ! entrainment parameters - real(kind_phys),PARAMETER :: & - & L0=80,& - & ENT0=0.2 - + real(kind_phys),parameter :: & + &L0=80, ENT0=0.2 + !downdraft properties + real(kind_phys):: & + & dp, & !diameter of plume + & dl, & !diameter increment + & Adn !total area of downdrafts + !additional printouts for debugging + integer, parameter :: debug_mf=0 + + dl = (1000.-500.)/real(ndown) pwmin=-3. ! drawing from the negative tail -3sigma to -1sigma pwmax=-1. @@ -7052,6 +7086,14 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & if ( radflux < 0.0 ) F0 = abs(radflux) + F0 enddo F0 = max(F0, 1.0) + + !Allow the total fractional area of the downdrafts to be proportional + !to the radiative forcing: + !for 50 W/m2, Adn = 0.10 + !for 100 W/m2, Adn = 0.15 + !for 150 W/m2, Adn = 0.20 + Adn = min( 0.05 + F0*0.001, 0.3) + !found Sc cloud and cloud not at surface, trigger downdraft if (cloudflg) then @@ -7066,14 +7108,14 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & ! call Poisson(1,NDOWN,kts+1,kte,ENTf,ENTi) - ! entrainent: Ent=Ent0/dz*P(dz/L0) - do i=1,NDOWN - do k=kts+1,kte -! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k)) - ENT(k,i) = 0.002 - ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) - enddo - enddo +! ! entrainent: Ent=Ent0/dz*P(dz/L0) +! do i=1,NDOWN +! do k=kts+1,kte +!! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k)) +! ENT(k,i) = 0.002 +! ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) +! enddo +! enddo !!![EW: INVJUMP] find 700mb height then subtract trpospheric lapse rate!!! p700_ind = MINLOC(ABS(p-70000),1)!p1D is 70000 @@ -7116,8 +7158,10 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & !DOWNW(ki,I)=0.5*(wlv+wtv) DOWNW(ki,I)=wlv + !multiply downa by cloud fraction, so it's impact will diminish if + !clouds are mixed away over the course of the longer radiation time step !DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW)) - DOWNA(ki,I)=.1/real(NDOWN) + DOWNA(ki,I)=Adn/real(NDOWN) DOWNU(ki,I)=(u(ki-1)*DZ(ki) + u(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) DOWNV(ki,I)=(v(ki-1)*DZ(ki) + v(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) @@ -7144,16 +7188,21 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & enddo - !print*, " Begin integration of downdrafts:" DO I=1,NDOWN + dp = 500. + dl*real(I) ! diameter of plume (meters) !print *, "Plume # =", I,"=======================" DO k=DD_initK(I)-1,KTS+1,-1 + + !Entrainment from Tian and Kuang (2016), with constraints + wmin = 0.3 + dp*0.0005 + ENT(k,i) = 0.33/(MIN(MAX(-1.0*DOWNW(k+1,I),wmin),0.9)*dp) + !starting at the first interface level below cloud top !EntExp=exp(-ENT(K,I)*dz(k)) !EntExp_M=exp(-ENT(K,I)/3.*dz(k)) - EntExp =ENT(K,I)*dz(k) - EntExp_M=ENT(K,I)*0.333*dz(k) + EntExp =ENT(K,I)*dz(k) !for all scalars + EntExp_M=ENT(K,I)*0.333*dz(k) !test for momentum QTn =DOWNQT(k+1,I) *(1.-EntExp) + QT(k)*EntExp THLn=DOWNTHL(k+1,I)*(1.-EntExp) + THL(k)*EntExp @@ -7187,11 +7236,11 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & BCOEFF*B/mindownw)*MIN(dz(k), 250.) !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 < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0))THEN - Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0) + !Add max acceleration of -2.0 m/s for coarse vertical resolution. + IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0))THEN + Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0) ENDIF - !Add symmetrical max decrease in w + !Add symmetrical max decrease in velocity (less negative) IF (Wn > DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0))THEN Wn = DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0) ENDIF @@ -7237,7 +7286,6 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & ! Even though downdraft starts at different height, average all up to qlTop DO k=qlTop,KTS,-1 DO I=1,NDOWN - IF (I > NDOWN) exit edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I) edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I) edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I) @@ -7287,8 +7335,8 @@ SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) ! Psig_bl tapers local mixing ! Psig_shcu tapers nonlocal mixing - real(kind_phys), INTENT(IN) :: dx,pbl1 - real(kind_phys), INTENT(OUT) :: Psig_bl,Psig_shcu + real(kind_phys), intent(in) :: dx,pbl1 + real(kind_phys), intent(out) :: Psig_bl,Psig_shcu real(kind_phys) :: dxdh Psig_bl=1.0 @@ -7361,28 +7409,28 @@ FUNCTION esat_blend(t) IMPLICIT NONE - real(kind_phys), INTENT(IN):: t + real(kind_phys), intent(in):: t real(kind_phys):: esat_blend,XC,ESL,ESI,chi !liquid - real(kind_phys), PARAMETER:: J0= .611583699E03 - real(kind_phys), PARAMETER:: J1= .444606896E02 - real(kind_phys), PARAMETER:: J2= .143177157E01 - real(kind_phys), PARAMETER:: J3= .264224321E-1 - real(kind_phys), PARAMETER:: J4= .299291081E-3 - real(kind_phys), PARAMETER:: J5= .203154182E-5 - real(kind_phys), PARAMETER:: J6= .702620698E-8 - real(kind_phys), PARAMETER:: J7= .379534310E-11 - real(kind_phys), PARAMETER:: J8=-.321582393E-13 + real(kind_phys), parameter:: J0= .611583699E03 + real(kind_phys), parameter:: J1= .444606896E02 + real(kind_phys), parameter:: J2= .143177157E01 + real(kind_phys), parameter:: J3= .264224321E-1 + real(kind_phys), parameter:: J4= .299291081E-3 + real(kind_phys), parameter:: J5= .203154182E-5 + real(kind_phys), parameter:: J6= .702620698E-8 + real(kind_phys), parameter:: J7= .379534310E-11 + real(kind_phys), parameter:: J8=-.321582393E-13 !ice - real(kind_phys), PARAMETER:: K0= .609868993E03 - real(kind_phys), PARAMETER:: K1= .499320233E02 - real(kind_phys), PARAMETER:: K2= .184672631E01 - real(kind_phys), PARAMETER:: K3= .402737184E-1 - real(kind_phys), PARAMETER:: K4= .565392987E-3 - real(kind_phys), PARAMETER:: K5= .521693933E-5 - real(kind_phys), PARAMETER:: K6= .307839583E-7 - real(kind_phys), PARAMETER:: K7= .105785160E-9 - real(kind_phys), PARAMETER:: K8= .161444444E-12 + real(kind_phys), parameter:: K0= .609868993E03 + real(kind_phys), parameter:: K1= .499320233E02 + real(kind_phys), parameter:: K2= .184672631E01 + real(kind_phys), parameter:: K3= .402737184E-1 + real(kind_phys), parameter:: K4= .565392987E-3 + real(kind_phys), parameter:: K5= .521693933E-5 + real(kind_phys), parameter:: K6= .307839583E-7 + real(kind_phys), parameter:: K7= .105785160E-9 + real(kind_phys), parameter:: K8= .161444444E-12 XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240 @@ -7412,28 +7460,28 @@ FUNCTION qsat_blend(t, P) IMPLICIT NONE - real(kind_phys), INTENT(IN):: t, P + real(kind_phys), intent(in):: t, P real(kind_phys):: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi !liquid - real(kind_phys), PARAMETER:: J0= .611583699E03 - real(kind_phys), PARAMETER:: J1= .444606896E02 - real(kind_phys), PARAMETER:: J2= .143177157E01 - real(kind_phys), PARAMETER:: J3= .264224321E-1 - real(kind_phys), PARAMETER:: J4= .299291081E-3 - real(kind_phys), PARAMETER:: J5= .203154182E-5 - real(kind_phys), PARAMETER:: J6= .702620698E-8 - real(kind_phys), PARAMETER:: J7= .379534310E-11 - real(kind_phys), PARAMETER:: J8=-.321582393E-13 + real(kind_phys), parameter:: J0= .611583699E03 + real(kind_phys), parameter:: J1= .444606896E02 + real(kind_phys), parameter:: J2= .143177157E01 + real(kind_phys), parameter:: J3= .264224321E-1 + real(kind_phys), parameter:: J4= .299291081E-3 + real(kind_phys), parameter:: J5= .203154182E-5 + real(kind_phys), parameter:: J6= .702620698E-8 + real(kind_phys), parameter:: J7= .379534310E-11 + real(kind_phys), parameter:: J8=-.321582393E-13 !ice - real(kind_phys), PARAMETER:: K0= .609868993E03 - real(kind_phys), PARAMETER:: K1= .499320233E02 - real(kind_phys), PARAMETER:: K2= .184672631E01 - real(kind_phys), PARAMETER:: K3= .402737184E-1 - real(kind_phys), PARAMETER:: K4= .565392987E-3 - real(kind_phys), PARAMETER:: K5= .521693933E-5 - real(kind_phys), PARAMETER:: K6= .307839583E-7 - real(kind_phys), PARAMETER:: K7= .105785160E-9 - real(kind_phys), PARAMETER:: K8= .161444444E-12 + real(kind_phys), parameter:: K0= .609868993E03 + real(kind_phys), parameter:: K1= .499320233E02 + real(kind_phys), parameter:: K2= .184672631E01 + real(kind_phys), parameter:: K3= .402737184E-1 + real(kind_phys), parameter:: K4= .565392987E-3 + real(kind_phys), parameter:: K5= .521693933E-5 + real(kind_phys), parameter:: K6= .307839583E-7 + real(kind_phys), parameter:: K7= .105785160E-9 + real(kind_phys), parameter:: K8= .161444444E-12 XC=MAX(-80.,t - t0c) @@ -7470,7 +7518,7 @@ FUNCTION xl_blend(t) IMPLICIT NONE - real(kind_phys), INTENT(IN):: t + real(kind_phys), intent(in):: t real(kind_phys):: xl_blend,xlvt,xlst,chi !note: t0c = 273.15, tice is set in mynn_common @@ -7499,11 +7547,11 @@ FUNCTION phim(zet) ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE - real(kind_phys), INTENT(IN):: zet + real(kind_phys), intent(in):: zet real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - real(kind_phys), PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - real(kind_phys), PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - real(kind_phys), PARAMETER :: am_unst=10., ah_unst=34. + real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), parameter :: am_unst=10., ah_unst=34. real(kind_phys):: phi_m,phim if ( zet >= 0.0 ) then @@ -7551,11 +7599,11 @@ FUNCTION phih(zet) ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE - real(kind_phys), INTENT(IN):: zet + real(kind_phys), intent(in):: zet real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - real(kind_phys), PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - real(kind_phys), PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - real(kind_phys), PARAMETER :: am_unst=10., ah_unst=34. + real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), parameter :: am_unst=10., ah_unst=34. real(kind_phys):: phh,phih if ( zet >= 0.0 ) then diff --git a/physics/mynnedmf_wrapper.F90 b/physics/PBL/MYNN_EDMF/mynnedmf_wrapper.F90 similarity index 97% rename from physics/mynnedmf_wrapper.F90 rename to physics/PBL/MYNN_EDMF/mynnedmf_wrapper.F90 index 3c7de235f..487753027 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/PBL/MYNN_EDMF/mynnedmf_wrapper.F90 @@ -131,7 +131,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & edmf_a,edmf_w,edmf_qt, & & edmf_thl,edmf_ent,edmf_qc, & & sub_thl,sub_sqv,det_thl,det_sqv,& - & nupdraft,maxMF,ktop_plume, & + & maxwidth,maxMF,ztop_plume, & + & ktop_plume, & & dudt, dvdt, dtdt, & & dqdt_water_vapor, dqdt_liquid_cloud, & ! <=== ntqv, ntcw & dqdt_ice, dqdt_snow, & ! <=== ntiw, ntsw @@ -310,9 +311,9 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind_phys), dimension(:), intent(out) :: & & ch,dtsfc1,dqsfc1,dusfc1,dvsfc1, & & dtsfci_diag,dqsfci_diag,dusfci_diag,dvsfci_diag, & - & maxMF + & maxMF,maxwidth,ztop_plume integer, dimension(:), intent(inout) :: & - & kpbl,nupdraft,ktop_plume + & kpbl,ktop_plume real(kind_phys), dimension(:), intent(inout) :: & & dusfc_cpl,dvsfc_cpl,dtsfc_cpl,dqsfc_cpl @@ -325,6 +326,7 @@ SUBROUTINE mynnedmf_wrapper_run( & integer :: idtend real(kind_phys), dimension(im) :: dusfci1,dvsfci1,dtsfci1,dqsfci1 real(kind_phys), allocatable :: save_qke_adv(:,:) + real(kind_phys), dimension(levs) :: kzero ! Initialize CCPP error handling variables errmsg = '' @@ -355,6 +357,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !print*,"in MYNN, initflag=",initflag endif + kzero = zero !generic zero array !initialize arrays for test EMIS_ANT_NO = 0. @@ -391,7 +394,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .true. FLAG_QC = .true. FLAG_QNC= .true. - FLAG_QS = .false. !.true. + FLAG_QS = .true. FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field? FLAG_QNIFA= .false. FLAG_QNBCA= .false. @@ -400,7 +403,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = 0.0 !qgrs_snow(i,k) + sqs(i,k) = qgrs_snow(i,k) ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) @@ -418,7 +421,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. - FLAG_QS = .false. + FLAG_QS = .true. !pipe it in, but do not mix FLAG_QNC= .true. FLAG_QNWFA= .true. FLAG_QNIFA= .true. @@ -428,7 +431,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = 0. !qgrs_snow(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -441,7 +444,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. - FLAG_QS = .false. + FLAG_QS = .true. FLAG_QNC= .true. FLAG_QNWFA= .false. FLAG_QNIFA= .false. @@ -451,7 +454,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = 0. !qgrs_snow(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -464,7 +467,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. - FLAG_QS = .false. + FLAG_QS = .true. FLAG_QNC= .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. @@ -474,7 +477,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = 0. !qgrs_snow(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = 0. qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -565,7 +568,7 @@ SUBROUTINE mynnedmf_wrapper_run( & call moisture_check2(levs, delt, & delp(i,:), exner(i,:), & sqv(i,:), sqc(i,:), & - sqi(i,:), sqs(i,:), & + sqi(i,:), kzero(:), & t3d(i,:) ) enddo @@ -748,7 +751,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc,& !output & sub_thl3D=sub_thl,sub_sqv3D=sub_sqv, & & det_thl3D=det_thl,det_sqv3D=det_sqv, & - & nupdraft=nupdraft,maxMF=maxMF, & !output + & maxwidth=maxwidth,maxMF=maxMF,ztop_plume=ztop_plume,& !output & ktop_plume=ktop_plume, & !output & spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl, & !input & RTHRATEN=htrlw, & !input @@ -834,7 +837,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 dqdt_water_aer_num_conc(i,k) = RQNWFABLTEN(i,k) dqdt_ice_aer_num_conc(i,k) = RQNIFABLTEN(i,k) @@ -869,7 +872,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) enddo enddo if(ldiag3d .and. .not. flag_for_pbl_generic_tend) then @@ -887,7 +890,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 enddo enddo @@ -917,7 +920,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - !dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) IF ( nssl_ccn_on ) THEN ! dqdt_cccn(i,k) = RQNWFABLTEN(i,k) ENDIF @@ -1005,8 +1008,8 @@ SUBROUTINE mynnedmf_wrapper_run( & print*,"dudt:",dudt(1,1),dudt(1,2),dudt(1,levs) print*,"dvdt:",dvdt(1,1),dvdt(1,2),dvdt(1,levs) print*,"dqdt:",dqdt_water_vapor(1,1),dqdt_water_vapor(1,2),dqdt_water_vapor(1,levs) - print*,"ktop_plume:",ktop_plume(1)," maxmf:",maxmf(1) - print*,"nup:",nupdraft(1) + print*,"ztop_plume:",ztop_plume(1)," maxmf:",maxmf(1) + print*,"maxwidth:",maxwidth(1) print* endif diff --git a/physics/mynnedmf_wrapper.meta b/physics/PBL/MYNN_EDMF/mynnedmf_wrapper.meta similarity index 98% rename from physics/mynnedmf_wrapper.meta rename to physics/PBL/MYNN_EDMF/mynnedmf_wrapper.meta index ec4706aba..00589dfe5 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/PBL/MYNN_EDMF/mynnedmf_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mynnedmf_wrapper type = scheme - dependencies = machine.F,module_bl_mynn.F90,physcons.F90,bl_mynn_common.f90 + dependencies = ../../hooks/machine.F,module_bl_mynn.F90,bl_mynn_common.f90 ######################################################################## [ccpp-arg-table] @@ -964,13 +964,14 @@ type = real kind = kind_phys intent = inout -[nupdraft] - standard_name = number_of_plumes - long_name = number of plumes per grid column - units = count +[maxwidth] + standard_name = maximum_width_of_plumes + long_name = maximum width of plumes per grid column + units = m dimensions = (horizontal_loop_extent) - type = integer - intent = inout + type = real + kind = kind_phys + intent = out [maxMF] standard_name = maximum_mass_flux long_name = maximum mass flux within a column @@ -979,6 +980,14 @@ type = real kind = kind_phys intent = out +[ztop_plume] + standard_name = height_of_tallest_plume_in_a_column + long_name = height of tallest plume in a column + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [ktop_plume] standard_name = k_level_of_highest_plume long_name = k-level of highest plume diff --git a/physics/mfscu.f b/physics/PBL/SATMEDMF/mfscu.f similarity index 100% rename from physics/mfscu.f rename to physics/PBL/SATMEDMF/mfscu.f diff --git a/physics/mfscuq.f b/physics/PBL/SATMEDMF/mfscuq.f similarity index 100% rename from physics/mfscuq.f rename to physics/PBL/SATMEDMF/mfscuq.f diff --git a/physics/satmedmfvdif.F b/physics/PBL/SATMEDMF/satmedmfvdif.F similarity index 100% rename from physics/satmedmfvdif.F rename to physics/PBL/SATMEDMF/satmedmfvdif.F diff --git a/physics/satmedmfvdif.meta b/physics/PBL/SATMEDMF/satmedmfvdif.meta similarity index 99% rename from physics/satmedmfvdif.meta rename to physics/PBL/SATMEDMF/satmedmfvdif.meta index 3609ed50f..b94e74d6c 100644 --- a/physics/satmedmfvdif.meta +++ b/physics/PBL/SATMEDMF/satmedmfvdif.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = satmedmfvdif type = scheme - dependencies = funcphys.f90,machine.F,mfpblt.f,mfscu.f,tridi.f + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../mfpblt.f,mfscu.f,../tridi.f ######################################################################## [ccpp-arg-table] diff --git a/physics/satmedmfvdifq.F b/physics/PBL/SATMEDMF/satmedmfvdifq.F similarity index 100% rename from physics/satmedmfvdifq.F rename to physics/PBL/SATMEDMF/satmedmfvdifq.F diff --git a/physics/satmedmfvdifq.meta b/physics/PBL/SATMEDMF/satmedmfvdifq.meta similarity index 99% rename from physics/satmedmfvdifq.meta rename to physics/PBL/SATMEDMF/satmedmfvdifq.meta index b6680dccb..ff718f138 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/PBL/SATMEDMF/satmedmfvdifq.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = satmedmfvdifq type = scheme - dependencies = funcphys.f90,machine.F,mfpbltq.f,mfscuq.f,tridi.f + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../mfpbltq.f,mfscuq.f,../tridi.f ######################################################################## [ccpp-arg-table] diff --git a/physics/moninshoc.f b/physics/PBL/SHOC/moninshoc.f similarity index 100% rename from physics/moninshoc.f rename to physics/PBL/SHOC/moninshoc.f diff --git a/physics/moninshoc.meta b/physics/PBL/SHOC/moninshoc.meta similarity index 99% rename from physics/moninshoc.meta rename to physics/PBL/SHOC/moninshoc.meta index dca5736f5..474689ea0 100644 --- a/physics/moninshoc.meta +++ b/physics/PBL/SHOC/moninshoc.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = moninshoc type = scheme - dependencies = funcphys.f90,machine.F,mfpbl.f,tridi.f + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../mfpbl.f,../tridi.f ######################################################################## [ccpp-arg-table] diff --git a/physics/shoc.F90 b/physics/PBL/SHOC/shoc.F90 similarity index 100% rename from physics/shoc.F90 rename to physics/PBL/SHOC/shoc.F90 diff --git a/physics/shoc.meta b/physics/PBL/SHOC/shoc.meta similarity index 99% rename from physics/shoc.meta rename to physics/PBL/SHOC/shoc.meta index 984c6aec5..a1550ce11 100644 --- a/physics/shoc.meta +++ b/physics/PBL/SHOC/shoc.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = shoc type = scheme - dependencies = funcphys.f90,machine.F + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/ysuvdif.F90 b/physics/PBL/YSU/ysuvdif.F90 similarity index 100% rename from physics/ysuvdif.F90 rename to physics/PBL/YSU/ysuvdif.F90 diff --git a/physics/ysuvdif.meta b/physics/PBL/YSU/ysuvdif.meta similarity index 99% rename from physics/ysuvdif.meta rename to physics/PBL/YSU/ysuvdif.meta index 0007197bd..20e96a92d 100644 --- a/physics/ysuvdif.meta +++ b/physics/PBL/YSU/ysuvdif.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = ysuvdif type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/mfpbl.f b/physics/PBL/mfpbl.f similarity index 100% rename from physics/mfpbl.f rename to physics/PBL/mfpbl.f diff --git a/physics/mfpblt.f b/physics/PBL/mfpblt.f similarity index 100% rename from physics/mfpblt.f rename to physics/PBL/mfpblt.f diff --git a/physics/mfpbltq.f b/physics/PBL/mfpbltq.f similarity index 100% rename from physics/mfpbltq.f rename to physics/PBL/mfpbltq.f diff --git a/physics/shinhongvdif.F90 b/physics/PBL/saYSU/shinhongvdif.F90 similarity index 100% rename from physics/shinhongvdif.F90 rename to physics/PBL/saYSU/shinhongvdif.F90 diff --git a/physics/shinhongvdif.meta b/physics/PBL/saYSU/shinhongvdif.meta similarity index 99% rename from physics/shinhongvdif.meta rename to physics/PBL/saYSU/shinhongvdif.meta index dcd3b96cd..8b1d48605 100644 --- a/physics/shinhongvdif.meta +++ b/physics/PBL/saYSU/shinhongvdif.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = shinhongvdif type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/tridi.f b/physics/PBL/tridi.f similarity index 100% rename from physics/tridi.f rename to physics/PBL/tridi.f diff --git a/physics/iounitdef.f b/physics/Radiation/RRTMG/iounitdef.f similarity index 100% rename from physics/iounitdef.f rename to physics/Radiation/RRTMG/iounitdef.f diff --git a/physics/module_bfmicrophysics.f b/physics/Radiation/RRTMG/module_bfmicrophysics.f similarity index 100% rename from physics/module_bfmicrophysics.f rename to physics/Radiation/RRTMG/module_bfmicrophysics.f diff --git a/physics/rad_sw_pre.F90 b/physics/Radiation/RRTMG/rad_sw_pre.F90 similarity index 100% rename from physics/rad_sw_pre.F90 rename to physics/Radiation/RRTMG/rad_sw_pre.F90 diff --git a/physics/rad_sw_pre.meta b/physics/Radiation/RRTMG/rad_sw_pre.meta similarity index 96% rename from physics/rad_sw_pre.meta rename to physics/Radiation/RRTMG/rad_sw_pre.meta index ccbdbf74b..9d14c6ffc 100644 --- a/physics/rad_sw_pre.meta +++ b/physics/Radiation/RRTMG/rad_sw_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rad_sw_pre type = scheme - dependencies = iounitdef.f,machine.F + dependencies = iounitdef.f,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/radcons.f90 b/physics/Radiation/RRTMG/radcons.f90 similarity index 100% rename from physics/radcons.f90 rename to physics/Radiation/RRTMG/radcons.f90 diff --git a/physics/radlw_datatb.f b/physics/Radiation/RRTMG/radlw_datatb.f similarity index 100% rename from physics/radlw_datatb.f rename to physics/Radiation/RRTMG/radlw_datatb.f diff --git a/physics/radlw_main.F90 b/physics/Radiation/RRTMG/radlw_main.F90 similarity index 100% rename from physics/radlw_main.F90 rename to physics/Radiation/RRTMG/radlw_main.F90 diff --git a/physics/radlw_main.meta b/physics/Radiation/RRTMG/radlw_main.meta similarity index 99% rename from physics/radlw_main.meta rename to physics/Radiation/RRTMG/radlw_main.meta index 3dccc97b3..f7c80fb20 100644 --- a/physics/radlw_main.meta +++ b/physics/Radiation/RRTMG/radlw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw type = scheme - dependencies = machine.F,mersenne_twister.f,physcons.F90,radlw_datatb.f,radlw_param.f + dependencies = ../../hooks/machine.F,../mersenne_twister.f,../../hooks/physcons.F90,radlw_datatb.f,radlw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/radlw_param.f b/physics/Radiation/RRTMG/radlw_param.f similarity index 100% rename from physics/radlw_param.f rename to physics/Radiation/RRTMG/radlw_param.f diff --git a/physics/radlw_param.meta b/physics/Radiation/RRTMG/radlw_param.meta similarity index 100% rename from physics/radlw_param.meta rename to physics/Radiation/RRTMG/radlw_param.meta diff --git a/physics/radsw_datatb.f b/physics/Radiation/RRTMG/radsw_datatb.f similarity index 100% rename from physics/radsw_datatb.f rename to physics/Radiation/RRTMG/radsw_datatb.f diff --git a/physics/radsw_main.F90 b/physics/Radiation/RRTMG/radsw_main.F90 similarity index 100% rename from physics/radsw_main.F90 rename to physics/Radiation/RRTMG/radsw_main.F90 diff --git a/physics/radsw_main.meta b/physics/Radiation/RRTMG/radsw_main.meta similarity index 99% rename from physics/radsw_main.meta rename to physics/Radiation/RRTMG/radsw_main.meta index 1edb6fcac..2169a26f0 100644 --- a/physics/radsw_main.meta +++ b/physics/Radiation/RRTMG/radsw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw type = scheme - dependencies = machine.F,mersenne_twister.f,physcons.F90,radsw_datatb.f,radsw_param.f + dependencies = ../../hooks/machine.F,../mersenne_twister.f,../../hooks/physcons.F90,radsw_datatb.f,radsw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/radsw_param.f b/physics/Radiation/RRTMG/radsw_param.f similarity index 100% rename from physics/radsw_param.f rename to physics/Radiation/RRTMG/radsw_param.f diff --git a/physics/radsw_param.meta b/physics/Radiation/RRTMG/radsw_param.meta similarity index 100% rename from physics/radsw_param.meta rename to physics/Radiation/RRTMG/radsw_param.meta diff --git a/physics/rrtmg_lw_cloud_optics.F90 b/physics/Radiation/RRTMG/rrtmg_lw_cloud_optics.F90 similarity index 100% rename from physics/rrtmg_lw_cloud_optics.F90 rename to physics/Radiation/RRTMG/rrtmg_lw_cloud_optics.F90 diff --git a/physics/rrtmg_lw_post.F90 b/physics/Radiation/RRTMG/rrtmg_lw_post.F90 similarity index 100% rename from physics/rrtmg_lw_post.F90 rename to physics/Radiation/RRTMG/rrtmg_lw_post.F90 diff --git a/physics/rrtmg_lw_post.meta b/physics/Radiation/RRTMG/rrtmg_lw_post.meta similarity index 99% rename from physics/rrtmg_lw_post.meta rename to physics/Radiation/RRTMG/rrtmg_lw_post.meta index 7f219c24f..6ed7c2365 100644 --- a/physics/rrtmg_lw_post.meta +++ b/physics/Radiation/RRTMG/rrtmg_lw_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/rrtmg_sw_cloud_optics.F90 b/physics/Radiation/RRTMG/rrtmg_sw_cloud_optics.F90 similarity index 100% rename from physics/rrtmg_sw_cloud_optics.F90 rename to physics/Radiation/RRTMG/rrtmg_sw_cloud_optics.F90 diff --git a/physics/rrtmg_sw_post.F90 b/physics/Radiation/RRTMG/rrtmg_sw_post.F90 similarity index 100% rename from physics/rrtmg_sw_post.F90 rename to physics/Radiation/RRTMG/rrtmg_sw_post.F90 diff --git a/physics/rrtmg_sw_post.meta b/physics/Radiation/RRTMG/rrtmg_sw_post.meta similarity index 99% rename from physics/rrtmg_sw_post.meta rename to physics/Radiation/RRTMG/rrtmg_sw_post.meta index 6a9f4efb5..9914051ce 100644 --- a/physics/rrtmg_sw_post.meta +++ b/physics/Radiation/RRTMG/rrtmg_sw_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw_post type = scheme - dependencies = machine.F,radsw_param.f + dependencies = ../../hooks/machine.F,radsw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.F90 similarity index 100% rename from physics/rrtmgp_aerosol_optics.F90 rename to physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.F90 diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.meta similarity index 98% rename from physics/rrtmgp_aerosol_optics.meta rename to physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.meta index cc9eb1cc2..37ec2e9a0 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmgp_aerosol_optics type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radiation_tools.F90 + dependencies = ../../hooks/machine.F,../radiation_aerosols.f,../radiation_tools.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/Radiation/RRTMGP/rrtmgp_lw_cloud_optics.F90 similarity index 100% rename from physics/rrtmgp_lw_cloud_optics.F90 rename to physics/Radiation/RRTMGP/rrtmgp_lw_cloud_optics.F90 diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/Radiation/RRTMGP/rrtmgp_lw_gas_optics.F90 similarity index 100% rename from physics/rrtmgp_lw_gas_optics.F90 rename to physics/Radiation/RRTMGP/rrtmgp_lw_gas_optics.F90 diff --git a/physics/rrtmgp_lw_main.F90 b/physics/Radiation/RRTMGP/rrtmgp_lw_main.F90 similarity index 99% rename from physics/rrtmgp_lw_main.F90 rename to physics/Radiation/RRTMGP/rrtmgp_lw_main.F90 index 67f7f749a..01b25c925 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/Radiation/RRTMGP/rrtmgp_lw_main.F90 @@ -19,7 +19,6 @@ module rrtmgp_lw_main use rrtmgp_lw_gas_optics, only: lw_gas_props,rrtmgp_lw_gas_optics_init use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, abssnow0, & abssnow1, absrain - use module_radiation_gases, only: NF_VGAS, getgases, getozn use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22, & eps, oneminus, ftiny diff --git a/physics/rrtmgp_lw_main.meta b/physics/Radiation/RRTMGP/rrtmgp_lw_main.meta similarity index 98% rename from physics/rrtmgp_lw_main.meta rename to physics/Radiation/RRTMGP/rrtmgp_lw_main.meta index fd96eb14b..572e67d94 100644 --- a/physics/rrtmgp_lw_main.meta +++ b/physics/Radiation/RRTMGP/rrtmgp_lw_main.meta @@ -1,12 +1,13 @@ [ccpp-table-properties] name = rrtmgp_lw_main type = scheme - dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 + dependencies = ../../hooks/machine.F,../radiation_tools.F90,../mersenne_twister.f + dependencies = rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 dependencies = rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 dependencies = rte-rrtmgp/rte/mo_source_functions.F90,rte-rrtmgp/rte/mo_rte_lw.F90,rte-rrtmgp/rte/mo_fluxes.F90 dependencies = rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90, rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 - dependencies = mersenne_twister.f,rrtmgp_sampling.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - dependencies = rrtmgp_lw_gas_optics.F90, rrtmgp_lw_cloud_optics.F90 + dependencies = rrtmgp_lw_gas_optics.F90, rrtmgp_lw_cloud_optics.F90,rrtmgp_sampling.F90 + dependencies = ../../Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.F90 ######################################################################## [ccpp-arg-table] @@ -150,7 +151,7 @@ intent = in [top_at_1] standard_name = flag_for_vertical_ordering_in_radiation - long_name = flag for vertical ordering in radiaiton + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical @@ -638,4 +639,4 @@ units = 1 dimensions = () type = integer - intent = out \ No newline at end of file + intent = out diff --git a/physics/rrtmgp_sampling.F90 b/physics/Radiation/RRTMGP/rrtmgp_sampling.F90 similarity index 100% rename from physics/rrtmgp_sampling.F90 rename to physics/Radiation/RRTMGP/rrtmgp_sampling.F90 diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/Radiation/RRTMGP/rrtmgp_sw_cloud_optics.F90 similarity index 100% rename from physics/rrtmgp_sw_cloud_optics.F90 rename to physics/Radiation/RRTMGP/rrtmgp_sw_cloud_optics.F90 diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/Radiation/RRTMGP/rrtmgp_sw_gas_optics.F90 similarity index 100% rename from physics/rrtmgp_sw_gas_optics.F90 rename to physics/Radiation/RRTMGP/rrtmgp_sw_gas_optics.F90 diff --git a/physics/rrtmgp_sw_main.F90 b/physics/Radiation/RRTMGP/rrtmgp_sw_main.F90 similarity index 100% rename from physics/rrtmgp_sw_main.F90 rename to physics/Radiation/RRTMGP/rrtmgp_sw_main.F90 diff --git a/physics/rrtmgp_sw_main.meta b/physics/Radiation/RRTMGP/rrtmgp_sw_main.meta similarity index 98% rename from physics/rrtmgp_sw_main.meta rename to physics/Radiation/RRTMGP/rrtmgp_sw_main.meta index dbb93a5df..711d01bc1 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/Radiation/RRTMGP/rrtmgp_sw_main.meta @@ -1,12 +1,13 @@ [ccpp-table-properties] name = rrtmgp_sw_main type = scheme - dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 + dependencies = ../../hooks/machine.F,../radiation_tools.F90,../mersenne_twister.f + dependencies = rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 dependencies = rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 dependencies = rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/mo_fluxes.F90 dependencies = rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90, rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 - dependencies = mersenne_twister.f,rrtmgp_sampling.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - dependencies = rrtmgp_sw_gas_optics.F90, rrtmgp_sw_cloud_optics.F90 + dependencies = rrtmgp_sw_gas_optics.F90, rrtmgp_sw_cloud_optics.F90,rrtmgp_sampling.F90 + dependencies = ../../Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/Radiation/RRTMGP/rte-rrtmgp b/physics/Radiation/RRTMGP/rte-rrtmgp new file mode 160000 index 000000000..74a0e098b --- /dev/null +++ b/physics/Radiation/RRTMGP/rte-rrtmgp @@ -0,0 +1 @@ +Subproject commit 74a0e098b2163425e4b5466c2dfcf8ae26d560a5 diff --git a/physics/mersenne_twister.f b/physics/Radiation/mersenne_twister.f similarity index 100% rename from physics/mersenne_twister.f rename to physics/Radiation/mersenne_twister.f diff --git a/physics/radiation_aerosols.f b/physics/Radiation/radiation_aerosols.f similarity index 100% rename from physics/radiation_aerosols.f rename to physics/Radiation/radiation_aerosols.f diff --git a/physics/radiation_astronomy.f b/physics/Radiation/radiation_astronomy.f similarity index 100% rename from physics/radiation_astronomy.f rename to physics/Radiation/radiation_astronomy.f diff --git a/physics/radiation_cloud_overlap.F90 b/physics/Radiation/radiation_cloud_overlap.F90 similarity index 100% rename from physics/radiation_cloud_overlap.F90 rename to physics/Radiation/radiation_cloud_overlap.F90 diff --git a/physics/radiation_clouds.f b/physics/Radiation/radiation_clouds.f similarity index 100% rename from physics/radiation_clouds.f rename to physics/Radiation/radiation_clouds.f diff --git a/physics/radiation_gases.f b/physics/Radiation/radiation_gases.f similarity index 76% rename from physics/radiation_gases.f rename to physics/Radiation/radiation_gases.f index ccc3b598a..4c626b348 100644 --- a/physics/radiation_gases.f +++ b/physics/Radiation/radiation_gases.f @@ -1,17 +1,14 @@ !> \file radiation_gases.f -!! This file contains routines that set up ozone climatological -!! profiles and other constant gas profiles, such as co2, ch4, n2o, -!! o2, and those of cfc gases. All data are entered as mixing ratio -!! by volume, except ozone which is mass mixing ratio (g/g). +!! This file contains routines that set up gas profiles, such as co2, +!! ch4, n2o, o2, and those of cfc gases. All data are entered as mixing +!! ratio by volume ! ========================================================== !!!!! ! 'module_radiation_gases' description !!!!! ! ========================================================== !!!!! ! ! -! set up ozone climatological profiles and other constant gas ! -! profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All ! -! data are entered as mixing ratio by volume, except ozone which is ! -! mass mixing ratio (g/g). ! +! set up constant gas profiles, such as co2, ch4, n2o, o2, and those ! +! of cfc gases. All data are entered as mixing ratio by volume ! ! ! ! in the module, the externally callabe subroutines are : ! ! ! @@ -23,16 +20,10 @@ ! ! ! 'gas_update' -- read in data and update with time ! ! input: ! -! ( iyear, imon, iday, ihour, loz1st, ldoco2, me ) ! +! ( iyear, imon, iday, ihour, ldoco2, me ) ! ! output: ! ! ( errflg, errmsg ) ! ! ! -! 'getozn' -- setup climatological ozone profile ! -! input: ! -! ( prslk,xlat, ! -! IMAX, LM ) ! -! output: ! -! ( o3mmr ) ! ! ! ! 'getgases' -- setup constant gas profiles for LW and SW ! ! input: ! @@ -47,7 +38,6 @@ ! 'module module_iounitdef' in 'iounitdef.f' ! ! ! ! unit used for radiative active gases: ! -! ozone : mass mixing ratio (g/g) ! ! co2 : volume mixing ratio (p/p) ! ! n2o : volume mixing ratio (p/p) ! ! ch4 : volume mixing ratio (p/p) ! @@ -81,15 +71,6 @@ ! seasonal cycle calculations ! ! aug 2011 - y-t hou fix a bug in subr getgases doing vertical ! ! co2 mapping. (for top_at_1 case, not affact opr). ! -! aug 2012 - y-t hou modified subr getozn. moved the if-first ! -! block to subr gas_init to ensure threading safe in ! -! climatology ozone applications. (not affect gfs) ! -! also changed the initialization subr into two parts:! -! 'gas_init' is called at the start of run to set up ! -! module parameters; and 'gas_update' is called within! -! the time loop to check and update data sets. defined! -! the climatology ozone parameters k1oz,k2oz,facoz as ! -! module variables and are set in subr 'gas_update' ! ! nov 2012 - y-t hou modified control parameters thru module ! ! 'physparam'. ! ! jan 2013 - z. janjic/y. hou modified ilon (longitude index) ! @@ -105,10 +86,8 @@ !> \defgroup module_radiation_gases_mod Radiation Gases Module !> @{ -!> This module sets up ozone climatological profiles and other constant -!! gas profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All -!! data are entered as mixing ratio by volume, except ozone which is -!! mass mixing ratio (g/g). +!> This module sets up constant gas profiles, such as co2, ch4, n2o, o2, +!! and those of cfc gases. All data are entered as mixing ratio by volume. !!\image html rad_gas_AGGI.png "Figure 1: Atmospheric radiative forcing, relative to 1750, by long-lived greenhouse gases and the 2016 update of the NOAA Annual Greenhouse Gas Index (AGGI)" !! NOAA Annual Greenhouse Gas Index (AGGI) shows that from 1990 to 2016, !! radiative forcing by long-lived greenhouse gases (LLGHGs) increased by @@ -121,10 +100,6 @@ !!\n ICO2=1: use observed global annual mean value !!\n ICO2=2: use observed monthly 2-d data table in \f$15^o\f$ horizontal resolution !! -!! O3 Distribution (namelist control parameter -\b NTOZ): -!!\n NTOZ=0: use seasonal and zonal averaged climatological ozone -!!\n NTOZ>0: use 3-D prognostic ozone -!! !! Trace Gases (currently using the global mean climatology in unit of ppmv): !! \f$CH_4-1.50\times10^{-6}\f$; !! \f$N_2O-0.31\times10^{-6}\f$; @@ -137,14 +112,11 @@ !! !!\version NCEP-Radiation_gases v5.1 Nov 2012 -!> This module sets up ozone climatological profiles and other constant gas -!! profiles, such as co2, ch4, n2o, o2, and those of cfc gases. +!> This module sets up constant gas rofiles, such as co2, ch4, n2o, o2, and those +!! of cfc gases. module module_radiation_gases use machine, only : kind_phys, kind_io4 use funcphys, only : fpkapx - use ozne_def, only : JMR => latsozc, LOZ => levozc, & - & blte => blatc, dlte=> dphiozc, & - & timeozc => timeozc use module_iounitdef, only : NIO3CLM, NICO2CN ! implicit none @@ -182,22 +154,8 @@ module module_radiation_gases ! gfdl 1999 value real (kind=kind_phys), parameter :: f113vmr_def= 8.2000e-11 -! --- ozone seasonal climatology parameters defined in module ozne_def -! - 4x5 ozone data parameter -! integer, parameter :: JMR=45, LOZ=17 -! real (kind=kind_phys), parameter :: blte=-86.0, dlte=4.0 -! - geos ozone data -! integer, parameter :: JMR=18, LOZ=17 -! real (kind=kind_phys), parameter :: blte=-85.0, dlte=10.0 - ! --- module variables to be set in subroutin gas_init and/or gas_update -! variables for climatology ozone (ioznflg = 0) - - real (kind=kind_phys), allocatable :: pkstr(:), o3r(:,:,:) - integer :: k1oz = 0, k2oz = 0 - real (kind=kind_phys) :: facoz = 0.0 - ! arrays for co2 2-d monthly data and global mean values from observed data real (kind=kind_phys), allocatable :: co2vmr_sav(:,:,:) @@ -212,33 +170,30 @@ module module_radiation_gases ! --- public interfaces - public gas_init, gas_update, getgases, getozn + public gas_init, gas_update, getgases ! ================= contains ! ================= -!> This subroutine sets up ozone, co2, etc. parameters. If climatology -!! ozone then read in monthly ozone data. +!> This subroutine sets up co2, etc. parameters. !!\param me print message control flag !!\param co2usr_file co2 user defined data table !!\param co2cyc_file co2 climotology monthly cycle data table !!\param ictmflg data ic time/date control flag !!\param ico2flg co2 data source control flag -!!\param ioznflg ozone data control flag !!\param con_pi physical constant Pi !!\param errflg error flag !!\param errmsg error message !>\section gas_init_gen gas_init General Algorithm !----------------------------------- subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & - & ictmflg, ioznflg, con_pi, errflg, errmsg) + & ictmflg, con_pi, errflg, errmsg) ! =================================================================== ! ! ! -! gas_init sets up ozone, co2, etc. parameters. if climatology ozone ! -! then read in monthly ozone data. ! +! gas_init sets up co2, etc. parameters. ! ! ! ! inputs: ! ! me - print message control flag ! @@ -259,9 +214,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & ! further data extrapolation. ! ! =yyyy1: use yyyy data for the fcst. if needed, do ! ! extrapolation to match the fcst time. ! -! ioznflg - ozone data control flag ! -! =0: use climatological ozone profile ! -! >0: use interactive ozone profile ! ! co2usr_file - external co2 user defined data table ! ! co2cyc_file - external co2 climotology monthly cycle data table ! ! con_pi - physical constant Pi ! @@ -270,9 +222,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & ! errflg - error flag ! ! errmsg - error message ! ! ! -! internal module variables: ! -! pkstr, o3r - arrays for climatology ozone data ! -! ! ! usage: call gas_init ! ! ! ! subprograms called: none ! @@ -282,9 +231,10 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & implicit none ! --- inputs: - integer, intent(in) :: me, ictmflg, ioznflg, ico2flg + integer, intent(in) :: me, ictmflg, ico2flg character(len=26),intent(in) :: co2usr_file,co2cyc_file real(kind=kind_phys), intent(in) :: con_pi + ! --- output: character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -292,10 +242,7 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & ! --- locals: real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat real (kind=kind_phys) :: co2g1, co2g2 - real (kind=kind_phys) :: pstr(LOZ) - real (kind=kind_io4) :: o3clim4(JMR,LOZ,12), pstr4(LOZ) - integer :: imond(12), ilat(JMR,12) integer :: i, j, k, iyr, imo logical :: file_exist, lextpl character :: cline*100, cform*8 @@ -317,78 +264,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & kyrsav = 0 kmonsav = 1 -! --- ... climatology ozone data section - - if ( ioznflg > 0 ) then - if ( me == 0 ) then - print *,' - Using interactive ozone distribution' - endif - else - if ( timeozc /= 12 ) then - print *,' - Using climatology ozone distribution' - print *,' timeozc=',timeozc, ' is not monthly mean', & - & ' - job aborting in subroutin gas_init!!!' - errflg = 1 - errmsg = 'ERROR(gas_init): Climatological o3 distribution '// & - & 'is not monthly mean' - return - endif - - allocate (pkstr(LOZ), o3r(JMR,LOZ,12)) - rewind NIO3CLM - - if ( LOZ == 17 ) then ! For the operational ozone climatology - do k = 1, LOZ - read (NIO3CLM,15) pstr4(k) - 15 format(f10.3) - enddo - - do imo = 1, 12 - do j = 1, JMR - read (NIO3CLM,16) imond(imo), ilat(j,imo), & - & (o3clim4(j,k,imo),k=1,10) - 16 format(i2,i4,10f6.2) - read (NIO3CLM,20) (o3clim4(j,k,imo),k=11,LOZ) - 20 format(6x,10f6.2) - enddo - enddo - else ! For newer ozone climatology - read (NIO3CLM) - do k = 1, LOZ - read (NIO3CLM) pstr4(k) - enddo - - do imo = 1, 12 - do k = 1, LOZ - read (NIO3CLM) (o3clim4(j,k,imo),j=1,JMR) - enddo - enddo - endif ! end if_LOZ_block -! - do imo = 1, 12 - do k = 1, LOZ - do j = 1, JMR - o3r(j,k,imo) = o3clim4(j,k,imo) * 1.655e-6 - enddo - enddo - enddo - - do k = 1, LOZ - pstr(k) = pstr4(k) - enddo - - if ( me == 0 ) then - print *,' - Using climatology ozone distribution' - print *,' Found ozone data for levels pstr=', & - & (pstr(k),k=1,LOZ) -! print *,' O3=',(o3r(15,k,1),k=1,LOZ) - endif - - do k = 1, LOZ - pkstr(k) = fpkapx(pstr(k)*100.0) - enddo - endif ! end if_ioznflg_block - ! --- ... co2 data section co2_glb = co2vmr_def @@ -542,20 +417,18 @@ end subroutine gas_init !!\param imon month of the year !!\param iday day of the month !!\param ihour hour of the day -!!\param loz1st clim ozone 1st time update control flag !!\param ldoco2 co2 update control flag !!\param me print message control flag !!\param co2dat_file co2 2d monthly obsv data table !!\param co2gbl_file co2 global annual mean data table !!\param ictmflg data ic time/date control flag !!\param ico2flg co2 data source control flag -!!\param ioznflg ozone data control flag !!\param errflg error flag !!\param errmsg error message !>\section gen_gas_update gas_update General Algorithm !----------------------------------- - subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & - & me, co2dat_file, co2gbl_file, ictmflg, ico2flg, ioznflg, & + subroutine gas_update(iyear, imon, iday, ihour, ldoco2, & + & me, co2dat_file, co2gbl_file, ictmflg, ico2flg, & & errflg, errmsg ) ! =================================================================== ! @@ -568,7 +441,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & ! imon - month of the year 1 ! ! iday - day of the month 1 ! ! ihour - hour of the day 1 ! -! loz1st - clim ozone 1st time update control flag 1 ! ! ldoco2 - co2 update control flag 1 ! ! me - print message control flag 1 ! ! ico2flg - co2 data source control flag ! @@ -588,9 +460,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & ! further data extrapolation. ! ! =yyyy1: use yyyy data for the fcst. if needed, do ! ! extrapolation to match the fcst time. ! -! ioznflg - ozone data control flag ! -! =0: use climatological ozone profile ! -! >0: use interactive ozone profile ! ! ivflip - vertical profile indexing flag ! ! co2dat_file - external co2 2d monthly obsv data table ! ! co2gbl_file - external co2 global annual mean data table ! @@ -604,8 +473,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & ! co2cyc_sav - monthly cycle co2 vol mixing ratio IMXCO2*JMXCO2*12 ! ! co2_glb - global annual mean co2 mixing ratio ! ! gco2cyc - global monthly mean co2 variation 12 ! -! k1oz,k2oz,facoz ! -! - climatology ozone parameters 1 ! ! ! ! usage: call gas_update ! ! ! @@ -617,9 +484,8 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & ! --- inputs: integer, intent(in) :: iyear,imon,iday,ihour,me,ictmflg,ico2flg - integer, intent(in) :: ioznflg character(len=26),intent(in) :: co2dat_file, co2gbl_file - logical, intent(in) :: loz1st, ldoco2 + logical, intent(in) :: ldoco2 ! --- output: character(len=*), intent(out) :: errmsg @@ -644,35 +510,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & errmsg = '' errflg = 0 -!> - Ozone data section - - if ( ioznflg == 0 ) then - midmon = mdays(imon)/2 + 1 - change = loz1st .or. ( (iday==midmon) .and. (ihour==0) ) -! - if ( change ) then - if ( iday < midmon ) then - k1oz = mod(imon+10, 12) + 1 - midm = mdays(k1oz)/2 + 1 - k2oz = imon - midp = mdays(k1oz) + midmon - else - k1oz = imon - midm = midmon - k2oz = mod(imon, 12) + 1 - midp = mdays(k2oz)/2 + 1 + mdays(k1oz) - endif - endif -! - if (iday < midmon) then - id = iday + mdays(k1oz) - else - id = iday - endif - - facoz = float(id - midm) / float(midp - midm) - endif - !> - co2 data section if ( ico2flg == 0 ) return ! use prescribed global mean co2 data @@ -1104,119 +941,6 @@ subroutine getgases( plvl, xlon, xlat, IMAX, LMAX, ico2flg, & end subroutine getgases !----------------------------------- -!> This subroutine sets up climatological ozone profile for radiation -!! calculation. This code is originally written by Shrinivas Moorthi. -!!\param prslk (IMAX,LM), exner function = \f$(p/p0)^{rocp}\f$ -!!\param xlat (IMAX), latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param IMAX, LM (1), horizontal and vertical dimensions -!!\param top_at_1 (1), vertical profile indexing flag -!!\param o3mmr (IMAX,LM), output ozone profile in mass mixing -!! ratio (g/g) -!>\section getozn_gen getozn General Algorithm -!----------------------------------- - subroutine getozn( prslk,xlat, IMAX, LM, top_at_1, o3mmr) - -! =================================================================== ! -! ! -! getozn sets up climatological ozone profile for radiation calculation! -! ! -! this code is originally written By Shrinivas Moorthi ! -! ! -! inputs: ! -! prslk (IMAX,LM) - exner function = (p/p0)**rocp ! -! xlat (IMAX) - latitude in radians, default to pi/2 -> -pi/2 ! -! range, otherwise see in-line comment ! -! IMAX, LM - horizontal and vertical dimensions ! -! top_at_1 - vertical profile indexing flag ! -! ! -! outputs: ! -! o3mmr (IMAX,LM) - output ozone profile in mass mixing ratio (g/g)! -! ! -! module variables: ! -! k1oz, k2oz - ozone data interpolation indices ! -! facoz - ozone data interpolation factor ! -! ! -! usage: call getozn ! -! ! -! =================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: IMAX, LM - logical, intent(in) :: top_at_1 - real (kind=kind_phys), intent(in) :: prslk(:,:), xlat(:) - -! --- outputs: - real (kind=kind_phys), intent(out) :: o3mmr(:,:) - -! --- locals: - real (kind=kind_phys) :: o3i(IMAX,LOZ), wk1(IMAX), deglat, elte, & - & tem, tem1, tem2, tem3, tem4, temp - integer :: i, j, k, l, j1, j2, ll -! -!===> ... begin here -! - elte = blte + (JMR-1)*dlte - - do i = 1, IMAX - deglat = xlat(i) * raddeg ! if xlat in pi/2 -> -pi/2 range -! deglat = 90.0 - xlat(i)*raddeg ! if xlat in 0 -> pi range - - if (deglat > blte .and. deglat < elte) then - tem1 = (deglat - blte) / dlte + 1 - j1 = tem1 - j2 = j1 + 1 - tem1 = tem1 - j1 - elseif (deglat <= blte) then - j1 = 1 - j2 = 1 - tem1 = 1.0 - elseif (deglat >= elte) then - j1 = JMR - j2 = JMR - tem1 = 1.0 - endif - - tem2 = 1.0 - tem1 - do j = 1, LOZ - tem3 = tem2*o3r(j1,j,k1oz) + tem1*o3r(j2,j,k1oz) - tem4 = tem2*o3r(j1,j,k2oz) + tem1*o3r(j2,j,k2oz) - o3i(i,j) = tem4*facoz + tem3*(1.0 - facoz) - enddo - enddo - - do l = 1, LM - ll = l - if (.not. top_at_1) ll = LM -l + 1 - - do i = 1, IMAX - wk1(i) = prslk(i,ll) - enddo - - do k = 1, LOZ-1 - temp = 1.0 / (pkstr(k+1) - pkstr(k)) - - do i = 1, IMAX - if (wk1(i) > pkstr(k) .and. wk1(i) <= pkstr(k+1)) then - tem = (pkstr(k+1) - wk1(i)) * temp - o3mmr(I,ll) = tem * o3i(i,k) + (1.0 - tem) * o3i(i,k+1) - endif - enddo - enddo - - do i = 1, IMAX - if (wk1(i) > pkstr(LOZ)) o3mmr(i,ll) = o3i(i,LOZ) - if (wk1(i) < pkstr(1)) o3mmr(i,ll) = o3i(i,1) - enddo - enddo -! - return -!................................... - end subroutine getozn -!----------------------------------- - ! !........................................! end module module_radiation_gases ! diff --git a/physics/radiation_surface.f b/physics/Radiation/radiation_surface.f similarity index 100% rename from physics/radiation_surface.f rename to physics/Radiation/radiation_surface.f diff --git a/physics/radiation_tools.F90 b/physics/Radiation/radiation_tools.F90 similarity index 100% rename from physics/radiation_tools.F90 rename to physics/Radiation/radiation_tools.F90 diff --git a/physics/gfdl_sfc_layer.F90 b/physics/SFC_Layer/GFDL/gfdl_sfc_layer.F90 similarity index 100% rename from physics/gfdl_sfc_layer.F90 rename to physics/SFC_Layer/GFDL/gfdl_sfc_layer.F90 diff --git a/physics/gfdl_sfc_layer.meta b/physics/SFC_Layer/GFDL/gfdl_sfc_layer.meta similarity index 99% rename from physics/gfdl_sfc_layer.meta rename to physics/SFC_Layer/GFDL/gfdl_sfc_layer.meta index f1c7a4ce2..ac98437e9 100644 --- a/physics/gfdl_sfc_layer.meta +++ b/physics/SFC_Layer/GFDL/gfdl_sfc_layer.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = gfdl_sfc_layer type = scheme - dependencies = machine.F,module_sf_exchcoef.f90,namelist_soilveg_ruc.F90,noahmp_tables.f90 + dependencies = ../../hooks/machine.F,module_sf_exchcoef.f90 + dependencies = ../../SFC_Models/Land/RUC/namelist_soilveg_ruc.F90 + dependencies = ../../SFC_Models/Land/Noahmp/noahmp_tables.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/module_sf_exchcoef.f90 b/physics/SFC_Layer/GFDL/module_sf_exchcoef.f90 similarity index 100% rename from physics/module_sf_exchcoef.f90 rename to physics/SFC_Layer/GFDL/module_sf_exchcoef.f90 diff --git a/physics/module_SF_JSFC.F90 b/physics/SFC_Layer/MYJ/module_SF_JSFC.F90 similarity index 100% rename from physics/module_SF_JSFC.F90 rename to physics/SFC_Layer/MYJ/module_SF_JSFC.F90 diff --git a/physics/myjsfc_wrapper.F90 b/physics/SFC_Layer/MYJ/myjsfc_wrapper.F90 similarity index 100% rename from physics/myjsfc_wrapper.F90 rename to physics/SFC_Layer/MYJ/myjsfc_wrapper.F90 diff --git a/physics/myjsfc_wrapper.meta b/physics/SFC_Layer/MYJ/myjsfc_wrapper.meta similarity index 99% rename from physics/myjsfc_wrapper.meta rename to physics/SFC_Layer/MYJ/myjsfc_wrapper.meta index 40b6b78f3..0ae09985e 100644 --- a/physics/myjsfc_wrapper.meta +++ b/physics/SFC_Layer/MYJ/myjsfc_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = myjsfc_wrapper type = scheme - dependencies = module_SF_JSFC.F90 + dependencies = ../../hooks/machine.F,module_SF_JSFC.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/module_sf_mynn.F90 b/physics/SFC_Layer/MYNN/module_sf_mynn.F90 similarity index 89% rename from physics/module_sf_mynn.F90 rename to physics/SFC_Layer/MYNN/module_sf_mynn.F90 index c60247cf6..3d847348d 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/SFC_Layer/MYNN/module_sf_mynn.F90 @@ -26,7 +26,7 @@ MODULE module_sf_mynn ! ! LAND only: ! "iz0tlnd" namelist option is used to select the following momentum options: -! (default) =0: Zilitinkevich (1995); Czil now set to 0.085 +! (default) =0: Zilitinkevich (1995); Czil now set to 0.095 ! =1: Czil_new (modified according to Chen & Zhang 2008) ! =2: Modified Yang et al (2002, 2008) - generalized for all landuse ! =3: constant zt = z0/7.4 (original form; Garratt 1992) @@ -106,6 +106,7 @@ MODULE module_sf_mynn REAL(kind_phys), DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & psih_stab,psih_unstab +!$acc declare create(psim_stab, psim_unstab, psih_stab, psih_unstab) CONTAINS @@ -224,7 +225,7 @@ SUBROUTINE SFCLAY_mynn( & ! (water =1: z0 from Davis et al (2008), zt & zq from COARE3.0/3.5 ! only) =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) ! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5 -!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.085, +!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.095, ! (land =1: Czil_new (modified according to Chen & Zhang 2008) ! only) =2: Modified Yang et al (2002, 2008) - generalized for all landuse ! =3: constant zt = z0/7.4 (Garratt 1992) @@ -371,6 +372,20 @@ SUBROUTINE SFCLAY_mynn( & errflg = 0 errmsg = '' +!$acc enter data copyin( dz8w,U3D,V3D,QV3D,QC3D,P3D,T3D, & +!$acc pattern_spp_sfc) + +!$acc enter data copyin( UST_WAT(:), UST_LND(:), UST_ICE(:), & +!$acc MOL(:), QFLX(:), HFLX(:), & +!$acc QSFC(:), QSFC_WAT(:), QSFC_LND(:), & +!$acc QSFC_ICE(:)) + +!$acc enter data create( dz8w1d(:), dz2w1d(:), U1D(:), & +!$acc V1D(:), U1D2(:), V1D2(:), & +!$acc QV1D(:), QC1D(:), P1D(:), & +!$acc T1D(:), rstoch1D(:), qstar(:)) + + IF (debug_code >= 1) THEN write(*,*)"======= printing of constants:" write(*,*)"cp=", cp," g=", grav @@ -382,6 +397,10 @@ SUBROUTINE SFCLAY_mynn( & itf=ite !MIN0(ite,ide-1) ktf=kte !MIN0(kte,kde-1) +!$acc parallel loop present(dz8w,U3D,V3D,QV3D,QC3D,P3D,T3D, & +!$acc pattern_spp_sfc,dz8w1d,dz2w1d,U1D, & +!$acc V1D,U1D2,V1D2,QV1D,QC1D,P1D,T1D, & +!$acc rstoch1D,qstar) DO i=its,ite dz8w1d(I) = dz8w(i,kts) dz2w1d(I) = dz8w(i,kts+1) @@ -403,6 +422,9 @@ SUBROUTINE SFCLAY_mynn( & ENDDO IF (itimestep==1 .AND. iter==1) THEN +!$acc parallel loop present(U1D,V1D,UST_WAT,UST_LND,UST_ICE,MOL, & +!$acc QFLX,HFLX,QV3D,QSFC,QSFC_WAT, & +!$acc QSFC_LND,QSFC_ICE) DO i=its,ite IF (.not. flag_restart) THEN !Everything here is used before calculated @@ -432,6 +454,9 @@ SUBROUTINE SFCLAY_mynn( & ENDDO ENDIF +!$acc exit data delete( dz8w,U3D,V3D,QV3D,QC3D,P3D,T3D, & +!$acc pattern_spp_sfc, QC1D) + CALL SFCLAY1D_mynn(flag_iter, & J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & U1D2,V1D2,dz2w1d, & @@ -471,6 +496,16 @@ SUBROUTINE SFCLAY_mynn( & its,ite, jts,jte, kts,kte, & errmsg, errflg ) +!$acc exit data copyout( UST_WAT(:), UST_LND(:), UST_ICE(:), & +!$acc MOL(:), QFLX(:), HFLX(:), & +!$acc QSFC(:), QSFC_WAT(:), QSFC_LND(:), & +!$acc QSFC_ICE(:)) + +!$acc exit data delete( dz8w1d(:), dz2w1d(:), U1D(:), & +!$acc V1D(:), U1D2(:), V1D2(:), & +!$acc QV1D(:), T1D(:), P1D(:), & +!$acc rstoch1D(:), qstar(:)) + END SUBROUTINE SFCLAY_MYNN !------------------------------------------------------------------- @@ -629,6 +664,22 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg +! Local fixed-size errmsg character array for error messages on accelerator +! devices distinct from the host (e.g. GPUs). Necessary since OpenACC does +! not support assumed-size (len=*) arrays like errmsg. Additional +! device_errflg integer to denote when device_errmsg needs to be synced +! with errmsg. + character(len=512) :: device_errmsg + integer :: device_errflg + +! Special versions of the fixed-size errmsg character array for error messages +! on the device and it's errflag counterpart. These are necessary to ensure +! the return statements at lines 1417 and 2030 are executed only for this +! special case, and not any and all error messages set on the device. + character(len=512) :: device_special_errmsg + integer :: device_special_errflg + + !---------------------------------------------------------------- ! LOCAL VARS !---------------------------------------------------------------- @@ -678,7 +729,65 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! Initialize error-handling errflg = 0 errmsg = '' + device_errflg = errflg + device_errmsg = errmsg + device_special_errflg = errflg + device_special_errmsg = errmsg !------------------------------------------------------------------- +!$acc update device(psim_stab, psim_unstab, psih_stab, psih_unstab) + +!$acc enter data create( ZA, ZA2, THV1D, TH1D, TC1D, TV1D, & +!$acc RHO1D, QVSH, PSIH2, PSIM10, PSIH10, WSPDI, & +!$acc GOVRTH, PSFC, THCON, & +!$acc zratio_lnd, zratio_ice, zratio_wat, & +!$acc TSK_lnd, TSK_ice, TSK_wat, & +!$acc THSK_lnd, THSK_ice, THSK_wat, & +!$acc THVSK_lnd, THVSK_ice, THVSK_wat, & +!$acc GZ1OZ0_lnd, GZ1OZ0_ice, GZ1OZ0_wat, & +!$acc GZ1OZt_lnd, GZ1OZt_ice, GZ1OZt_wat, & +!$acc GZ2OZ0_lnd, GZ2OZ0_ice, GZ2OZ0_wat, & +!$acc GZ2OZt_lnd, GZ2OZt_ice, GZ2OZt_wat, & +!$acc GZ10OZ0_lnd, GZ10OZ0_ice, GZ10OZ0_wat, & +!$acc GZ10OZt_lnd, GZ10OZt_ice, GZ10OZt_wat, & +!$acc ZNTstoch_lnd, ZNTstoch_ice, ZNTstoch_wat, & +!$acc ZT_lnd, ZT_ice, ZT_wat, & +!$acc ZQ_lnd, ZQ_ice, ZQ_wat, & +!$acc PSIQ_lnd, PSIQ_ice, PSIQ_wat, & +!$acc PSIQ2_lnd, PSIQ2_ice, PSIQ2_wat, & +!$acc QSFCMR_lnd, QSFCMR_ice, QSFCMR_wat ) + +!$acc enter data copyin(flag_iter, dry, wet, icy, CPM, MAVAIL, & +!$acc QFX, FLHC, FLQC, CHS, CH, CHS2, CQS2, USTM, & +!$acc HFX, LH, wstar, qstar, PBLH, ZOL, MOL, RMOL, & +!$acc T2, TH2, Q2, QV1D, PSFCPA, & +!$acc WSPD, U10, V10, U1D, V1D, U1D2, V1D2, & +!$acc T1D, P1D, rstoch1D, sigmaf, & +!$acc shdmax, vegtype, z0pert, ztpert, dx, QGH, & +!$acc dz2w1d, dz8w1d, & +!$acc stress_wat, stress_lnd, stress_ice, & +!$acc rb_wat, rb_lnd, rb_ice, & +!$acc tskin_wat, tskin_lnd, tskin_ice, & +!$acc tsurf_wat, tsurf_lnd, tsurf_ice, & +!$acc psim, psih, & +!$acc UST_wat, UST_lnd, UST_ice, & +!$acc ZNT_wat, ZNT_lnd, ZNT_ice, & +!$acc QSFC, QSFC_lnd, QSFC_wat, QSFC_ice, & +!$acc QFLX, QFLX_lnd, QFLX_wat, QFLX_ice, & +!$acc HFLX, HFLX_lnd, HFLX_wat, HFLX_ice, & +!$acc PSIX_wat, PSIX_lnd, PSIX_ice, & +!$acc PSIX10_wat, PSIX10_lnd, PSIX10_ice, & +!$acc PSIT2_lnd, PSIT2_wat, PSIT2_ice, & +!$acc PSIT_lnd, PSIT_wat, PSIT_ice, & +!$acc ch_lnd, ch_wat, ch_ice, & +!$acc cm_lnd, cm_wat, cm_ice, & +!$acc snowh_lnd, snowh_wat, snowh_ice, & +!$acc device_errmsg, device_errflg, & +!$acc device_special_errmsg, device_special_errflg) + +!$acc parallel loop present(PSFCPA, PSFC, QSFC, T1D, flag_iter, tsurf_lnd, & +!$acc QSFC_wat, QSFCMR_wat, wet, TSK_wat, tskin_wat, & +!$acc QSFC_lnd, QSFCMR_lnd, dry, TSK_lnd, tskin_lnd, & +!$acc QSFC_ice, QSFCMR_ice, icy, TSK_ice, tskin_ice) DO I=its,ite ! PSFC ( in cmb) is used later in saturation checks @@ -791,6 +900,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif ! flag_iter ENDDO +!$acc serial present(pblh, PSFCPA, dz8w1d, qflx, hflx, & +!$acc dry, tskin_lnd, tsurf_lnd, qsfc_lnd, znt_lnd, ust_lnd, snowh_lnd, & +!$acc icy, tskin_ice, tsurf_ice, qsfc_ice, znt_ice, ust_ice, snowh_ice, & +!$acc wet, tskin_wat, tsurf_wat, qsfc_wat, znt_wat, ust_wat, snowh_wat) IF (debug_code >= 1) THEN write(0,*)"ITIMESTEP=",ITIMESTEP," iter=",iter DO I=its,ite @@ -815,7 +928,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF ENDDO ENDIF +!$acc end serial +!$acc parallel loop present(PSFC, PSFCPA, QVSH, QV1D, THCON, flag_iter, & +!$acc dry, tskin_lnd, TSK_lnd, tsurf_lnd, THSK_lnd, THVSK_lnd, qsfc_lnd, & +!$acc icy, tskin_ice, TSK_ice, tsurf_ice, THSK_ice, THVSK_ice, qsfc_ice, & +!$acc wet, tskin_wat, TSK_wat, tsurf_wat, THSK_wat, THVSK_wat, qsfc_wat) DO I=its,ite ! PSFC ( in cmb) is used later in saturation checks PSFC(I)=PSFCPA(I)/1000. @@ -829,7 +947,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_lnd(I) = TSK_lnd(I)*THCON(I) !(K) THVSK_lnd(I) = THSK_lnd(I)*(1.+EP1*qsfc_lnd(I)) - if(THVSK_lnd(I) < 170. .or. THVSK_lnd(I) > 360.) & + if(THVSK_lnd(I) < 160. .or. THVSK_lnd(I) > 390.) & print *,'THVSK_lnd(I)',itimestep,i,THVSK_lnd(I),THSK_lnd(i),tsurf_lnd(i),tskin_lnd(i),qsfc_lnd(i) endif if(icy(i)) then @@ -838,7 +956,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_ice(I) = TSK_ice(I)*THCON(I) !(K) THVSK_ice(I) = THSK_ice(I)*(1.+EP1*qsfc_ice(I)) !(K) - if(THVSK_ice(I) < 170. .or. THVSK_ice(I) > 360.) & + if(THVSK_ice(I) < 160. .or. THVSK_ice(I) > 390.) & print *,'THVSK_ice(I)',itimestep,i,THVSK_ice(I),THSK_ice(i),tsurf_ice(i),tskin_ice(i),qsfc_ice(i) endif if(wet(i)) then @@ -847,24 +965,27 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_wat(I) = TSK_wat(I)*THCON(I) !(K) THVSK_wat(I) = THSK_wat(I)*(1.+EP1*QVSH(I)) !(K) - if(THVSK_wat(I) < 170. .or. THVSK_wat(I) > 360.) & + if(THVSK_wat(I) < 160. .or. THVSK_wat(I) > 390.) & print *,'THVSK_wat(I)',i,THVSK_wat(I),THSK_wat(i),tsurf_wat(i),tskin_wat(i),qsfc_wat(i) endif endif ! flag_iter ENDDO +!$acc parallel loop present(TH1D, T1D, P1D, TC1D) DO I=its,ite ! CONVERT LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: TH1D(I)=T1D(I)*(100000./P1D(I))**ROVCP !(Theta, K) TC1D(I)=T1D(I)-273.15 !(T, Celsius) ENDDO +!$acc parallel loop present(THV1D, TH1D, QVSH, TV1D, T1D) DO I=its,ite ! CONVERT TO VIRTUAL TEMPERATURE THV1D(I)=TH1D(I)*(1.+EP1*QVSH(I)) !(K) TV1D(I)=T1D(I)*(1.+EP1*QVSH(I)) !(K) ENDDO +!$acc parallel loop present(RHO1D, P1D, TV1D, TH1D, ZA, ZA2, dz2w1d, dz8w1d, GOVRTH) DO I=its,ite RHO1D(I)=P1D(I)/(Rd*TV1D(I)) !now using value calculated in sfc driver ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level @@ -873,11 +994,16 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO !tgs - should QFX and HFX be separate for land, ice and water? +!$acc parallel loop present(QFX, QFLX, RHO1D, HFX, HFLX) DO I=its,ite QFX(i)=QFLX(i)*RHO1D(I) HFX(i)=HFLX(i)*RHO1D(I)*cp ENDDO +!$acc serial present(THV1D, TV1D, RHO1D, GOVRTH, & +!$acc dry, tsk_lnd, thvsk_lnd, & +!$acc icy, tsk_ice, thvsk_ice, & +!$acc wet, tsk_wat, thvsk_wat) IF (debug_code ==2) THEN !write(*,*)"ITIMESTEP=",ITIMESTEP DO I=its,ite @@ -890,7 +1016,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & write(*,*)"RHO1D=", RHO1D(i)," GOVRTH=",GOVRTH(i) ENDDO ENDIF +!$acc end serial +!$acc parallel loop present(T1D,P1D,QGH,QV1D,CPM) DO I=its,ite ! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP ! Q2SAT = QGH IN LSM @@ -908,6 +1036,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & CPM(I)=CP*(1.+0.84*QV1D(I)) ENDDO +!$acc serial present(QGH, & +!$acc wet, QSFC_wat, QSFCMR_wat, & +!$acc dry, QSFC_lnd, QSFCMR_lnd, & +!$acc icy, QSFC_ice, QSFCMR_ice) IF (debug_code == 2) THEN write(*,*)"ITIMESTEP=",ITIMESTEP DO I=its,ite @@ -925,7 +1057,13 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif ENDDO ENDIF +!$acc end serial +!$acc parallel loop present(flag_iter,U1D,V1D,WSPD,wet,dry,icy, & +!$acc THV1D,THVSK_wat,THVSK_lnd,THVSK_ice, & +!$acc hfx,RHO1D,qfx,WSTAR,pblh,dx,GOVRTH,ZA, & +!$acc TSK_wat,TSK_lnd,TSK_ice, & +!$acc rb_wat,rb_lnd,rb_ice) DO I=its,ite if( flag_iter(i) ) then ! DH* 20200401 - note. A weird bug in Intel 18 on hera prevents using the @@ -1067,6 +1205,35 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-------------------------------------------------------------------- !-------------------------------------------------------------------- +!$acc parallel loop present(flag_iter, PSFCPA, dz8w1d, pblh, & +!$acc device_errmsg, device_errflg, & +!$acc device_special_errmsg, device_special_errflg, & +!$acc wet, dry, icy, & +!$acc ZT_wat, ZT_lnd, ZT_ice, & +!$acc ZNT_wat, ZNT_lnd, ZNT_ice, & +!$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, & +!$acc UST_wat, UST_lnd, UST_ice, & +!$acc ZQ_wat, ZQ_lnd, ZQ_ice, & +!$acc snowh_wat, snowh_lnd, snowh_ice, & +!$acc THVSK_wat, THVSK_lnd, THVSK_ice, & +!$acc tskin_wat, tskin_lnd, tskin_ice, & +!$acc tsurf_wat, tsurf_lnd, tsurf_ice, & +!$acc qsfc_wat, qsfc_lnd, qsfc_ice, & +!$acc GZ1OZ0_wat, GZ1OZt_wat, GZ2OZ0_wat, GZ2OZt_wat, GZ10OZ0_wat, GZ10OZt_wat, & +!$acc GZ1OZ0_lnd, GZ1OZt_lnd, GZ2OZ0_lnd, GZ2OZt_lnd, GZ10OZ0_lnd, GZ10OZt_lnd, & +!$acc GZ1OZ0_ice, GZ1OZt_ice, GZ2OZ0_ice, GZ2OZt_ice, GZ10OZ0_ice, GZ10OZt_ice, & +!$acc zratio_wat, zratio_lnd, zratio_ice, & +!$acc stress_wat, stress_lnd, stress_ice, & +!$acc rb_wat, rb_lnd, rb_ice, & +!$acc qflx, qflx_lnd, & +!$acc hflx, hflx_lnd, & +!$acc psim, psih, psim10, psih10, psih2, & +!$acc psix_wat, psix10_wat, psit_wat, psit2_wat, psiq_wat, psiq2_wat, & +!$acc psix_lnd, psix10_lnd, psit_lnd, psit2_lnd, psiq_lnd, psiq2_lnd, & +!$acc psix_ice, psix10_ice, psit_ice, psit2_ice, psiq_ice, psiq2_ice, & +!$acc WSPD, WSPDI, U1D, V1D, TC1D, THV1D, rstoch1D, USTM, ZA, ZOL, QVSH, & +!$acc shdmax, vegtype, z0pert, ztpert, mol, rmol, wstar, qstar, sigmaf) + DO I=its,ite if( flag_iter(i) ) then @@ -1082,10 +1249,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & if (sfc_z0_type >= 0) then ! Avoid calculation is using wave model ! CALCULATE z0 (znt) !-------------------------------------- + IF (debug_code == 2) THEN write(*,*)"=============Input to ZNT over water:" write(*,*)"u*:",UST_wat(i)," wspd=",WSPD(i)," visc=",visc," za=",ZA(I) ENDIF + IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX .EQ. 0 ) THEN IF (COARE_OPT .EQ. 3.0) THEN @@ -1170,7 +1339,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF ELSEIF ( ISFTCFLX .EQ. 4 ) THEN !GFS zt formulation - CALL GFS_zt_wat(ZT_wat(i),ZNTstoch_wat(i),restar,WSPD(i),ZA(i),sfc_z0_type,errmsg,errflg) + CALL GFS_zt_wat(ZT_wat(i),ZNTstoch_wat(i),restar,WSPD(i),ZA(i),sfc_z0_type,device_errmsg,device_errflg) ZQ_wat(i)=ZT_wat(i) ENDIF ELSE @@ -1183,6 +1352,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & rstoch1D(i),spp_sfc) ENDIF ENDIF + IF (debug_code > 1) THEN write(*,*)"=============Output ZT & ZQ over water:" write(*,*)"ZT:",ZT_wat(i)," ZQ:",ZQ_wat(i) @@ -1210,6 +1380,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & else ZNTstoch_lnd(I) = ZNT_lnd(I) endif + !add limit to prevent ridiculous values of z0 (more than dz/15) + ZNTstoch_lnd(I) = min(ZNTstoch_lnd(I), dz8w1d(i)*0.0666_kind_phys) !-------------------------------------- ! LAND @@ -1230,9 +1402,16 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ELSEIF ( IZ0TLND .EQ. 2 ) THEN ! DH note - at this point, qstar is either not initialized ! or initialized to zero, but certainly not set correctly - errmsg = 'Logic error: qstar is not set correctly when calling Yang_2008' - errflg = 1 + device_special_errmsg = 'Logic error: qstar is not set correctly when calling Yang_2008' + device_special_errflg = 1 +#ifndef _OPENACC +! Necessary since OpenACC does not support branching in parallel code +! Must sync errmsg and errflg with device_errmsg and device_errflg, respectively +! so that proper error message and error flag codes are returned. + errmsg = device_special_errmsg + errflg = device_special_errflg return +#endif CALL Yang_2008(ZNTSTOCH_lnd(i),ZT_lnd(i),ZQ_lnd(i),UST_lnd(i),MOL(I),& qstar(I),restar,visc) ELSEIF ( IZ0TLND .EQ. 3 ) THEN @@ -1249,6 +1428,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & UST_lnd(I),KARMAN,1.0_kind_phys,0,spp_sfc,rstoch1D(i)) ENDIF ENDIF + IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i write(0,*)" ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) @@ -1258,7 +1438,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx_lnd(i)," hflx=",hflx_lnd(i)," hpbl=",pblh(i) ENDIF - GZ1OZ0_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) GZ1OZt_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(i))/ZT_lnd(i)) GZ2OZ0_lnd(I)= LOG((2.0+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) @@ -1821,6 +2000,26 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif ! flag_iter ENDDO ! end i-loop +#ifdef _OPENACC +! Necessary since OpenACC does not support branching in parallel code. +! Must sync host errflg, errmsg to determine if return must be triggered +! and correct error message and error flag code returned. +! This code is being executed on the HOST side only, pulling data from DEVICE. +!$acc exit data copyout(device_special_errflg, device_special_errmsg) + IF (device_special_errflg /= 0) THEN + errflg = device_special_errflg + errmsg = device_special_errmsg + return + ENDIF +#endif + +!$acc serial present(wet, dry, icy, & +!$acc PSIM, PSIH, CPM, RHO1D, ZOL, wspd, MOL, & +!$acc wstar, qstar, THV1D, HFX, MAVAIL, QVSH, & +!$acc THVSK_wat, THVSK_lnd, THVSK_ice, & +!$acc UST_wat, UST_lnd, UST_ice, & +!$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, & +!$acc zt_wat, zt_lnd, zt_ice) IF (debug_code == 2) THEN DO I=its,ite IF(wet(i))write(*,*)"==== AT END OF MAIN LOOP, i=",i, "(wet)" @@ -1841,10 +2040,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & write(*,*)"=============================================" ENDDO ! end i-loop ENDIF +!$acc end serial !---------------------------------------------------------- ! COMPUTE SURFACE HEAT AND MOISTURE FLUXES !---------------------------------------------------------- +!$acc parallel loop present(flag_iter, dry, wet, icy, & +!$acc QFX, HFX, FLHC, FLQC, LH, CHS, CH, CHS2, CQS2, & +!$acc RHO1D, MAVAIL, USTM, & +!$acc UST_lnd, UST_wat, UST_ice, & +!$acc PSIQ_lnd, PSIT_lnd, PSIX_lnd, & +!$acc PSIQ_wat, PSIT_wat, PSIX_wat, & +!$acc PSIQ_ice, PSIT_ice, PSIX_ice, & +!$acc PSIQ2_lnd, PSIT2_lnd, & +!$acc PSIQ2_wat, PSIT2_wat, & +!$acc PSIQ2_ice, PSIT2_ice, & +!$acc QSFC, QSFC_lnd, QSFC_wat, QSFC_ice, & +!$acc QFLX, QFLX_lnd, QFLX_wat, QFLX_ice, & +!$acc HFLX, HFLX_lnd, HFLX_wat, HFLX_ice, & +!$acc QSFCMR_lnd, QSFCMR_wat, QSFCMR_ice, & +!$acc QV1D, WSPD, WSPDI, CPM, TH1D, & +!$acc THSK_lnd, THSK_wat, THSK_ice, & +!$acc ch_lnd, ch_wat, ch_ice, & +!$acc cm_lnd, cm_wat, cm_ice) DO I=its,ite if( flag_iter(i) ) then @@ -2040,6 +2258,18 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO ! end i-loop IF (compute_diag) then + !$acc parallel loop present(flag_iter, dry, wet, icy, & + !$acc ZA, ZA2, T2, TH2, TH1D, Q2, QV1D, PSFCPA, & + !$acc THSK_lnd, THSK_wat, THSK_ice, & + !$acc QSFC_lnd, QSFC_wat, QSFC_ice, & + !$acc U10, V10, U1D, V1D, U1D2, V1D2, & + !$acc ZNTstoch_lnd, ZNTstoch_lnd, ZNTstoch_ice, & + !$acc PSIX_lnd, PSIX_wat, PSIX_ice, & + !$acc PSIX10_lnd, PSIX10_wat, PSIX10_ice, & + !$acc PSIT2_lnd, PSIT2_wat, PSIT2_ice, & + !$acc PSIT_lnd, PSIT_wat, PSIT_ice, & + !$acc PSIQ2_lnd, PSIQ2_wat, PSIQ2_ice, & + !$acc PSIQ_lnd, PSIQ_wat, PSIQ_ice) DO I=its,ite if( flag_iter(i) ) then !----------------------------------------------------- @@ -2153,6 +2383,16 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !----------------------------------------------------- ! DEBUG - SUSPICIOUS VALUES !----------------------------------------------------- +!$acc serial present(dry, wet, icy, CPM, MAVAIL, & +!$acc HFX, LH, wstar, RHO1D, PBLH, ZOL, ZA, MOL, & +!$acc PSIM, PSIH, WSTAR, T1D, TH1D, THV1D, QVSH, & +!$acc UST_wat, UST_lnd, UST_ice, & +!$acc THSK_wat, THSK_lnd, THSK_ice, & +!$acc THVSK_wat, THVSK_lnd, THVSK_ice, & +!$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, & +!$acc ZT_wat, ZT_lnd, ZT_ice, & +!$acc QSFC_wat, QSFC_lnd, QSFC_ice, & +!$acc PSIX_wat, PSIX_lnd, PSIX_ice) IF ( debug_code == 2) THEN DO I=its,ite yesno = 0 @@ -2257,6 +2497,62 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF ENDDO ! end i-loop ENDIF ! end debug option +!$acc end serial + +!$acc exit data copyout(CPM, FLHC, FLQC, CHS, CH, CHS2, CQS2,& +!$acc USTM, wstar, qstar, ZOL, MOL, RMOL, & +!$acc HFX, QFX, LH, QSFC, QFLX, HFLX, & +!$acc T2, TH2, Q2, WSPD, U10, V10, & +!$acc QGH, psim, psih, & +!$acc stress_wat, stress_lnd, stress_ice, & +!$acc rb_wat, rb_lnd, rb_ice, & +!$acc UST_wat, UST_lnd, UST_ice, & +!$acc ZNT_wat, ZNT_lnd, ZNT_ice, & +!$acc QSFC_lnd, QSFC_wat, QSFC_ice, & +!$acc QFLX_lnd, QFLX_wat, QFLX_ice, & +!$acc HFLX_lnd, HFLX_wat, HFLX_ice, & +!$acc PSIX_wat, PSIX_lnd, PSIX_ice, & +!$acc PSIX10_wat, PSIX10_lnd, PSIX10_ice, & +!$acc PSIT2_lnd, PSIT2_wat, PSIT2_ice, & +!$acc PSIT_lnd, PSIT_wat, PSIT_ice, & +!$acc ch_lnd, ch_wat, ch_ice, & +!$acc cm_lnd, cm_wat, cm_ice, & +!$acc device_errmsg, device_errflg) + +! Final sync of device and host error flags and messages +IF (device_errflg /= 0) THEN + errflg = device_errflg + errmsg = device_errmsg +ENDIF + +!$acc exit data delete( flag_iter, dry, wet, icy, dx, & +!$acc MAVAIL, PBLH, PSFCPA, z0pert, ztpert, & +!$acc QV1D, U1D, V1D, U1D2, V1D2, T1D, P1D, & +!$acc rstoch1D, sigmaf, shdmax, vegtype, & +!$acc dz2w1d, dz8w1d, & +!$acc snowh_wat, snowh_lnd, snowh_ice, & +!$acc tskin_wat, tskin_lnd, tskin_ice, & +!$acc tsurf_wat, tsurf_lnd, tsurf_ice) + +!$acc exit data delete( ZA, ZA2, THV1D, TH1D, TC1D, TV1D, & +!$acc RHO1D, QVSH, PSIH2, PSIM10, PSIH10, WSPDI, & +!$acc GOVRTH, PSFC, THCON, & +!$acc zratio_lnd, zratio_ice, zratio_wat, & +!$acc TSK_lnd, TSK_ice, TSK_wat, & +!$acc THSK_lnd, THSK_ice, THSK_wat, & +!$acc THVSK_lnd, THVSK_ice, THVSK_wat, & +!$acc GZ1OZ0_lnd, GZ1OZ0_ice, GZ1OZ0_wat, & +!$acc GZ1OZt_lnd, GZ1OZt_ice, GZ1OZt_wat, & +!$acc GZ2OZ0_lnd, GZ2OZ0_ice, GZ2OZ0_wat, & +!$acc GZ2OZt_lnd, GZ2OZt_ice, GZ2OZt_wat, & +!$acc GZ10OZ0_lnd, GZ10OZ0_ice, GZ10OZ0_wat, & +!$acc GZ10OZt_lnd, GZ10OZt_ice, GZ10OZt_wat, & +!$acc ZNTstoch_lnd, ZNTstoch_ice, ZNTstoch_wat, & +!$acc ZT_lnd, ZT_ice, ZT_wat, & +!$acc ZQ_lnd, ZQ_ice, ZQ_wat, & +!$acc PSIQ_lnd, PSIQ_ice, PSIQ_wat, & +!$acc PSIQ2_lnd, PSIQ2_ice, PSIQ2_wat, & +!$acc QSFCMR_lnd, QSFCMR_ice, QSFCMR_wat ) END SUBROUTINE SFCLAY1D_mynn !------------------------------------------------------------------- @@ -2272,6 +2568,7 @@ END SUBROUTINE SFCLAY1D_mynn SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& & landsea,IZ0TLND2,spp_sfc,rstoch) + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea INTEGER, OPTIONAL, INTENT(IN) :: IZ0TLND2 @@ -2309,7 +2606,7 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& IF ( IZ0TLND2 .EQ. 1 ) THEN CZIL = 10.0 ** ( -0.40 * ( Z_0 / 0.07 ) ) ELSE - CZIL = 0.085 !0.075 !0.10 + CZIL = 0.095 !0.075 !0.10 END IF Zt = Z_0*EXP(-KARMAN*CZIL*SQRT(restar)) @@ -2341,6 +2638,7 @@ SUBROUTINE davis_etal_2008(Z_0,ustar) !This is an update version from Davis et al. 2008, which !corrects a small-bias in Z_0 (AHW real-time 2012). + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: ustar REAL(kind_phys), INTENT(OUT) :: Z_0 @@ -2368,7 +2666,7 @@ END SUBROUTINE davis_etal_2008 !>This formulation for roughness length was designed account for. !!wave steepness. SUBROUTINE Taylor_Yelland_2001(Z_0,ustar,wsp10) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: ustar,wsp10 REAL(kind_phys), INTENT(OUT) :: Z_0 @@ -2396,7 +2694,7 @@ END SUBROUTINE Taylor_Yelland_2001 !! The Charnock parameter CZC is varied from .011 to .018. !! between 10-m wsp = 10 and 18.. SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc,zu) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu REAL(kind_phys), INTENT(OUT) :: Z_0 @@ -2421,7 +2719,7 @@ END SUBROUTINE charnock_1955 !!The Charnock parameter CZC is varied from about .005 to .028 !!between 10-m wind speeds of 6 and 19 m/s. SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu REAL(kind_phys), INTENT(OUT) :: Z_0 @@ -2450,7 +2748,7 @@ END SUBROUTINE edson_etal_2013 !!data. The formula for land uses a constant ratio (Z_0/7.4) taken !!from Garratt (1992). SUBROUTINE garratt_1992(Zt,Zq,Z_0,Ren,landsea) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Ren, Z_0,landsea REAL(kind_phys), INTENT(OUT) :: Zt,Zq @@ -2486,7 +2784,7 @@ END SUBROUTINE garratt_1992 !! !!This is for use over water only. SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch INTEGER, INTENT(IN) :: spp_sfc @@ -2530,7 +2828,7 @@ END SUBROUTINE fairall_etal_2003 !! The actual reference is unknown. This was passed along by Jim Edson (personal communication). !! This is for use over water only, preferably open ocean. SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch INTEGER, INTENT(IN) :: spp_sfc @@ -2578,6 +2876,7 @@ END SUBROUTINE fairall_etal_2014 !!This should only be used over land! SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc) + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc REAL(kind_phys) :: ht, &! roughness height at critical Reynolds number @@ -2613,6 +2912,7 @@ END SUBROUTINE Yang_2008 !>\ingroup mynn_sfc SUBROUTINE GFS_z0_lnd(z0max,shdmax,z1,vegtype,ivegsrc,z0pert) + !$acc routine seq REAL(kind_phys), INTENT(OUT) :: z0max REAL(kind_phys), INTENT(IN) :: shdmax,z1,z0pert INTEGER, INTENT(IN) :: vegtype,ivegsrc @@ -2673,6 +2973,7 @@ END SUBROUTINE GFS_z0_lnd !>\ingroup mynn_sfc SUBROUTINE GFS_zt_lnd(ztmax,z0max,sigmaf,ztpert,ustar_lnd) + !$acc routine seq REAL(kind_phys), INTENT(OUT) :: ztmax REAL(kind_phys), INTENT(IN) :: z0max,sigmaf,ztpert,ustar_lnd REAL(kind_phys) :: czilc, tem1, tem2 @@ -2701,6 +3002,7 @@ END SUBROUTINE GFS_zt_lnd !>\ingroup mynn_sfc SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag) + !$acc routine seq REAL(kind_phys), INTENT(OUT) :: z0rl_wat REAL(kind_phys), INTENT(INOUT):: ustar_wat REAL(kind_phys), INTENT(IN) :: wspd,z1 @@ -2752,19 +3054,27 @@ SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag) END SUBROUTINE GFS_z0_wat !-------------------------------------------------------------------- !>\ingroup mynn_sfc - SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) - + SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,device_errmsg,device_errflg) + !$acc routine seq real(kind_phys), INTENT(OUT) :: ztmax real(kind_phys), INTENT(IN) :: wspd,z1,z0rl_wat,restar INTEGER, INTENT(IN) :: sfc_z0_type - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + +! Using device_errmsg and device_errflg rather than the CCPP errmsg and errflg +! so that this subroutine can be run on an accelerator device with OpenACC. +! character(len=*), intent(out) :: errmsg +! integer, intent(out) :: errflg + character(len=512), intent(out) :: device_errmsg + integer, intent(out) :: device_errflg + real(kind_phys) :: z0,z0max,wind10m,rat,ustar_wat real(kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 ! Initialize error-handling - errflg = 0 - errmsg = '' +! errflg = 0 +! errmsg = '' + device_errflg = 0 + device_errmsg = '' ! z0 = 0.01 * z0rl_wat !Already converted to meters in the wrapper @@ -2795,9 +3105,12 @@ SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) call znot_t_v7(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type > 0) then write(0,*)'no option for sfc_z0_type=',sfc_z0_type - errflg = 1 - errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.' +! errflg = 1 +! errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.' + device_errflg = 1 + device_errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.' return + endif END SUBROUTINE GFS_zt_wat @@ -2807,6 +3120,7 @@ END SUBROUTINE GFS_zt_wat !! Weiguo Wang, 2019-0425 SUBROUTINE znot_m_v6(uref, znotm) + !$acc routine seq use machine , only : kind_phys IMPLICIT NONE ! Calculate areodynamical roughness over water with input 10-m wind @@ -2856,6 +3170,7 @@ END SUBROUTINE znot_m_v6 !! SUBROUTINE znot_t_v6(uref, znott) + !$acc routine seq IMPLICIT NONE !> Calculate scalar roughness over water with input 10-m wind !! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm @@ -2922,6 +3237,7 @@ END SUBROUTINE znot_t_v6 !! SUBROUTINE znot_m_v7(uref, znotm) + !$acc routine seq IMPLICIT NONE !> Calculate areodynamical roughness over water with input 10-m wind !! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) @@ -2971,6 +3287,7 @@ END SUBROUTINE znot_m_v7 !! SUBROUTINE znot_t_v7(uref, znott) + !$acc routine seq IMPLICIT NONE !> Calculate scalar roughness over water with input 10-m wind !! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm @@ -3040,6 +3357,7 @@ END SUBROUTINE znot_t_v7 !! This should only be used over snow/ice! SUBROUTINE Andreas_2002(Z_0,bvisc,ustar,Zt,Zq) + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Z_0, bvisc, ustar REAL(kind_phys), INTENT(OUT) :: Zt, Zq @@ -3313,6 +3631,7 @@ END SUBROUTINE PSI_CB2005 !! and Holtslag (1991) for stable conditions. SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(OUT) :: zL REAL(kind_phys), INTENT(IN) :: Rib, zaz0, z0zt @@ -3471,6 +3790,7 @@ REAL(kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) + !$acc routine seq ! This iterative algorithm to compute z/L from bulk-Ri IMPLICIT NONE @@ -3480,7 +3800,7 @@ REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) REAL(kind_phys) :: zol20,zol3,zolt,zolold INTEGER :: n INTEGER, PARAMETER :: nmax = 20 - REAL(kind_phys), DIMENSION(nmax):: zLhux + !REAL(kind_phys), DIMENSION(nmax):: zLhux REAL(kind_phys) :: psit2,psix2 !print*,"+++++++INCOMING: z/L=",zol1," ri=",ri @@ -3522,7 +3842,7 @@ REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) endif !print*,"n=",n," psit2=",psit2," psix2=",psix2 zolrib=ri*psix2**2/psit2 - zLhux(n)=zolrib + !zLhux(n)=zolrib n=n+1 enddo @@ -3530,7 +3850,7 @@ REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) !print*,"iter FAIL, n=",n," Ri=",ri," z/L=",zolri !if convergence fails, use approximate values: CALL Li_etal_2010(zolrib, ri, za/z0, z0/zt) - zLhux(n)=zolrib + !zLhux(n)=zolrib !print*,"FAILED, n=",n," Ri=",ri," z0=",z0 !print*,"z/L=",zLhux(1:nmax) else @@ -3595,6 +3915,7 @@ END SUBROUTINE psi_init ! !>\ingroup mynn_sfc real(kind_phys) function psim_stable_full(zolf) + !$acc routine seq real(kind_phys) :: zolf !psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) @@ -3605,6 +3926,7 @@ real(kind_phys) function psim_stable_full(zolf) !>\ingroup mynn_sfc real(kind_phys) function psih_stable_full(zolf) + !$acc routine seq real(kind_phys) :: zolf !psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) @@ -3615,6 +3937,7 @@ real(kind_phys) function psih_stable_full(zolf) !>\ingroup mynn_sfc real(kind_phys) function psim_unstable_full(zolf) + !$acc routine seq real(kind_phys) :: zolf,x,ym,psimc,psimk x=(1.-16.*zolf)**.25 @@ -3633,6 +3956,7 @@ real(kind_phys) function psim_unstable_full(zolf) !>\ingroup mynn_sfc real(kind_phys) function psih_unstable_full(zolf) + !$acc routine seq real(kind_phys) :: zolf,y,yh,psihc,psihk y=(1.-16.*zolf)**.5 @@ -3654,6 +3978,7 @@ real(kind_phys) function psih_unstable_full(zolf) !>\ingroup mynn_sfc !! REAL(kind_phys) function psim_stable_full_gfs(zolf) + !$acc routine seq REAL(kind_phys) :: zolf REAL(kind_phys), PARAMETER :: alpha4 = 20. REAL(kind_phys) :: aa @@ -3667,6 +3992,7 @@ REAL(kind_phys) function psim_stable_full_gfs(zolf) !>\ingroup mynn_sfc !! real(kind_phys) function psih_stable_full_gfs(zolf) + !$acc routine seq real(kind_phys) :: zolf real(kind_phys), PARAMETER :: alpha4 = 20. real(kind_phys) :: bb @@ -3680,6 +4006,7 @@ real(kind_phys) function psih_stable_full_gfs(zolf) !>\ingroup mynn_sfc !! real(kind_phys) function psim_unstable_full_gfs(zolf) + !$acc routine seq real(kind_phys) :: zolf real(kind_phys) :: hl1,tem1 real(kind_phys), PARAMETER :: a0=-3.975, a1=12.32, & @@ -3700,6 +4027,7 @@ real(kind_phys) function psim_unstable_full_gfs(zolf) !>\ingroup mynn_sfc !! real(kind_phys) function psih_unstable_full_gfs(zolf) + !$acc routine seq real(kind_phys) :: zolf real(kind_phys) :: hl1,tem1 real(kind_phys), PARAMETER :: a0p=-7.941, a1p=24.75, & @@ -3720,6 +4048,7 @@ real(kind_phys) function psih_unstable_full_gfs(zolf) !>\ingroup mynn_sfc !! look-up table functions - or, if beyond -10 < z/L < 10, recalculate real(kind_phys) function psim_stable(zolf,psi_opt) + !$acc routine seq integer :: nzol,psi_opt real(kind_phys) :: rzol,zolf @@ -3740,6 +4069,7 @@ real(kind_phys) function psim_stable(zolf,psi_opt) !>\ingroup mynn_sfc real(kind_phys) function psih_stable(zolf,psi_opt) + !$acc routine seq integer :: nzol,psi_opt real(kind_phys) :: rzol,zolf @@ -3760,6 +4090,7 @@ real(kind_phys) function psih_stable(zolf,psi_opt) !>\ingroup mynn_sfc real(kind_phys) function psim_unstable(zolf,psi_opt) + !$acc routine seq integer :: nzol,psi_opt real(kind_phys) :: rzol,zolf @@ -3780,6 +4111,7 @@ real(kind_phys) function psim_unstable(zolf,psi_opt) !>\ingroup mynn_sfc real(kind_phys) function psih_unstable(zolf,psi_opt) + !$acc routine seq integer :: nzol,psi_opt real(kind_phys) :: rzol,zolf diff --git a/physics/mynnsfc_wrapper.F90 b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.F90 similarity index 94% rename from physics/mynnsfc_wrapper.F90 rename to physics/SFC_Layer/MYNN/mynnsfc_wrapper.F90 index 1a970c9f4..3c033e65e 100644 --- a/physics/mynnsfc_wrapper.F90 +++ b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.F90 @@ -191,6 +191,16 @@ SUBROUTINE mynnsfc_wrapper_run( & & IMS,IME,JMS,JME,KMS,KME, & & ITS,ITE,JTS,JTE,KTS,KTE +!$acc enter data create(hfx, znt, psim, psih, chs, & +!$acc mavail, xland, GZ1OZ0, cpm, qgh, & +!$acc qfx, snowh_wat) + +!$acc enter data create(dz, th, qv) + +!$acc enter data copyin(rmol, phii, t3d, exner, qvsh, slmsk, xland) + +!$acc enter data copyin(dry, wet, icy, znt_lnd, znt_wat, znt_ice, qsfc_lnd, qsfc_ice, qsfc_lnd_ruc, qsfc_ice_ruc) + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -203,6 +213,7 @@ SUBROUTINE mynnsfc_wrapper_run( & ! write(0,*)"iter=",iter ! endif +!$acc kernels ! prep MYNN-only variables dz(:,:) = 0 th(:,:) = 0 @@ -210,6 +221,9 @@ SUBROUTINE mynnsfc_wrapper_run( & hfx(:) = 0 qfx(:) = 0 rmol(:) = 0 +!$acc end kernels + +!$acc parallel loop collapse(2) present(dz, phii, th, t3d, exner, qv, qvsh) do k=1,2 !levs do i=1,im dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv @@ -219,6 +233,7 @@ SUBROUTINE mynnsfc_wrapper_run( & enddo enddo +!$acc parallel loop present(slmsk, xland, qgh, mavail, cpm, snowh_wat) do i=1,im if (slmsk(i)==1. .or. slmsk(i)==2.)then !sea/land/ice mask (=0/1/2) in FV3 xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn @@ -235,6 +250,7 @@ SUBROUTINE mynnsfc_wrapper_run( & snowh_wat(i) = 0.0 enddo +!$acc kernels ! cm -> m where (dry) znt_lnd=znt_lnd*0.01 where (wet) znt_wat=znt_wat*0.01 @@ -245,6 +261,7 @@ SUBROUTINE mynnsfc_wrapper_run( & where (dry) qsfc_lnd = qsfc_lnd_ruc/(1.+qsfc_lnd_ruc) ! spec. hum where (icy) qsfc_ice = qsfc_ice_ruc/(1.+qsfc_ice_ruc) ! spec. hum. end if +!$acc end kernels ! if (lprnt) then ! write(0,*)"CALLING SFCLAY_mynn; input:" @@ -274,6 +291,8 @@ SUBROUTINE mynnsfc_wrapper_run( & ! write(0,*)"PBLH=",pblh(1)," xland=",xland(1) ! endif +!$acc exit data delete(qsfc_lnd_ruc, qsfc_ice_ruc) +!$acc exit data delete(phii, qvsh, slmsk) CALL SFCLAY_mynn( & u3d=u,v3d=v,t3d=t3d,qv3d=qv,p3d=prsl,dz8w=dz, & @@ -318,6 +337,13 @@ SUBROUTINE mynnsfc_wrapper_run( & errmsg=errmsg, errflg=errflg ) if (errflg/=0) return +!$acc exit data delete(hfx, znt, psim, psih, chs, & +!$acc mavail, xland, GZ1OZ0, cpm, qgh, & +!$acc qfx, snowh_wat, t3d, exner) +!$acc exit data delete(dz, th, qv) +!$acc exit data copyout(rmol) +!$acc exit data copyout(qsfc_lnd, qsfc_ice) + !! POST MYNN SURFACE LAYER (INTERSTITIAL) WORK: !do i = 1, im ! !* Taken from sfc_nst.f @@ -336,10 +362,15 @@ SUBROUTINE mynnsfc_wrapper_run( & ! znt_ice(i)=znt_ice(i)*100. !enddo +!$acc kernels ! m -> cm where (dry) znt_lnd=znt_lnd*100. where (wet) znt_wat=znt_wat*100. where (icy) znt_ice=znt_ice*100. +!$acc end kernels + +!$acc exit data delete(dry, wet, icy) +!$acc exit data copyout(znt_lnd, znt_wat, znt_ice) ! if (lprnt) then ! write(0,*) diff --git a/physics/mynnsfc_wrapper.meta b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.meta similarity index 99% rename from physics/mynnsfc_wrapper.meta rename to physics/SFC_Layer/MYNN/mynnsfc_wrapper.meta index d89cc5d35..0e1c96c02 100644 --- a/physics/mynnsfc_wrapper.meta +++ b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mynnsfc_wrapper type = scheme - dependencies = machine.F,module_sf_mynn.F90 + dependencies = ../../hooks/machine.F,../../hooks/physcons.F90,module_sf_mynn.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/date_def.f b/physics/SFC_Layer/UFS/date_def.f similarity index 100% rename from physics/date_def.f rename to physics/SFC_Layer/UFS/date_def.f diff --git a/physics/SFC_Layer/UFS/module_nst_model.f90 b/physics/SFC_Layer/UFS/module_nst_model.f90 new file mode 100644 index 000000000..74c75924b --- /dev/null +++ b/physics/SFC_Layer/UFS/module_nst_model.f90 @@ -0,0 +1,976 @@ +!>\file module_nst_model.f90 +!! This file contains the diurnal thermocline layer model (DTM) of +!! the GFS NSST scheme. + +!>\defgroup dtm_module GFS NSST Diurnal Thermocline Model +!> This module contains the diurnal thermocline layer model (DTM) of +!! the GFS NSST scheme. +!>\ingroup gfs_nst_main_mod + +!> This module contains the diurnal thermocline layer model (DTM) of +!! the GFS NSST scheme. +module nst_module + ! + ! the module of diurnal thermocline layer model + ! + use machine , only : kind_phys + use module_nst_parameters , only : z_w_max, z_w_min, z_w_ini, eps_z_w, eps_conv + use module_nst_parameters , only : eps_sfs, niter_z_w, niter_conv, niter_sfs, ri_c + use module_nst_parameters , only : ri_g, omg_m, omg_sh, kw => tc_w, visw, t0k, cp_w + use module_nst_parameters , only : z_c_max, z_c_ini, ustar_a_min, delz, exp_const + use module_nst_parameters , only : rad2deg, const_rot, tw_max, sst_max + use module_nst_parameters , only : zero, one + use module_nst_water_prop , only : sw_rad_skin, sw_ps_9b, sw_ps_9b_aw + + implicit none + + private + + public :: dtm_1p, dtm_1p_fca, dtm_1p_tla, dtm_1p_mwa, dtm_1p_mda, dtm_1p_mta, convdepth + public :: cal_w, cal_ttop, cool_skin, dtl_reset + +contains + + !>\ingroup gfs_nst_main_mod + !! This subroutine contains the module of diurnal thermocline layer model. + subroutine dtm_1p(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & + alpha,beta,alon,sinlat,soltim,grav,le,d_conv, & + xt,xs,xu,xv,xz,xzts,xtts) + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& + hl_ts,rho,alpha,beta,alon,sinlat,soltim,& + grav,le,d_conv + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts + ! local variables + + ! + ! input variables + ! + ! timestep: integration time step in seconds + ! rich : critical ri (flow dependent) + ! tox : x wind stress (n*m^-2 or kg/m/s^2) + ! toy : y wind stress (n*m^-2 or kg/m/s^2) + ! i0 : solar radiation flux at the surface (wm^-2) + ! q : non-solar heat flux at the surface (wm^-2) + ! sss : salinity (ppt) + ! sep : sr(e-p) (ppt*m/s) + ! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes + ! hl_ts : d(hl)/d(ts) + ! rho : sea water density (kg*m^-3) + ! alpha : thermal expansion coefficient (1/k) + ! beta : saline contraction coefficient (1/ppt) + ! sinlat : sine (lat) + ! grav : gravity accelleration + ! le : le=(2.501-.00237*tsea)*1e6 + ! d-conv : fcl thickness + ! + ! inout variables + ! + ! xt : dtl heat content (m*k) + ! xs : dtl salinity content (m*ppt) + ! xu : dtl x current content (m*m/s) + ! xv : dtl y current content (m*m/s) + ! xz : dtl thickness (m) + ! xzts : d(xz)/d(ts) (m/k ) + ! xtts : d(xt)/d(ts) (m) + ! + ! logical lprnt + + ! if (lprnt) print *,' first xt=',xt + if ( xt <= zero ) then ! dtl doesn't exist yet + call dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & + beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts) + elseif ( xt > zero ) then ! dtl already exists + ! + ! forward the system one time step + ! + call eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & + beta,alon,sinlat,soltim,grav,le,d_conv, & + xt,xs,xu,xv,xz,xzts,xtts) + endif ! if ( xt == 0 ) then + + end subroutine dtm_1p + + !>\ingroup gfs_nst_main_mod + !! This subroutine integrates one time step with modified Euler method. + subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & + beta,alon,sinlat,soltim,grav,le,d_conv, & + xt,xs,xu,xv,xz,xzts,xtts) + + ! + ! subroutine eulerm: integrate one time step with modified euler method + ! + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts, & + hl_ts,rho,alpha,beta,alon,sinlat,soltim, & + grav,le,d_conv + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts + ! local variables + real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0,xzts0,xtts0 + real(kind=kind_phys) :: fw,aw,q_warm + real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1,xzts1,xtts1 + real(kind=kind_phys) :: xt2,xs2,xu2,xv2,xz2,xzts2,xtts2 + real(kind=kind_phys) :: dzw,drho,fc + real(kind=kind_phys) :: alat,speed + ! logical lprnt + + ! + ! input variables + ! + ! timestep: integration time step in seconds + ! rich : critial ri (flow/mass dependent) + ! tox : x wind stress (n*m^-2 or kg/m/s^2) + ! toy : y wind stress (n*m^-2 or kg/m/s^2) + ! i0 : solar radiation flux at the surface (wm^-2) + ! q : non-solar heat flux at the surface (wm^-2) + ! sss : salinity (ppt) + ! sep : sr(e-p) (ppt*m/s) + ! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes + ! hl_ts : d(hl)/d(ts) + ! rho : sea water density (kg*m^-3) + ! alpha : thermal expansion coefficient (1/k) + ! beta : saline contraction coefficient (1/ppt) + ! alon : longitude (deg) + ! sinlat : sine (lat) + ! soltim : solar time + ! grav : gravity accelleration + ! le : le=(2.501-.00237*tsea)*1e6 + ! d_conv : fcl thickness (m) + ! + ! inout variables + ! + ! xt : dtl heat content (m*k) + ! xs : dtl salinity content (m*ppt) + ! xu : dtl x current content (m*m/s) + ! xv : dtl y current content (m*m/s) + ! xz : dtl thickness (m) + ! xzts : d(xz)/d(ts) (m/k ) + ! xtts : d(xt)/d(ts) (m) + + xt0 = xt + xs0 = xs + xu0 = xu + xv0 = xv + xz0 = xz + xtts0 = xtts + xzts0 = xzts + speed = max(1.0e-8, xu0*xu0+xv0*xv0) + + alat = asin(sinlat)*rad2deg + + fc = const_rot*sinlat + + call sw_ps_9b(xz0,fw) + + q_warm = fw*i0-q !total heat abs in warm layer + + call sw_ps_9b_aw(xz0,aw) + + drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep + + ! dzw = xz0*(tox*xu0+toy*xv0) / (rho*(xu0*xu0+xv0*xv0)) & + ! + xz0*xz0*xz0*drho*grav / (4.0*rich*(xu0*xu0+xv0*xv0)) + dzw = xz0 * ((tox*xu0+toy*xv0) / (rho*speed) & + + xz0*xz0*drho*grav / (4.0*rich*speed)) + + xt1 = xt0 + timestep*q_warm/(rho*cp_w) + xs1 = xs0 + timestep*sep + xu1 = xu0 + timestep*(fc*xv0+tox/rho) + xv1 = xv0 + timestep*(-fc*xu0+toy/rho) + xz1 = xz0 + timestep*dzw + + ! if (lprnt) print *,' xt1=',xt1,' xz1=',xz1,' xz0=',xz0,' dzw=',dzw, & + ! 'timestep=',timestep,tox,toy,xu0,xv0,rho,drho,grav,rich + + if ( xt1 <= zero .or. xz1 <= zero .or. xz1 > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + return + endif + + ! call dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt1,xs1,xu1,xv1,xz1,tr_mda,tr_fca,tr_tla,tr_mwa) + + xzts1 = xzts0 + timestep*((1.0/(xu0*xu0+xv0*xv0)) * & + ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz0**3/(4.0*rich*rho) & + +( (tox*xu0+toy*xv0)/rho+(3.0*drho-alpha*i0*aw*xz0/(rho*cp_w)) & + *grav*xz0*xz0/(4.0*rich) )*xzts0 )) + xtts1 = xtts0 + timestep*(i0*aw*xzts0-q_ts)/(rho*cp_w) + + ! if ( 2.0*xt1/xz1 > 0.001 ) then + ! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_01 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,& + ! 2.0*xt1/xz1,2.0*xs1/xz1,2.0*xu1/xz1,2.0*xv1/xz1,xz1,xtts1,xzts1,d_conv,t_fcl,te + ! endif + + call sw_ps_9b(xz1,fw) + q_warm = fw*i0-q !total heat abs in warm layer + call sw_ps_9b_aw(xz1,aw) + drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep + dzw = xz1*(tox*xu1+toy*xv1) / (rho*(xu1*xu1+xv1*xv1)) & + + xz1*xz1*xz1*drho*grav / (4.0*rich*(xu1*xu1+xv1*xv1)) + + xt2 = xt0 + timestep*q_warm/(rho*cp_w) + xs2 = xs0 + timestep*sep + xu2 = xu0 + timestep*(fc*xv1+tox/rho) + xv2 = xv0 + timestep*(-fc*xu1+toy/rho) + xz2 = xz0 + timestep*dzw + + ! if (lprnt) print *,' xt2=',xt2,' xz2=',xz2 + + if ( xt2 <= zero .or. xz2 <= zero .or. xz2 > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + return + endif + + xzts2 = xzts0 + timestep*((1.0/(xu1*xu1+xv1*xv1)) * & + ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz1**3/(4.0*rich*rho) & + +( (tox*xu1+toy*xv1)/rho+(3.0*drho-alpha*i0*aw*xz1/(rho*cp_w))* & + grav*xz1*xz1/(4.0*rich) )*xzts1 )) + xtts2 = xtts0 + timestep*(i0*aw*xzts1-q_ts)/(rho*cp_w) + + xt = 0.5*(xt1 + xt2) + xs = 0.5*(xs1 + xs2) + xu = 0.5*(xu1 + xu2) + xv = 0.5*(xv1 + xv2) + xz = 0.5*(xz1 + xz2) + xzts = 0.5*(xzts1 + xzts2) + xtts = 0.5*(xtts1 + xtts2) + + if ( xt <= zero .or. xz < zero .or. xz > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + endif + + ! if (lprnt) print *,' xt=',xt,' xz=',xz + ! if ( 2.0*xt/xz > 0.001 ) then + ! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_02 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,& + ! 2.0*xt/xz,2.0*xs/xz,2.0*xu/xz,2.0*xv/xz,xz,xtts,xzts,d_conv,t_fcl,te + ! endif + return + + end subroutine eulerm + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies xz adjustment. + subroutine dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt,xs,xu,xv,xz,tr_mda,tr_fca,tr_tla,tr_mwa) + ! apply xz adjustment: minimum depth adjustment (mda) + ! free convection adjustment (fca); + ! top layer adjustment (tla); + ! maximum warming adjustment (mwa) + ! + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,i0,q,rho,d_conv + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz + real(kind=kind_phys), intent(out) :: tr_mda,tr_fca,tr_tla,tr_mwa + ! local variables + real(kind=kind_phys) :: dz,t0,ttop0,ttop,fw,q_warm + ! TODO: xz_mwa is unset but used below in max function + real(kind=kind_phys) :: xz_fca,xz_tla,xz_mwa + ! + real(kind=kind_phys) :: xz_mda + + tr_mda = zero; tr_fca = zero; tr_tla = zero; tr_mwa = zero + + ! apply mda + if ( z_w_min > xz ) then + xz_mda = z_w_min + endif + ! apply fca + if ( d_conv > zero ) then + xz_fca = 2.0*xt/((2.0*xt/xz)*(1.0-d_conv/(2.0*xz))) + tr_fca = 1.0 + if ( xz_fca >= z_w_max ) then + call dtl_reset_cv(xt,xs,xu,xv,xz) + go to 10 + endif + endif + ! apply tla + dz = min(xz,max(d_conv,delz)) + call sw_ps_9b(dz,fw) + q_warm=fw*i0-q !total heat abs in warm layer + + if ( q_warm > zero ) then + call cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop0) + ! ttop = (2.0*xt/xz)*(1.0-dz/(2.0*xz)) + ttop = ((xt+xt)/xz)*(1.0-dz/(xz+xz)) + if ( ttop > ttop0 ) then + xz_tla = (xt+sqrt(xt*(xt-delz*ttop0)))/ttop0 + tr_tla = 1.0 + if ( xz_tla >= z_w_max ) then + call dtl_reset_cv(xt,xs,xu,xv,xz) + go to 10 + endif + endif + endif + + ! apply mwa + t0 = 2.0*xt/xz + if ( t0 > tw_max ) then + if ( xz >= z_w_max ) then + call dtl_reset_cv(xt,xs,xu,xv,xz) + go to 10 + endif + endif + + xz = max(xz_mda,xz_fca,xz_tla,xz_mwa) + +10 continue + + end subroutine dtm_1p_zwa + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies free convection adjustment(fca). + subroutine dtm_1p_fca(d_conv,xt,xtts,xz,xzts) + + ! apply xz adjustment: free convection adjustment (fca); + ! + real(kind=kind_phys), intent(in) :: d_conv,xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts + ! local variables + real(kind=kind_phys) :: t_fcl,t0 + ! + t0 = 2.0*xt/xz + t_fcl = t0*(1.0-d_conv/(2.0*xz)) + xz = 2.0*xt/t_fcl + ! xzts = 2.0*xtts/t_fcl + + end subroutine dtm_1p_fca + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies top layer adjustment (tla). + subroutine dtm_1p_tla(dz,te,xt,xtts,xz,xzts) + + ! apply xz adjustment: top layer adjustment (tla); + ! + real(kind=kind_phys), intent(in) :: dz,te,xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts + ! local variables + real(kind=kind_phys) :: tem + ! + tem = xt*(xt-dz*te) + if (tem > zero) then + xz = (xt+sqrt(xt*(xt-dz*te)))/te + else + xz = z_w_max + endif + ! xzts = xtts*(1.0+0.5*(2.0*xt-dz*te)/sqrt(xt*(xt-dz*te)))/te + end subroutine dtm_1p_tla + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies maximum warming adjustment (mwa). + subroutine dtm_1p_mwa(xt,xtts,xz,xzts) + + ! apply xz adjustment: maximum warming adjustment (mwa) + ! + real(kind=kind_phys), intent(in) :: xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts + ! local variables + ! + xz = 2.0*xt/tw_max + ! xzts = 2.0*xtts/tw_max + end subroutine dtm_1p_mwa + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies minimum depth adjustment (xz adjustment). + subroutine dtm_1p_mda(xt,xtts,xz,xzts) + + ! apply xz adjustment: minimum depth adjustment (mda) + ! + real(kind=kind_phys), intent(in) :: xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts + ! local variables + real(kind=kind_phys) :: ta + ! + xz = max(z_w_min,xz) + ta = 2.0*xt/xz + ! xzts = 2.0*xtts/ta + + end subroutine dtm_1p_mda + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies maximum temperature adjustment (mta). + subroutine dtm_1p_mta(dta,xt,xtts,xz,xzts) + + ! apply xz adjustment: maximum temperature adjustment (mta) + ! + real(kind=kind_phys), intent(in) :: dta,xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts + ! local variables + real(kind=kind_phys) :: ta + ! + ta = max(zero,2.0*xt/xz-dta) + if ( ta > zero ) then + xz = 2.0*xt/ta + else + xz = z_w_max + endif + ! xzts = 2.0*xtts/ta + + end subroutine dtm_1p_mta + + !>\ingroup gfs_nst_main_mod + !! This subroutine calculates depth for convective adjustment. + subroutine convdepth(kdt,timestep,i0,q,sss,sep,rho,alpha,beta,xt,xs,xz,d_conv) + + ! + ! calculate depth for convective adjustment + ! + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,i0,q,sss,sep,rho,alpha,beta + real(kind=kind_phys), intent(in) :: xt,xs,xz + real(kind=kind_phys), intent(out) :: d_conv + real(kind=kind_phys) :: t,s,d_conv_ini,d_conv2,fxp,aw,s1,s2,fac1 + integer :: n + ! + ! input variables + ! + ! timestep: time step in seconds + ! i0 : solar radiation flux at the surface (wm^-2) + ! q : non-solar heat flux at the surface (wm^-2) + ! sss : salinity (ppt) + ! sep : sr(e-p) (ppt*m/s) + ! rho : sea water density (kg*m^-3) + ! alpha : thermal expansion coefficient (1/k) + ! beta : saline contraction coefficient (1/ppt) + ! xt : initial heat content (k*m) + ! xs : initial salinity content (ppt*m) + ! xz : initial dtl thickness (m) + ! + ! output variables + ! + ! d_conv : free convection depth (m) + + ! t : initial diurnal warming t (k) + ! s : initial diurnal warming s (ppt) + + n = 0 + t = 2.0*xt/xz + s = 2.0*xs/xz + + s1 = alpha*rho*t-omg_m*beta*rho*s + + if ( s1 == zero ) then + d_conv = zero + else + + fac1 = alpha*q/cp_w+omg_m*beta*rho*sep + if ( i0 <= zero ) then + d_conv2=(2.0*xz*timestep/s1)*fac1 + if ( d_conv2 > zero ) then + d_conv = sqrt(d_conv2) + else + d_conv = zero + endif + elseif ( i0 > zero ) then + + d_conv_ini = zero + + iter_conv: do n = 1, niter_conv + call sw_ps_9b(d_conv_ini,fxp) + call sw_ps_9b_aw(d_conv_ini,aw) + s2 = alpha*(q-(fxp-aw*d_conv_ini)*i0)/cp_w+omg_m*beta*rho*sep + d_conv2=(2.0*xz*timestep/s1)*s2 + if ( d_conv2 < zero ) then + d_conv = zero + exit iter_conv + endif + d_conv = sqrt(d_conv2) + if ( abs(d_conv-d_conv_ini) < eps_conv .and. n <= niter_conv ) exit iter_conv + d_conv_ini = d_conv + enddo iter_conv + d_conv = max(zero,min(d_conv,z_w_max)) + endif ! if ( i0 <= zero ) then + + endif ! if ( s1 == zero ) then + + ! if ( d_conv > 0.01 ) then + ! write(*,'(a,i4,i3,10f9.3,3f10.6,f10.1,f6.2)') ' d_conv : ',kdt,n,d_conv,d_conv_ini,q,i0,rho,cp_w,timestep,xt,xs,xz,sep, & + ! s1,s2,d_conv2,aw + ! endif + + end subroutine convdepth + + !>\ingroup gfs_nst_main_mod + subroutine dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & + alpha,beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts) + ! + ! determine xz iteratively (starting wit fw = 0.5) and then update the other 6 variables + ! + + integer,intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts, & + hl_ts,rho,alpha,beta,alon,sinlat,soltim,grav,le + real(kind=kind_phys), intent(out) :: xt,xs,xu,xv,xz,xzts,xtts + real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0 + real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1 + real(kind=kind_phys) :: fw,aw,q_warm,ft0,fs0,fu0,fv0,fz0,ft1,fs1,fu1,fv1,fz1 + real(kind=kind_phys) :: coeff1,coeff2,ftime,z_w,z_w_tmp,fc,warml,alat + integer :: n + ! + ! input variables + ! + ! timestep: time step in seconds + ! tox : x wind stress (n*m^-2 or kg/m/s^2) + ! toy : y wind stress (n*m^-2 or kg/m/s^2) + ! i0 : solar radiation flux at the surface (wm^-2) + ! q : non-solar heat flux at the surface (wm^-2) + ! sss : salinity (ppt) + ! sep : sr(e-p) (ppt*m/s) + ! rho : sea water density (kg*m^-3) + ! alpha : thermal expansion coefficient (1/k) + ! beta : saline contraction coefficient (1/ppt) + ! alon : longitude + ! sinlat : sine(latitude) + ! grav : gravity accelleration + ! le : le=(2.501-.00237*tsea)*1e6 + ! + ! output variables + ! + ! xt : onset t content in dtl + ! xs : onset s content in dtl + ! xu : onset u content in dtl + ! xv : onset v content in dtl + ! xz : onset dtl thickness (m) + ! xzts : onset d(xz)/d(ts) (m/k ) + ! xtts : onset d(xt)/d(ts) (m) + + fc=1.46/10000.0/2.0*sinlat + alat = asin(sinlat) + ! + ! initializing dtl (just before the onset) + ! + xt0 = zero + xs0 = zero + xu0 = zero + xv0 = zero + + z_w_tmp=z_w_ini + + call sw_ps_9b(z_w_tmp,fw) + ! fw=0.5 ! + q_warm=fw*i0-q !total heat abs in warm layer + + if ( abs(alat) > 1.0 ) then + ftime=sqrt((2.0-2.0*cos(fc*timestep))/(fc*fc*timestep)) + else + ftime=timestep + endif + + coeff1=alpha*grav/cp_w + coeff2=omg_m*beta*grav*rho + warml = coeff1*q_warm-coeff2*sep + + if ( warml > zero .and. q_warm > zero) then + iters_z_w: do n = 1,niter_z_w + if ( warml > zero .and. q_warm > zero ) then + z_w=sqrt(2.0*rich*ftime/rho)*sqrt(tox**2+toy**2)/sqrt(warml) + else + z_w = z_w_max + exit iters_z_w + endif + + ! write(*,'(a,i4,i4,10f9.3,f9.6,f3.0)') ' z_w = ',kdt,n,z_w,z_w_tmp,timestep,q_warm,q,i0,fw,tox,toy,sep,warml,omg_m + + if (abs(z_w - z_w_tmp) < eps_z_w .and. z_w/=z_w_max .and. n < niter_z_w) exit iters_z_w + z_w_tmp=z_w + call sw_ps_9b(z_w_tmp,fw) + q_warm = fw*i0-q + warml = coeff1*q_warm-coeff2*sep + end do iters_z_w + else + z_w=z_w_max + endif + + xz0 = max(z_w,z_w_min) + + ! + ! update xt, xs, xu, xv + ! + if ( z_w < z_w_max .and. q_warm > zero) then + + call sw_ps_9b(z_w,fw) + q_warm=fw*i0-q !total heat abs in warm layer + + ft0 = q_warm/(rho*cp_w) + fs0 = sep + fu0 = fc*xv0+tox/rho + fv0 = -fc*xu0+toy/rho + + xt1 = xt0 + timestep*ft0 + xs1 = xs0 + timestep*fs0 + xu1 = xu0 + timestep*fu0 + xv1 = xv0 + timestep*fv0 + + fz0 = xz0*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz0*xz0/(4.0*rich) & + -alpha*grav*q_warm*xz0*xz0/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1) + xz1 = xz0 + timestep*fz0 + + xz1 = max(xz1,z_w_min) + + if ( xt1 < zero .or. xz1 > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts) + return + endif + + call sw_ps_9b(xz1,fw) + q_warm=fw*i0-q !total heat abs in warm layer + + ft1 = q_warm/(rho*cp_w) + fs1 = sep + fu1 = fc*xv1+tox/rho + fv1 = -fc*xu1+toy/rho + + fz1 = xz1*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz1*xz1/(4.0*rich) & + -alpha*grav*q_warm*xz1*xz1/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1) + + xt = xt0 + 0.5*timestep*(ft0+ft1) + xs = xs0 + 0.5*timestep*(fs0+fs1) + xu = xu0 + 0.5*timestep*(fu0+fu1) + xv = xv0 + 0.5*timestep*(fv0+fv1) + xz = xz0 + 0.5*timestep*(fz0+fz1) + + xz = max(xz,z_w_min) + + call sw_ps_9b_aw(xz,aw) + + ! xzts = (q_ts+(cp_w*omg_m*beta*sss/(le*alpha))*hl_ts)*xz/(i0*xz*aw+2.0*q_warm-2.0*(rho*cp_w*omg_m*beta*sss/alpha)*(sep/sss)) + xzts = (q_ts+omg_m*rho*cp_w*beta*sss*hl_ts*xz/(le*alpha))/(i0*xz*aw+2.0*q_warm-2.0*omg_m*rho*cp_w*beta*sss*sep/(le*alpha)) + xtts = timestep*(i0*aw*xzts-q_ts)/(rho*cp_w) + endif + + if ( xt < zero .or. xz > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts) + endif + + return + + end subroutine dtm_onset + + !>\ingroup gfs_nst_main_mod + !! This subroutine computes coefficients (\a w_0 and \a w_d) to + !! calculate d(tw)/d(ts). + subroutine cal_w(kdt,xz,xt,xzts,xtts,w_0,w_d) + ! + ! abstract: calculate w_0,w_d + ! + ! input variables + ! + ! kdt : the number of time step + ! xt : dtl heat content + ! xz : dtl depth + ! xzts : d(zw)/d(ts) + ! xtts : d(xt)/d(ts) + ! + ! output variables + ! + ! w_0 : coefficint 1 to calculate d(tw)/d(ts) + ! w_d : coefficint 2 to calculate d(tw)/d(ts) + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: xz,xt,xzts,xtts + real(kind=kind_phys), intent(out) :: w_0,w_d + + w_0 = 2.0*(xtts-xt*xzts/xz)/xz + w_d = (2.0*xt*xzts/xz**2-w_0)/xz + + ! if ( 2.0*xt/xz > 1.0 ) then + ! write(*,'(a,i4,2f9.3,4f10.4))') ' cal_w : ',kdt,xz,xt,w_0,w_d,xzts,xtts + ! endif + end subroutine cal_w + + !>\ingroup gfs_nst_main_mod + !! This subroutine calculates the diurnal warming amount at the top layer + !! with thickness of \a delz. + subroutine cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop) + ! + ! abstract: calculate + ! + ! input variables + ! + ! kdt : the number of record + ! timestep : the number of record + ! q_warm : total heat abs in layer dz + ! rho : sea water density + ! dz : dz = max(delz,d_conv) top layer thickness defined to adjust xz + ! xt : heat content in dtl at previous time + ! xz : dtl thickness at previous time + ! + ! output variables + ! + ! ttop : the diurnal warming amount at the top layer with thickness of delz + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,q_warm,rho,dz,xt,xz + real(kind=kind_phys), intent(out) :: ttop + real(kind=kind_phys) :: dt_warm,t0 + + dt_warm = (xt+xt)/xz + t0 = dt_warm*(1.0-dz/(xz+xz)) + ttop = t0 + q_warm*timestep/(rho*cp_w*dz) + + end subroutine cal_ttop + + !>\ingroup gfs_nst_main_mod + !! This subroutine adjust dtm-1p dtl thickness by applying shear flow stability + !! with assumed exponential profile. + subroutine app_sfs(kdt,xt,xs,xu,xv,alpha,beta,grav,d_1p,xz) + ! + ! abstract: adjust dtm-1p dtl thickness by applying shear flow stability with assumed exponetial profile + ! + ! input variables + ! + ! kdt : the number of record + ! xt : heat content in dtl + ! xs : salinity content in dtl + ! xu : u-current content in dtl + ! xv : v-current content in dtl + ! alpha + ! beta + ! grav + ! d_1p : dtl depth before sfs applied + ! + ! output variables + ! + ! xz : dtl depth + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: xt,xs,xu,xv,alpha,beta,grav,d_1p + real(kind=kind_phys), intent(out) :: xz + ! real(kind=kind_phys) :: ze,cc,xz0,l,d_sfs, t_sfs, tem + real(kind=kind_phys) :: cc,l,d_sfs,tem + real(kind=kind_phys), parameter :: c2 = 0.3782 + + cc = ri_g/(grav*c2) + + tem = alpha*xt - beta*xs + if (tem > zero) then + d_sfs = sqrt(2.0*cc*(xu*xu+xv*xv)/tem) + else + d_sfs = zero + endif + + ! xz0 = d_1p + ! iter_sfs: do n = 1, niter_sfs + ! l = int_epn(0.0,xz0,0.0,xz0,2) + ! d_sfs = cc*(xu*xu+xv*xv)/((alpha*xt-beta*xs)*l) + ! write(*,'(a,i6,i3,4f9.4))') ' app_sfs_iter : ',kdt,n,cc,l,xz0,d_sfs + ! if ( abs(d_sfs-xz0) < eps_sfs .and. n <= niter_sfs ) exit iter_sfs + ! xz0 = d_sfs + ! enddo iter_sfs + + ! ze = a2*d_sfs ! not used! + + l = int_epn(zero,d_sfs,zero,d_sfs,2) + + ! t_sfs = xt/l + ! xz = (xt+xt) / t_sfs + + xz = l + l + + ! write(*,'(a,i6,6f9.4))') ' app_sfs : ',kdt,xz0,d_sfs,d_1p,xz,2.0*xt/d_1p,t_sfs + end subroutine app_sfs + + !>\ingroup gfs_nst_main_mod + !! This subroutine calculates d(tz)/d(ts). + subroutine cal_tztr(kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr) + ! + ! abstract: calculate d(tz)/d(ts) + ! + ! input variables + ! + ! kdt : the number of record + ! xt : heat content in dtl + ! xz : dtl depth (m) + ! c_0 : coefficint 1 to calculate d(tc)/d(ts) + ! c_d : coefficint 2 to calculate d(tc)/d(ts) + ! w_0 : coefficint 1 to calculate d(tw)/d(ts) + ! w_d : coefficint 2 to calculate d(tw)/d(ts) + ! + ! output variables + ! + ! tztr : d(tz)/d(tr) + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: xt,c_0,c_d,w_0,w_d,zc,zw,z + real(kind=kind_phys), intent(out) :: tztr + + if ( xt > zero ) then + if ( z <= zc ) then + ! tztr = 1.0/(1.0-w_0+c_0)+z*(w_d-c_d)/(1.0-w_0+c_0) + tztr = (1.0+z*(w_d-c_d))/(1.0-w_0+c_0) + elseif ( z > zc .and. z < zw ) then + ! tztr = (1.0+c_0)/(1.0-w_0+c_0)+z*w_d/(1.0-w_0+c_0) + tztr = (1.0+c_0+z*w_d)/(1.0-w_0+c_0) + elseif ( z >= zw ) then + tztr = 1.0 + endif + elseif ( xt == zero ) then + if ( z <= zc ) then + ! tztr = 1.0/(1.0+c_0)-z*c_d/(1.0+c_0) + tztr = (1.0-z*c_d)/(1.0+c_0) + else + tztr = 1.0 + endif + else + tztr = 1.0 + endif + + ! write(*,'(a,i4,9f9.4))') ' cal_tztr : ',kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr + end subroutine cal_tztr + + !>\ingroup gfs_nst_main_mod + !> This subroutine contains the upper ocean cool-skin parameterization + !! (Fairall et al, 1996 \cite fairall_et_al_1996). + subroutine cool_skin(ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le,deltat_c,z_c,c_0,c_d) + ! + ! upper ocean cool-skin parameterizaion, fairall et al, 1996. + ! + ! input: + ! ustar_a : atmosphreic friction velocity at the air-sea interface (m/s) + ! f_nsol : the "nonsolar" part of the surface heat flux (w/m^s) + ! f_sol_0 : solar radiation at the ocean surface (w/m^2) + ! evap : latent heat flux (w/m^2) + ! sss : ocean upper mixed layer salinity (ppu) + ! alpha : thermal expansion coefficient + ! beta : saline contraction coefficient + ! rho_w : oceanic density + ! rho_a : atmospheric density + ! ts : oceanic surface temperature + ! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes + ! hl_ts : d(hl)/d(ts) + ! grav : gravity + ! le : + ! + ! output: + ! deltat_c: cool-skin temperature correction (degrees k) + ! z_c : molecular sublayer (cool-skin) thickness (m) + ! c_0 : coefficient1 to calculate d(tz)/d(ts) + ! c_d : coefficient2 to calculate d(tz)/d(ts) + + ! + real(kind=kind_phys), intent(in) :: ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le + real(kind=kind_phys), intent(out) :: deltat_c,z_c,c_0,c_d + ! declare local variables + real(kind=kind_phys), parameter :: a1=0.065, a2=11.0, a3=6.6e-5, a4=8.0e-4, tcw=0.6, tcwi=1.0/tcw + real(kind=kind_phys) :: a_c,b_c,zc_ts,bc1,bc2 + real(kind=kind_phys) :: xi,hb,ustar1_a,bigc,deltaf,fxp + real(kind=kind_phys) :: zcsq + real(kind=kind_phys) :: cc1,cc2,cc3 + + + z_c = z_c_ini ! initial guess + + ustar1_a = max(ustar_a,ustar_a_min) + + call sw_rad_skin(z_c,fxp) + deltaf = f_sol_0*fxp + + hb = alpha*(f_nsol-deltaf)+beta*sss*cp_w*evap/le + bigc = 16*grav*cp_w*(rho_w*visw)**3/(rho_a*rho_a*kw*kw) + + if ( hb > 0 ) then + xi = 6./(1+(bigc*hb/ustar1_a**4)**0.75)**0.3333333 + else + xi = 6.0 + endif + z_c = min(z_c_max,xi*visw/(sqrt(rho_a/rho_w)*ustar1_a )) + + call sw_rad_skin(z_c,fxp) + + deltaf = f_sol_0*fxp + deltaf = f_nsol - deltaf + if ( deltaf > 0 ) then + deltat_c = deltaf * z_c / kw + else + deltat_c = zero + z_c = zero + endif + ! + ! calculate c_0 & c_d + ! + if ( z_c > zero ) then + cc1 = 6.0*visw / (tcw*ustar1_a*sqrt(rho_a/rho_w)) + cc2 = bigc*alpha / max(ustar_a,ustar_a_min)**4 + cc3 = beta*sss*cp_w/(alpha*le) + zcsq = z_c * z_c + a_c = a2 + a3/zcsq - (a3/(a4*z_c)+a3/zcsq) * exp(-z_c/a4) + + if ( hb > zero .and. zcsq > zero .and. alpha > zero) then + bc1 = zcsq * (q_ts+cc3*hl_ts) + bc2 = zcsq * f_sol_0*a_c - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq) + zc_ts = bc1/bc2 + ! b_c = z_c**2*(q_ts+cc3*hl_ts)/(z_c**2*f_sol_0*a_c-4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*z_c**2)) ! d(z_c)/d(ts) + b_c = (q_ts+cc3*hl_ts)/(f_sol_0*a_c & + - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq*zcsq)) ! d(z_c)/d(ts) + c_0 = (z_c*q_ts+(f_nsol-deltaf-f_sol_0*a_c*z_c)*b_c)*tcwi + c_d = (f_sol_0*a_c*z_c*b_c-q_ts)*tcwi + + else + b_c = zero + zc_ts = zero + c_0 = z_c*q_ts*tcwi + c_d = -q_ts*tcwi + endif + + ! if ( c_0 < 0.0 ) then + ! write(*,'(a,2f12.6,10f10.6)') ' c_0, c_d = ',c_0,c_d,b_c,zc_ts,hb,bc1,bc2,z_c,cc1,cc2,cc3,z_c**2 + ! endif + + ! c_0 = z_c*q_ts/tcw + ! c_d = -q_ts/tcw + + else + c_0 = zero + c_d = zero + endif ! if ( z_c > 0.0 ) then + + end subroutine cool_skin + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + !! This function calculates a definitive integral of an exponential curve (power of 2). + real function int_epn(z1,z2,zmx,ztr,n) + ! + ! abstract: calculate a definitive integral of an exponetial curve (power of 2) + ! + real(kind_phys) :: z1,z2,zmx,ztr,zi + real(kind_phys) :: fa,fb,fi,int + integer :: m,i,n + + m = nint((z2-z1)/delz) + fa = exp(-exp_const*((z1-zmx)/(ztr-zmx))**n) + fb = exp(-exp_const*((z2-zmx)/(ztr-zmx))**n) + int = zero + do i = 1, m-1 + zi = z1 + delz*float(i) + fi = exp(-exp_const*((zi-zmx)/(ztr-zmx))**n) + int = int + fi + enddo + int_epn = delz*((fa+fb)/2.0 + int) + end function int_epn + + !>\ingroup gfs_nst_main_mod + !! This subroutine resets the value of xt,xs,xu,xv,xz. + subroutine dtl_reset_cv(xt,xs,xu,xv,xz) + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz + xt = zero + xs = zero + xu = zero + xv = zero + xz = z_w_max + end subroutine dtl_reset_cv + + !>\ingroup gfs_nst_main_mod + !! This subroutine resets the value of xt,xs,xu,xv,xz,xtts,xzts. + subroutine dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts + xt = zero + xs = zero + xu = zero + xv = zero + xz = z_w_max + xtts = zero + xzts = zero + end subroutine dtl_reset + +end module nst_module diff --git a/physics/SFC_Layer/UFS/module_nst_parameters.f90 b/physics/SFC_Layer/UFS/module_nst_parameters.f90 new file mode 100644 index 000000000..5308345e2 --- /dev/null +++ b/physics/SFC_Layer/UFS/module_nst_parameters.f90 @@ -0,0 +1,156 @@ +!>\file module_nst_parameters.f90 +!! This file contains constants and paramters used in GFS +!! near surface sea temperature scheme. + +!>\defgroup nst_parameters GFS NSST Parameter Module +!! \ingroup gfs_nst_main_mod +!! This module contains constants and parameters used in GFS +!! near surface sea temperature scheme. +!! history: +!! 20210305: X.Li, reduce z_w_max from 30 m to 20 m +module module_nst_parameters + + use machine, only : kind_phys + ! + ! air constants and coefficients from the atmospehric model + use physcons, only: & + eps => con_eps & !< con_rd/con_rv (nd) + ,cp_a => con_cp & !< spec heat air @p (j/kg/k) + ,epsm1 => con_epsm1 & !< eps - 1 (nd) + ,hvap => con_hvap & !< lat heat h2o cond (j/kg) + ,sigma_r => con_sbc & !< stefan-boltzmann (w/m2/k4) + ,grav => con_g & !< acceleration due to gravity (kg/m/s^2) + ,omega => con_omega & !< ang vel of earth (1/s) + ,rvrdm1 => con_fvirt & !< con_rv/con_rd-1. (nd) + ,rd => con_rd & !< gas constant air (j/kg/k) + ,rocp => con_rocp & !< r/cp + ,pi => con_pi + + implicit none + + private + + public :: sigma_r + public :: zero, one, half + public :: niter_conv, niter_z_w, niter_sfs + public :: z_w_max, z_w_min, z_w_ini, z_c_max, z_c_ini, eps_z_w, eps_conv, eps_sfs + public :: ri_c, ri_g, omg_m, omg_sh, tc_w, visw, cp_w, t0k, ustar_a_min, delz, exp_const + public :: rad2deg, const_rot, tw_max, sst_max, solar_time_6am, tau_min, wd_max + + real(kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, half = 0.5_kind_phys + ! + ! note: take timestep from here later + integer :: & + niter_conv = 5, & + niter_z_w = 5, & + niter_sfs = 5 + ! + ! general constants + real (kind=kind_phys), parameter :: & + sec_in_day = 86400. & + ,sec_in_hour = 3600. & + ,solar_time_6am = 21600.0 & + ,const_rot = 0.000073 & !< constant to calculate corioli force + ,ri_c = 0.65 & + ,ri_g = 0.25 & + ,eps_z_w = 0.01 & !< criteria to finish iterations for z_w + ,eps_conv = 0.01 & !< criteria to finish iterations for d_conv + ,eps_sfs = 0.01 & !< criteria to finish iterations for d_sfs + ,z_w_max = 20.0 & !< max warm layer thickness + ,z_w_min = 0.2 & !< min warm layer thickness + ,z_w_ini = 0.2 & !< initial warm layer thickness in dtl_onset + ,z_c_max = 0.01 & !< maximum of sub-layer thickness (m) + ,z_c_ini = 0.001 & !< initial value of z_c + ,ustar_a_min = 0.031 & !< minimum of friction wind speed (m/s): 0.031 ~ 1m/s at 10 m hight + ,tau_min = 0.005 & !< minimum of wind stress for dtm + ,exp_const = 9.5 & !< coefficient in exponet profile + ,delz = 0.1 & !< vertical increment for integral calculation (m) + ,von = 0.4 & !< von karman's "constant" + ,t0k = 273.16 & !< celsius to kelvin + ,gray = 0.97 & + ,sst_max = 308.16 & + ,tw_max = 5.0 & + ,wd_max = 2.0 & + ,omg_m = 1.0 & !< trace factor to apply salinity effect + ,omg_rot = 1.0 & !< trace factor to apply rotation effect + ,omg_sh = 1.0 & !< trace factor to apply sensible heat due to rainfall effect + ,visw = 1.e-6 & !< m2/s kinematic viscosity water + ,novalue = 0 & + ,smallnumber = 1.e-6 & + ,timestep_oc = sec_in_day/8. & !< time step in the ocean model (3 hours) + ,radian = 2.*pi/180. & + ,rad2deg = 180./pi & + ,cp_w = 4000. & !< specific heat water (j/kg/k ) + ,rho0_w = 1022.0 & !< density water (kg/m3 ) (or 1024.438) + ,vis_w = 1.e-6 & !< kinematic viscosity water (m2/s ) + ,tc_w = 0.6 & !< thermal conductivity water (w/m/k ) + ,capa_w = 3950.0 & !< heat capacity of sea water ! + ,thref = 1.0e-3 !< reference value of specific volume (m**3/kg) + +!!$!============================================ +!!$ +!!$ ,lvapor=2.453e6 & ! latent heat of vaporization note: make it function of t ????? note the same as hvap +!!$ ,alpha=1 ! thermal expansion coefficient +!!$ ,beta ! saline contraction coefficient +!!$ ,cp=1 !=1 specific heat of sea water +!!$ ,g=1 ! acceleration due to gravity +!!$ ,kw=1 ! thermal conductivity of water +!!$ ,nu=1 !kinematic wiscosity +!!$ ,rho_w=1 !water density +!!$ ,rho_a=1 !air density +!!$ ,l_vapr=2.453e6 +!!$ ,novalue=--1.0e+10 +!!$ +!!$c factors +!!$ beta=1.2 !given as 1.25 in fairall et al.(1996) +!!$ von=0.4 ! von karman's "constant" +!!$c fdg=1.00 ! fairall's lkb rr to von karman adjustment +!!$ fdg=1.00 !based on results from flux workshop august 1995 +!!$ tok=273.16 ! celsius to kelvin +!!$ twopi=3.14159*2. +!!$ +!!$c air constants and coefficients +!!$ rgas=287.1 !j/kg/k gas const. dry air +!!$ xlv=(2.501-0.00237*ts)*1e+6 !j/kg latent heat of vaporization at ts +!!$ cpa=1004.67 !j/kg/k specific heat of dry air (businger 1982) +!!$ cpv=cpa*(1+0.84*q) !moist air - currently not used (businger 1982) +!!$ rhoa=p*100./(rgas*(t+tok)*(1.+.61*q)) !kg/m3 moist air density ( " ) +!!$ visa=1.326e-5*(1+6.542e-3*t+8.301e-6*t*t-4.84e-9*t*t*t) !m2/s +!!$ !kinematic viscosity of dry air - andreas (1989) crrel rep. 89-11 +!!$c +!!$c cool skin constants +!!$ al=2.1e-5*(ts+3.2)**0.79 !water thermal expansion coefft. +!!$ be=0.026 !salinity expansion coefft. +!!$ cpw=4000. !j/kg/k specific heat water +!!$ rhow=1022. !kg/m3 density water +!!$ visw=1.e-6 !m2/s kinematic viscosity water +!!$ tcw=0.6 !w/m/k thermal conductivity water +!!$ bigc=16.*grav*cpw*(rhow*visw)**3/(tcw*tcw*rhoa*rhoa) +!!$ wetc=0.622*xlv*qs/(rgas*(ts+tok)**2) !correction for dq;slope of sat. vap. +!!$ +!!$! +!!$! functions +!!$ +!!$ +!!$ real, parameter :: timestep=86400. !integration time step, second +!!$ +!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 +!!$ real, parameter :: capa =3950.0 !heat capacity of sea water +!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 +!!$ real , parameter :: hslab=50.0 !slab ocean depth +!!$ real , parameter :: bad=-1.0e+10 +!!$ real , parameter :: tmin=2.68e+02 +!!$ real , parameter :: tmax=3.11e+02 +!!$ +!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 +!!$ real, parameter :: capa =3950.0 !heat capacity of sea water +!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 +!!$ real, parameter :: tmin=2.68e+02 !normal minimal temp +!!$ real, parameter :: tmax=3.11e+02 !normal max temp +!!$ real, parameter :: smin=1.0 !normal minimal salt +!!$ real, parameter :: smax=50. !normal maximum salt +!!$ real, parameter :: visct=1.e-5 !viscocity for temperature diffusion +!!$ real, parameter :: viscs=1.e-5 !viscocity for salt diffusion +!!$ +!!$ +end module module_nst_parameters diff --git a/physics/SFC_Layer/UFS/module_nst_water_prop.f90 b/physics/SFC_Layer/UFS/module_nst_water_prop.f90 new file mode 100644 index 000000000..858659e90 --- /dev/null +++ b/physics/SFC_Layer/UFS/module_nst_water_prop.f90 @@ -0,0 +1,734 @@ + +!>\file module_nst_water_prop.f90 +!! This file contains GFS NSST water property subroutines. + +!>\defgroup waterprop GFS NSST Water Property +!!This module contains GFS NSST water property subroutines. +!!\ingroup gfs_nst_main_mod +module module_nst_water_prop + use machine , only : kind_phys + use module_nst_parameters , only : t0k, zero, one, half + + implicit none + ! + private + public :: rhocoef, density, sw_rad_skin, grv, sw_ps_9b, sw_ps_9b_aw, get_dtzm_point, get_dtzm_2d + + ! + interface sw_ps_9b + module procedure sw_ps_9b + end interface sw_ps_9b + interface sw_ps_9b_aw + module procedure sw_ps_9b_aw + end interface sw_ps_9b_aw + ! + interface sw_rad + module procedure sw_fairall_6exp_v1 ! sw_wick_v1 + end interface sw_rad + interface sw_rad_aw + module procedure sw_fairall_6exp_v1_aw + end interface sw_rad_aw + interface sw_rad_sum + module procedure sw_fairall_6exp_v1_sum + end interface sw_rad_sum + interface sw_rad_upper + module procedure sw_soloviev_3exp_v2 + end interface sw_rad_upper + interface sw_rad_upper_aw + module procedure sw_soloviev_3exp_v2_aw + end interface sw_rad_upper_aw + interface sw_rad_skin + module procedure sw_ohlmann_v1 + end interface sw_rad_skin +contains + ! ------------------------------------------------------ + !>\ingroup gfs_nst_main_mod + !! This subroutine computes thermal expansion coefficient (alpha) + !! and saline contraction coefficient (beta). + subroutine rhocoef(t, s, rhoref, alpha, beta) + ! ------------------------------------------------------ + + ! compute thermal expansion coefficient (alpha) + ! and saline contraction coefficient (beta) using + ! the international equation of state of sea water + ! (1980). ref: pond and pickard, introduction to + ! dynamical oceanography, pp310. + ! note: compression effects are not included + + real(kind=kind_phys), intent(in) :: t, s, rhoref + real(kind=kind_phys), intent(out) :: alpha, beta + real(kind=kind_phys) :: tc + + tc = t - t0k + + alpha = & + 6.793952e-2 & + - 2.0 * 9.095290e-3 * tc + 3.0 * 1.001685e-4 * tc**2 & + - 4.0 * 1.120083e-6 * tc**3 + 5.0 * 6.536332e-9 * tc**4 & + - 4.0899e-3 * s & + + 2.0 * 7.6438e-5 * tc * s - 3.0 * 8.2467e-7 * tc**2 * s & + + 4.0 * 5.3875e-9 * tc**3 * s & + + 1.0227e-4 * s**1.5 - 2.0 * 1.6546e-6 * tc * s**1.5 + + ! note: rhoref - specify + ! + alpha = -alpha/rhoref + + beta = & + 8.24493e-1 - 4.0899e-3 * tc & + + 7.6438e-5 * tc**2 - 8.2467e-7 * tc**3 & + + 5.3875e-9 * tc**4 - 1.5 * 5.72466e-3 * s**.5 & + + 1.5 * 1.0227e-4 * tc * s**.5 & + - 1.5 * 1.6546e-6 * tc**2 * s**.5 & + + 2.0 * 4.8314e-4 * s + + beta = beta / rhoref + + end subroutine rhocoef + ! ---------------------------------------- + !>\ingroup gfs_nst_main_mod + !! This subroutine computes sea water density. + subroutine density(t, s, rho) + ! ---------------------------------------- + + ! input + real(kind=kind_phys), intent(in) :: t !unit, k + real(kind=kind_phys), intent(in) :: s !unit, 1/1000 + ! output + real(kind=kind_phys), intent(out) :: rho !unit, kg/m^3 + ! local + real(kind=kind_phys) :: tc + + ! compute density using the international equation + ! of state of sea water 1980, (pond and pickard, + ! introduction to dynamical oceanography, pp310). + ! compression effects are not included + + rho = zero + tc = t - t0k + + ! effect of temperature on density (lines 1-3) + ! effect of temperature and salinity on density (lines 4-8) + rho = & + 999.842594 + 6.793952e-2 * tc & + - 9.095290e-3 * tc**2 + 1.001685e-4 * tc**3 & + - 1.120083e-6 * tc**4 + 6.536332e-9 * tc**5 & + + 8.24493e-1 * s - 4.0899e-3 * tc * s & + + 7.6438e-5 * tc**2 * s - 8.2467e-7 * tc**3 * s & + + 5.3875e-9 * tc**4 * s - 5.72466e-3 * s**1.5 & + + 1.0227e-4 * tc * s**1.5 - 1.6546e-6 * tc**2 * s**1.5 & + + 4.8314e-4 * s**2 + + end subroutine density + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + !! This subroutine computes the fraction of the solar radiation absorbed + !! by the depth z following Paulson and Simpson (1981) \cite paulson_and_simpson_1981 . + elemental subroutine sw_ps_9b(z,fxp) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: fxp + real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + ! + if(z>zero) then + fxp=one-(f(1)*exp(-z/gamma(1))+f(2)*exp(-z/gamma(2))+f(3)*exp(-z/gamma(3))+ & + f(4)*exp(-z/gamma(4))+f(5)*exp(-z/gamma(5))+f(6)*exp(-z/gamma(6))+ & + f(7)*exp(-z/gamma(7))+f(8)*exp(-z/gamma(8))+f(9)*exp(-z/gamma(9))) + else + fxp=zero + endif + ! + end subroutine sw_ps_9b + ! + !====================== + ! + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + !! This subroutine + elemental subroutine sw_ps_9b_aw(z,aw) + ! + ! d(fw)/d(z) for 9-band + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: aw + real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + ! + if(z>zero) then + aw=(f(1)/gamma(1))*exp(-z/gamma(1))+(f(2)/gamma(2))*exp(-z/gamma(2))+(f(3)/gamma(3))*exp(-z/gamma(3))+ & + (f(1)/gamma(4))*exp(-z/gamma(4))+(f(2)/gamma(5))*exp(-z/gamma(5))+(f(6)/gamma(6))*exp(-z/gamma(6))+ & + (f(1)/gamma(7))*exp(-z/gamma(7))+(f(2)/gamma(8))*exp(-z/gamma(8))+(f(9)/gamma(9))*exp(-z/gamma(9)) + else + aw=zero + endif + ! + end subroutine sw_ps_9b_aw + ! + !====================== + !>\ingroup gfs_nst_main_mod + !! This subroutine computes fraction of the solar radiation absorbed by the ocean at the depth + !! z (Fairall et al. (1996) \cite fairall_et_al_1996, p. 1298) following Paulson and Simpson + !! (1981) \cite paulson_and_simpson_1981 . + elemental subroutine sw_fairall_6exp_v1(z,fxp) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: fxp + + real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + real(kind=kind_phys), dimension(9) :: zgamma + real(kind=kind_phys), dimension(9) :: f_c + ! + if(z>zero) then + zgamma=z/gamma + f_c=f*(one-one/zgamma*(one-exp(-zgamma))) + fxp=sum(f_c) + else + fxp=zero + endif + ! + end subroutine sw_fairall_6exp_v1 + ! + !====================== + ! + ! + !>\ingroup gfs_nst_main_mod + !! This subroutine calculates fraction of the solar radiation absorbed by the + !! ocean at the depth z (fairall et al.(1996) \cite fairall_et_al_1996; p.1298) + !! following Paulson and Simpson (1981) \cite paulson_and_simpson_1981. + elemental subroutine sw_fairall_6exp_v1_aw(z,aw) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! aw: d(fxp)/d(z) + ! + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: aw + + real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + real(kind=kind_phys), dimension(9) :: zgamma + real(kind=kind_phys), dimension(9) :: f_aw + ! + if(z>zero) then + zgamma=z/gamma + f_aw=(f/z)*((gamma/z)*(one-exp(-zgamma))-exp(-zgamma)) + aw=sum(f_aw) + ! write(*,'(a,f6.2,f12.6,9f10.4)') 'z,aw in sw_rad_aw : ',z,aw,f_aw + else + aw=zero + endif + ! + end subroutine sw_fairall_6exp_v1_aw + ! + !>\ingroup gfs_nst_main_mod + !! This subroutine computes fraction of the solar radiation absorbed by the ocean at the + !! depth z (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1298) following Paulson and + !! Simpson (1981) \cite paulson_and_simpson_1981 . + !>\param[in] z depth (m) + !>\param[out] sum for convection depth calculation + elemental subroutine sw_fairall_6exp_v1_sum(z,sum) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! sum: for convection depth calculation + ! + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: sum + + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + real(kind=kind_phys), dimension(9) :: zgamma + real(kind=kind_phys), dimension(9) :: f_sum + ! + ! zgamma=z/gamma + ! f_sum=(zgamma/z)*exp(-zgamma) + ! sum=sum(f_sum) + + sum=( one/gamma(1))*exp(-z/gamma(1))+(one/gamma(2))*exp(-z/gamma(2))+(one/gamma(3))*exp(-z/gamma(3))+ & + (one/gamma(4))*exp(-z/gamma(4))+(one/gamma(5))*exp(-z/gamma(5))+(one/gamma(6))*exp(-z/gamma(6))+ & + (one/gamma(7))*exp(-z/gamma(7))+(one/gamma(8))*exp(-z/gamma(8))+(one/gamma(9))*exp(-z/gamma(9)) + ! + end subroutine sw_fairall_6exp_v1_sum + ! + !====================== + !>\ingroup gfs_nst_main_mod + !! Solar radiation absorbed by the ocean at the depth z (Fairall et al. (1996) + !! \cite fairall_et_al_1996, p.1298) + !!\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) + !!\param[in] z depth (m) + !!\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) + elemental subroutine sw_fairall_simple_v1(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z,f_sol_0 + real(kind=kind_phys), intent(out) :: df_sol_z + ! + if(z>zero) then + df_sol_z=f_sol_0*(0.137+11.0*z-6.6e-6/z*(one-exp(-z/8.e-4))) + else + df_sol_z=zero + endif + ! + end subroutine sw_fairall_simple_v1 + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + !! solar radiation absorbed by the ocean at the depth z (Zeng and Beljaars (2005) + !! \cite zeng_and_beljaars_2005 , p.5). + !>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) + !>\param[in] z depth (m) + !>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) + elemental subroutine sw_wick_v1(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (zeng and beljaars, 2005, p.5) + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z,f_sol_0 + real(kind=kind_phys), intent(out) :: df_sol_z + ! + if(z>zero) then + df_sol_z=f_sol_0*(0.065+11.0*z-6.6e-5/z*(one-exp(-z/8.e-4))) + else + df_sol_z=zero + endif + ! + end subroutine sw_wick_v1 + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + !! This subroutine computes solar radiation absorbed by the ocean at the depth z + !! (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1301) following + !! Soloviev and Vershinsky (1982) \cite soloviev_and_vershinsky_1982. + !>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) + !>\param[in] z depth (m) + !>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) + elemental subroutine sw_soloviev_3exp_v1(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) + ! following soloviev, 1982 + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z,f_sol_0 + real(kind=kind_phys), intent(out) :: df_sol_z + real(kind=kind_phys), dimension(3) :: f_c + real(kind=kind_phys), dimension(3), parameter :: f=(/0.45,0.27,0.28/) + real(kind=kind_phys), dimension(3), parameter :: gamma=(/12.82,0.357,0.014/) + ! + if(z>zero) then + f_c = f*gamma(int(one-exp(-z/gamma))) + df_sol_z = f_sol_0*(one-sum(f_c)/z) + else + df_sol_z = zero + endif + ! + end subroutine sw_soloviev_3exp_v1 + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) + ! following soloviev, 1982 + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z,f_sol_0 + real(kind=kind_phys), intent(out) :: df_sol_z + ! + if(z>zero) then + df_sol_z=f_sol_0*(one & + -(0.28*0.014*(one-exp(-z/0.014)) & + + 0.27*0.357*(one-exp(-z/0.357)) & + + 0.45*12.82*(one-exp(-z/12.82)))/z & + ) + else + df_sol_z=zero + endif + ! + end subroutine sw_soloviev_3exp_v2 + + !>\ingroup gfs_nst_main_mod + elemental subroutine sw_soloviev_3exp_v2_aw(z,aw) + ! + ! aw = d(fxp)/d(z) + ! following soloviev, 1982 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! aw: d(fxp)/d(z) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: aw + real(kind=kind_phys) :: fxp + ! + if(z>zero) then + fxp=(one & + -(0.28*0.014*(one-exp(-z/0.014)) & + + 0.27*0.357*(one-exp(-z/0.357)) & + + 0.45*12.82*(one-exp(-z/12.82)))/z & + ) + aw=one-fxp-(0.28*exp(-z/0.014)+0.27*exp(-z/0.357)+0.45*exp(-z/12.82)) + else + aw=zero + endif + end subroutine sw_soloviev_3exp_v2_aw + ! + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + elemental subroutine sw_ohlmann_v1(z,fxp) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: fxp + ! + if(z>zero) then + fxp=.065+11.*z-6.6e-5/z*(one-exp(-z/8.0e-4)) + else + fxp=zero + endif + ! + end subroutine sw_ohlmann_v1 + ! + + !>\ingroup gfs_nst_main_mod + real(kind_phys) function grv(x) + real(kind=kind_phys) :: x !< sin(lat) + real(kind=kind_phys) :: gamma,c1,c2,c3,c4 + gamma=9.7803267715 + c1=0.0052790414 + c2=0.0000232718 + c3=0.0000001262 + c4=0.0000000007 + + grv=gamma*(one+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8)) + end function grv + + !>\ingroup gfs_nst_main_mod + !>This subroutine computes solar time from the julian date. + subroutine solar_time_from_julian(jday,xlon,soltim) + ! + ! calculate solar time from the julian date + ! + real(kind=kind_phys), intent(in) :: jday + real(kind=kind_phys), intent(in) :: xlon + real(kind=kind_phys), intent(out) :: soltim + real(kind=kind_phys) :: fjd,xhr,xmin,xsec,intime + ! + fjd=jday-floor(jday) + fjd=jday + xhr=floor(fjd*24.0)-sign(12.0,fjd-half) + xmin=nint(fjd*1440.0)-(xhr+sign(12.0,fjd-half))*60.0 + xsec=zero + intime=xhr+xmin/60.0+xsec/3600.0+24.0 + soltim=mod(xlon/15.0+intime,24.0)*3600.0 + end subroutine solar_time_from_julian + + ! + !*********************************************************************** + ! + !>\ingroup gfs_nst_main_mod + !> This subroutine computes julian day and fraction from year, + !! month, day and time UTC. + subroutine compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) + !fpp$ noconcur r + !$$$ subprogram documentation block + ! . . . . + ! subprogram: compjd computes julian day and fraction + ! prgmmr: kenneth campana org: w/nmc23 date: 89-07-07 + ! + ! abstract: computes julian day and fraction + ! from year, month, day and time utc. + ! + ! program history log: + ! 77-05-06 ray orzol,gfdl + ! 98-05-15 iredell y2k compliance + ! + ! usage: call compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) + ! input argument list: + ! jyr - year (4 digits) + ! jmnth - month + ! jday - day + ! jhr - hour + ! jmn - minutes + ! output argument list: + ! jd - julian day. + ! fjd - fraction of the julian day. + ! + ! subprograms called: + ! iw3jdn compute julian day number + ! + ! attributes: + ! language: fortran. + ! + !$$$ + ! + integer :: jyr,jmnth,jday,jhr,jmn,jd + integer :: iw3jdn + real (kind=kind_phys) fjd + jd=iw3jdn(jyr,jmnth,jday) + if(jhr.lt.12) then + jd=jd-1 + fjd=half+jhr/24.+jmn/1440. + else + fjd=(jhr-12)/24.+jmn/1440. + endif + end subroutine compjd + + !>\ingroup gfs_nst_main_mod + !>This subroutine computes dtm (the mean of \f$dT(z)\f$). + subroutine get_dtzm_point(xt,xz,dt_cool,zc,z1,z2,dtm) + ! ===================================================================== ! + ! ! + ! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! + ! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool ! + ! ! + ! usage: ! + ! ! + ! call get_dtm12 ! + ! ! + ! inputs: ! + ! (xt,xz,dt_cool,zc,z1,z2, ! + ! outputs: ! + ! dtm) ! + ! ! + ! program history log: ! + ! ! + ! 2015 -- xu li createad original code ! + ! inputs: ! + ! xt - real, heat content in dtl 1 ! + ! xz - real, dtl thickness 1 ! + ! dt_cool - real, sub-layer cooling amount 1 ! + ! zc - sub-layer cooling thickness 1 ! + ! z1 - lower bound of depth of sea temperature 1 ! + ! z2 - upper bound of depth of sea temperature 1 ! + ! outputs: ! + ! dtm - mean of dT(z) (z1 to z2) 1 ! + ! + real (kind=kind_phys), intent(in) :: xt,xz,dt_cool,zc,z1,z2 + real (kind=kind_phys), intent(out) :: dtm + ! Local variables + real (kind=kind_phys) :: dt_warm,dtw,dtc + + ! + ! get the mean warming in the range of z=z1 to z=z2 + ! + dtw = zero + if ( xt > zero ) then + dt_warm = (xt+xt)/xz ! Tw(0) + if ( z1 < z2) then + if ( z2 < xz ) then + dtw = dt_warm*(one-(z1+z2)/(xz+xz)) + elseif ( z1 < xz .and. z2 >= xz ) then + dtw = half*(one-z1/xz)*dt_warm*(xz-z1)/(z2-z1) + endif + elseif ( z1 == z2 ) then + if ( z1 < xz ) then + dtw = dt_warm*(one-z1/xz) + endif + endif + endif + ! + ! get the mean cooling in the range of z=z1 to z=z2 + ! + dtc = zero + if ( zc > zero ) then + if ( z1 < z2) then + if ( z2 < zc ) then + dtc = dt_cool*(one-(z1+z2)/(zc+zc)) + elseif ( z1 < zc .and. z2 >= zc ) then + dtc = half*(one-z1/zc)*dt_cool*(zc-z1)/(z2-z1) + endif + elseif ( z1 == z2 ) then + if ( z1 < zc ) then + dtc = dt_cool*(one-z1/zc) + endif + endif + endif + + ! + ! get the mean T departure from Tf in the range of z=z1 to z=z2 + ! + dtm = dtw - dtc + + end subroutine get_dtzm_point + + !>\ingroup gfs_nst_main_mod + subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,nth,dtm) + !subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) + ! ===================================================================== ! + ! ! + ! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! + ! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool ! + ! ! + ! usage: ! + ! ! + ! call get_dtzm_2d ! + ! ! + ! inputs: ! + ! (xt,xz,dt_cool,zc,z1,z2, ! + ! outputs: ! + ! dtm) ! + ! ! + ! program history log: ! + ! ! + ! 2015 -- xu li createad original code ! + ! inputs: ! + ! xt - real, heat content in dtl 1 ! + ! xz - real, dtl thickness 1 ! + ! dt_cool - real, sub-layer cooling amount 1 ! + ! zc - sub-layer cooling thickness 1 ! + ! wet - logical, flag for wet point (ocean or lake) 1 ! + ! icy - logical, flag for ice point (ocean or lake) 1 ! + ! nx - integer, dimension in x-direction (zonal) 1 ! + ! ny - integer, dimension in y-direction (meridional) 1 ! + ! z1 - lower bound of depth of sea temperature 1 ! + ! z2 - upper bound of depth of sea temperature 1 ! + ! nth - integer, num of openmp thread 1 ! + ! outputs: ! + ! dtm - mean of dT(z) (z1 to z2) 1 ! + ! + integer, intent(in) :: nx,ny, nth + real (kind=kind_phys), dimension(nx,ny), intent(in) :: xt,xz,dt_cool,zc + logical, dimension(nx,ny), intent(in) :: wet + ! logical, dimension(nx,ny), intent(in) :: wet,icy + real (kind=kind_phys), intent(in) :: z1,z2 + real (kind=kind_phys), dimension(nx,ny), intent(out) :: dtm + ! Local variables + integer :: i,j + real (kind=kind_phys) :: dt_warm, dtw, dtc, xzi + + + !$omp parallel do num_threads (nth) private(j,i,dtw,dtc,xzi) + do j = 1, ny + do i= 1, nx + + dtm(i,j) = zero ! initialize dtm + + if ( wet(i,j) ) then + ! + ! get the mean warming in the range of z=z1 to z=z2 + ! + dtw = zero + if ( xt(i,j) > zero ) then + xzi = one / xz(i,j) + dt_warm = (xt(i,j)+xt(i,j)) * xzi ! Tw(0) + if (z1 < z2) then + if ( z2 < xz(i,j) ) then + dtw = dt_warm * (one-half*(z1+z2)*xzi) + elseif (z1 < xz(i,j) .and. z2 >= xz(i,j) ) then + dtw = half*(one-z1*xzi)*dt_warm*(xz(i,j)-z1)/(z2-z1) + endif + elseif (z1 == z2 ) then + if (z1 < xz(i,j) ) then + dtw = dt_warm * (one-z1*xzi) + endif + endif + endif + ! + ! get the mean cooling in the range of z=0 to z=zsea + ! + dtc = zero + if ( zc(i,j) > zero ) then + if ( z1 < z2) then + if ( z2 < zc(i,j) ) then + dtc = dt_cool(i,j) * (one-(z1+z2)/(zc(i,j)+zc(i,j))) + elseif ( z1 < zc(i,j) .and. z2 >= zc(i,j) ) then + dtc = half*(one-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1) + endif + elseif ( z1 == z2 ) then + if ( z1 < zc(i,j) ) then + dtc = dt_cool(i,j) * (one-z1/zc(i,j)) + endif + endif + endif + ! get the mean T departure from Tf in the range of z=z1 to z=z2 + dtm(i,j) = dtw - dtc + endif ! if ( wet(i,j)) then + enddo + enddo + ! + + end subroutine get_dtzm_2d + +end module module_nst_water_prop diff --git a/physics/sfc_diag.f b/physics/SFC_Layer/UFS/sfc_diag.f similarity index 100% rename from physics/sfc_diag.f rename to physics/SFC_Layer/UFS/sfc_diag.f diff --git a/physics/sfc_diag.meta b/physics/SFC_Layer/UFS/sfc_diag.meta similarity index 98% rename from physics/sfc_diag.meta rename to physics/SFC_Layer/UFS/sfc_diag.meta index a16290b58..f4f83ab04 100644 --- a/physics/sfc_diag.meta +++ b/physics/SFC_Layer/UFS/sfc_diag.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = sfc_diag type = scheme - dependencies = funcphys.f90,machine.F + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F,hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/sfc_diag_post.F90 b/physics/SFC_Layer/UFS/sfc_diag_post.F90 similarity index 75% rename from physics/sfc_diag_post.F90 rename to physics/SFC_Layer/UFS/sfc_diag_post.F90 index c1a43f170..6945e48e9 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/SFC_Layer/UFS/sfc_diag_post.F90 @@ -14,16 +14,17 @@ module sfc_diag_post !! #endif subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, opt_diag, dry, lssav, dtf, con_eps, con_epsm1, pgr,& - t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & + vegtype,t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) use machine, only: kind_phys, kind_dbl_prec implicit none - integer, intent(in) :: im, lsm, lsm_noahmp,opt_diag - logical, intent(in) :: lssav - real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1 + integer, intent(in) :: im, lsm, lsm_noahmp,opt_diag + integer, dimension(:), intent(in) :: vegtype ! vegetation type (integer index) + logical, intent(in) :: lssav + real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1 logical , dimension(:), intent(in) :: dry real(kind=kind_phys), dimension(:), intent(in) :: pgr, u10m, v10m real(kind=kind_phys), dimension(:), intent(inout) :: t2m, q2m, tmpmin, tmpmax, spfhmin, spfhmax @@ -41,12 +42,23 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, opt_diag, dry, lssav, dtf, co errflg = 0 if (lsm == lsm_noahmp) then - if (opt_diag == 2 .or. opt_diag == 3)then +! over shrublands use opt_diag=2 + do i=1, im + if(dry(i)) then + if (vegtype(i) == 6 .or. vegtype(i) == 7 & + .or. vegtype(i) == 16) then + t2m(i) = t2mmp(i) + q2m(i) = q2mp(i) + endif + endif + enddo + + if (opt_diag == 2 .or. opt_diag == 3) then do i=1,im if(dry(i)) then t2m(i) = t2mmp(i) q2m(i) = q2mp(i) - endif + endif enddo endif endif diff --git a/physics/sfc_diag_post.meta b/physics/SFC_Layer/UFS/sfc_diag_post.meta similarity index 95% rename from physics/sfc_diag_post.meta rename to physics/SFC_Layer/UFS/sfc_diag_post.meta index c50d3c4dc..4abb3bac0 100644 --- a/physics/sfc_diag_post.meta +++ b/physics/SFC_Layer/UFS/sfc_diag_post.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = sfc_diag_post type = scheme - dependencies = machine.F + relative_path = ../../ + dependencies = hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -81,6 +82,13 @@ type = real kind = kind_phys intent = in +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent= in [t2mmp] standard_name = temperature_at_2m_from_noahmp long_name = 2 meter temperature from noahmp diff --git a/physics/sfc_diff.f b/physics/SFC_Layer/UFS/sfc_diff.f similarity index 99% rename from physics/sfc_diff.f rename to physics/SFC_Layer/UFS/sfc_diff.f index 6e834537a..c5ed8bfa6 100644 --- a/physics/sfc_diff.f +++ b/physics/SFC_Layer/UFS/sfc_diff.f @@ -60,6 +60,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & ! mg, sfc-perts !intent(in) & flag_iter,redrag, & !intent(in) + & flag_lakefreeze, & !intent(in) & u10m,v10m,sfc_z0_type, & !hafs,z0 type !intent(in) & wet,dry,icy, & !intent(in) & thsfc_loc, & !intent(in) @@ -90,6 +91,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) logical, dimension(:), intent(in) :: flag_iter, dry, icy + logical, dimension(:), intent(in) :: flag_lakefreeze logical, dimension(:), intent(inout) :: wet logical, intent(in) :: thsfc_loc ! Flag for reference pressure in theta calculation @@ -168,7 +170,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type do i=1,im - if(flag_iter(i)) then + if(flag_iter(i) .or. flag_lakefreeze(i)) then ! Need to initialize ztmax arrays ztmax_lnd(i) = 1. ! log(1) = 0 diff --git a/physics/sfc_diff.meta b/physics/SFC_Layer/UFS/sfc_diff.meta similarity index 98% rename from physics/sfc_diff.meta rename to physics/SFC_Layer/UFS/sfc_diff.meta index eb30b8c50..8ca5b24e1 100644 --- a/physics/sfc_diff.meta +++ b/physics/SFC_Layer/UFS/sfc_diff.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = sfc_diff type = scheme - dependencies = machine.F + relative_path = ../../ + dependencies = hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -194,6 +195,13 @@ dimensions = () type = logical intent = in +[flag_lakefreeze] + standard_name = flag_for_lake_water_freeze + long_name = flag for lake water freeze + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in [u10m] standard_name = x_wind_at_10m long_name = 10 meter u wind speed diff --git a/physics/SFC_Layer/UFS/sfc_nst.f90 b/physics/SFC_Layer/UFS/sfc_nst.f90 new file mode 100644 index 000000000..08b1b48e4 --- /dev/null +++ b/physics/SFC_Layer/UFS/sfc_nst.f90 @@ -0,0 +1,664 @@ +!>\file sfc_nst.f90 +!! This file contains the GFS NSST model. + +!> This module contains the CCPP-compliant GFS near-surface sea temperature scheme. +module sfc_nst + + use machine , only : kind_phys, kp => kind_phys + use funcphys , only : fpvs + use module_nst_parameters , only : one, zero, half + use module_nst_parameters , only : t0k, cp_w, omg_m, omg_sh, sigma_r, solar_time_6am, sst_max + use module_nst_parameters , only : ri_c, z_w_max, delz, wd_max, rad2deg, const_rot, tau_min, tw_max + use module_nst_water_prop , only : get_dtzm_point, density, rhocoef, grv, sw_ps_9b + use nst_module , only : cool_skin, dtm_1p, cal_w, cal_ttop, convdepth, dtm_1p_fca + use nst_module , only : dtm_1p_tla, dtm_1p_mwa, dtm_1p_mda, dtm_1p_mta, dtl_reset + ! + implicit none +contains + + !>\defgroup gfs_nst_main_mod GFS Near-Surface Sea Temperature Module + !! This module contains the CCPP-compliant GFS near-surface sea temperature scheme. + !> @{ + !! This subroutine calls the Thermal Skin-layer and Diurnal Thermocline models to update the NSST profile. + !! \section arg_table_sfc_nst_run Argument Table + !! \htmlinclude sfc_nst_run.html + !! + !> \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm + subroutine sfc_nst_run & + ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs: + pi, tgice, sbc, ps, u1, v1, t1, q1, tref, cm, ch, & + lseaspray, fm, fm10, & + prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, & + sinlat, stress, & + sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & + wind, flag_iter, flag_guess, nstf_name1, nstf_name4, & + nstf_name5, lprnt, ipr, thsfc_loc, & + tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & ! --- input/output: + z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, & + qsurf, gflux, cmm, chh, evap, hflx, ep, errmsg, errflg & ! --- outputs: + ) + ! + ! ===================================================================== ! + ! description: ! + ! ! + ! ! + ! usage: ! + ! ! + ! call sfc_nst ! + ! inputs: ! + ! ( im, ps, u1, v1, t1, q1, tref, cm, ch, ! + ! lseaspray, fm, fm10, ! + ! prsl1, prslki, wet, use_lake_model, xlon, sinlat, stress, ! + ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! + ! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, ! + ! nstf_name5, lprnt, ipr, thsfc_loc, ! + ! input/outputs: ! + ! tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, ! + ! z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, ! + ! -- outputs: + ! qsurf, gflux, cmm, chh, evap, hflx, ep ! + ! ) + ! ! + ! ! + ! subprogram/functions called: fpvs, density, rhocoef, cool_skin ! + ! ! + ! program history log: ! + ! 2007 -- xu li createad original code ! + ! 2008 -- s. moorthi adapted to the parallel version ! + ! may 2009 -- y.-t. hou modified to include input lw surface ! + ! emissivity from radiation. also replaced the ! + ! often comfusing combined sw and lw suface ! + ! flux with separate sfc net sw flux (defined ! + ! as dn-up) and lw flux. added a program doc block. ! + ! sep 2009 -- s. moorthi removed rcl and additional reformatting ! + ! and optimization + made pa as input pressure unit.! + ! 2009 -- xu li recreatead the code ! + ! feb 2010 -- s. moorthi added some changes made to the previous ! + ! version ! + ! Jul 2016 -- X. Li, modify the diurnal warming event reset ! + ! ! + ! ! + ! ==================== definition of variables ==================== ! + ! ! + ! inputs: size ! + ! im - integer, horiz dimension 1 ! + ! ps - real, surface pressure (pa) im ! + ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! + ! t1 - real, surface layer mean temperature ( k ) im ! + ! q1 - real, surface layer mean specific humidity im ! + ! tref - real, reference/foundation temperature ( k ) im ! + ! cm - real, surface exchange coeff for momentum (m/s) im ! + ! ch - real, surface exchange coeff heat & moisture(m/s) im ! + ! lseaspray- logical, .t. for parameterization for sea spray 1 ! + ! fm - real, a stability profile function for momentum im ! + ! fm10 - real, a stability profile function for momentum im ! + ! at 10m ! + ! prsl1 - real, surface layer mean pressure (pa) im ! + ! prslki - real, im ! + ! prsik1 - real, im ! + ! prslk1 - real, im ! + ! wet - logical, =T if any ocn/lake water (F otherwise) im ! + ! use_lake_model- logical, =T if flake model is used for lake im ! + ! icy - logical, =T if any ice im ! + ! xlon - real, longitude (radians) im ! + ! sinlat - real, sin of latitude im ! + ! stress - real, wind stress (n/m**2) im ! + ! sfcemis - real, sfc lw emissivity (fraction) im ! + ! dlwflx - real, total sky sfc downward lw flux (w/m**2) im ! + ! sfcnsw - real, total sky sfc netsw flx into ocean (w/m**2) im ! + ! rain - real, rainfall rate (kg/m**2/s) im ! + ! timestep - real, timestep interval (second) 1 ! + ! kdt - integer, time step counter 1 ! + ! solhr - real, fcst hour at the end of prev time step 1 ! + ! xcosz - real, consine of solar zenith angle 1 ! + ! wind - real, wind speed (m/s) im ! + ! flag_iter- logical, execution or not im ! + ! when iter = 1, flag_iter = .true. for all grids im ! + ! when iter = 2, flag_iter = .true. when wind < 2 im ! + ! for both land and ocean (when nstf_name1 > 0) im ! + ! flag_guess-logical, .true.= guess step to get CD et al im ! + ! when iter = 1, flag_guess = .true. when wind < 2 im ! + ! when iter = 2, flag_guess = .false. for all grids im ! + ! nstf_name - integers , NSST related flag parameters 1 ! + ! nstf_name1 : 0 = NSSTM off 1 ! + ! 1 = NSSTM on but uncoupled 1 ! + ! 2 = NSSTM on and coupled 1 ! + ! nstf_name4 : zsea1 in mm 1 ! + ! nstf_name5 : zsea2 in mm 1 ! + ! lprnt - logical, control flag for check print out 1 ! + ! ipr - integer, grid index for check print out 1 ! + ! thsfc_loc- logical, flag for reference pressure in theta 1 ! + ! ! + ! input/outputs: + ! li added for oceanic components + ! tskin - real, ocean surface skin temperature ( k ) im ! + ! tsurf - real, the same as tskin ( k ) but for guess run im ! + ! xt - real, heat content in dtl im ! + ! xs - real, salinity content in dtl im ! + ! xu - real, u-current content in dtl im ! + ! xv - real, v-current content in dtl im ! + ! xz - real, dtl thickness im ! + ! zm - real, mxl thickness im ! + ! xtts - real, d(xt)/d(ts) im ! + ! xzts - real, d(xz)/d(ts) im ! + ! dt_cool - real, sub-layer cooling amount im ! + ! d_conv - real, thickness of free convection layer (fcl) im ! + ! z_c - sub-layer cooling thickness im ! + ! c_0 - coefficient1 to calculate d(tz)/d(ts) im ! + ! c_d - coefficient2 to calculate d(tz)/d(ts) im ! + ! w_0 - coefficient3 to calculate d(tz)/d(ts) im ! + ! w_d - coefficient4 to calculate d(tz)/d(ts) im ! + ! ifd - real, index to start dtlm run or not im ! + ! qrain - real, sensible heat flux due to rainfall (watts) im ! + + ! outputs: ! + + ! qsurf - real, surface air saturation specific humidity im ! + ! gflux - real, soil heat flux (w/m**2) im ! + ! cmm - real, im ! + ! chh - real, im ! + ! evap - real, evaperation from latent heat flux im ! + ! hflx - real, sensible heat flux im ! + ! ep - real, potential evaporation im ! + ! ! + ! ===================================================================== ! + + + + ! --- inputs: + integer, intent(in) :: im, kdt, ipr, nstf_name1, nstf_name4, nstf_name5 + real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, & + epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice + real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & + t1, q1, tref, cm, ch, fm, fm10, & + prsl1, prslki, prsik1, prslk1, xlon, xcosz, & + sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind + real (kind=kind_phys), intent(in) :: timestep + real (kind=kind_phys), intent(in) :: solhr + + ! For sea spray effect + logical, intent(in) :: lseaspray + ! + logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet + integer, dimension(:), intent(in) :: use_lake_model + logical, intent(in) :: lprnt + logical, intent(in) :: thsfc_loc + + ! --- input/outputs: + ! control variables of dtl system (5+2) and sl (2) and coefficients for d(tz)/d(ts) calculation + real (kind=kind_phys), dimension(:), intent(inout) :: tskin, & + tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & + z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain + + ! --- outputs: + real (kind=kind_phys), dimension(:), intent(inout) :: qsurf, gflux, cmm, chh, evap, hflx, ep + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! + ! locals + ! + integer :: k,i + ! + real (kind=kind_phys), dimension(im) :: q0, qss, rch, rho_a, theta1, tv1, wndmag + + real(kind=kind_phys) :: elocp,tem,cpinv,hvapi + ! + ! nstm related prognostic fields + ! + logical :: flag(im) + real (kind=kind_phys), dimension(im) :: xt_old, xs_old, xu_old, xv_old, xz_old, & + zm_old,xtts_old, xzts_old, ifd_old, tref_old, tskin_old, dt_cool_old,z_c_old + + real(kind=kind_phys) :: ulwflx(im), nswsfc(im) + ! real(kind=kind_phys) rig(im), + ! & ulwflx(im),dlwflx(im), + ! & slrad(im),nswsfc(im) + real(kind=kind_phys) :: alpha,beta,rho_w,f_nsol,sss,sep, cosa,sina,taux,tauy, & + grav,dz,t0,ttop0,ttop + + real(kind=kind_phys) :: le,fc,dwat,dtmp,wetc,alfac,ustar_a,rich + real(kind=kind_phys) :: rnl_ts,hs_ts,hl_ts,rf_ts,q_ts + real(kind=kind_phys) :: fw,q_warm + real(kind=kind_phys) :: t12,alon,tsea,sstc,dta,dtz + real(kind=kind_phys) :: zsea1,zsea2,soltim + logical :: do_nst + ! + ! parameters for sea spray effect + ! + real (kind=kind_phys) :: f10m, u10m, v10m, ws10, ru10, qss1, & + bb1, hflxs, evaps, ptem + ! + ! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.1, + ! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.0, + ! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2, + real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, & + ws10cr=30., conlf=7.2e-9, consf=6.4e-8 + ! + !====================================================================================================== + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (nstf_name1 == 0) return ! No NSST model used + + cpinv = one/cp + hvapi = one/hvap + elocp = hvap/cp + + sss = 34.0_kp ! temporarily, when sea surface salinity data is not ready + ! + ! flag for open water and where the iteration is on + ! + do_nst = .false. + do i = 1, im + ! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i) + flag(i) = wet(i) .and. flag_iter(i) .and. use_lake_model(i)/=1 + do_nst = do_nst .or. flag(i) + enddo + if (.not. do_nst) return + ! + ! save nst-related prognostic fields for guess run + ! + do i=1, im + ! if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then + if(wet(i) .and. flag_guess(i) .and. use_lake_model(i)/=1) then + xt_old(i) = xt(i) + xs_old(i) = xs(i) + xu_old(i) = xu(i) + xv_old(i) = xv(i) + xz_old(i) = xz(i) + zm_old(i) = zm(i) + xtts_old(i) = xtts(i) + xzts_old(i) = xzts(i) + ifd_old(i) = ifd(i) + tskin_old(i) = tskin(i) + dt_cool_old(i) = dt_cool(i) + z_c_old(i) = z_c(i) + endif + enddo + + + ! --- ... initialize variables. all units are m.k.s. unless specified. + ! ps is in pascals, wind is wind speed, theta1 is surface air + ! estimated from level 1 temperature, rho_a is air density and + ! qss is saturation specific humidity at the water surface + !! + do i = 1, im + if ( flag(i) ) then + + nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward) + wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) + + q0(i) = max(q1(i), 1.0e-8_kp) + + if(thsfc_loc) then ! Use local potential temperature + theta1(i) = t1(i) * prslki(i) + else ! Use potential temperature referenced to 1000 hPa + theta1(i) = t1(i) / prslk1(i) ! potential temperature at the middle of lowest model layer + endif + + tv1(i) = t1(i) * (one + rvrdm1*q0(i)) + rho_a(i) = prsl1(i) / (rd*tv1(i)) + qss(i) = fpvs(tsurf(i)) ! pa + qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) ! pa + ! + evap(i) = zero + hflx(i) = zero + gflux(i) = zero + ep(i) = zero + + ! --- ... rcp = rho cp ch v + + rch(i) = rho_a(i) * cp * ch(i) * wind(i) + cmm(i) = cm (i) * wind(i) + chh(i) = rho_a(i) * ch(i) * wind(i) + + !> - Calculate latent and sensible heat flux over open water with tskin. + ! at previous time step + evap(i) = elocp * rch(i) * (qss(i) - q0(i)) + qsurf(i) = qss(i) + + if(thsfc_loc) then ! Use local potential temperature + hflx(i) = rch(i) * (tsurf(i) - theta1(i)) + else ! Use potential temperature referenced to 1000 hPa + hflx(i) = rch(i) * (tsurf(i)/prsik1(i) - theta1(i)) + endif + + ! if (lprnt .and. i == ipr) print *,' tskin=',tskin(i),' theta1=', + ! & theta1(i),' hflx=',hflx(i),' t1=',t1(i),'prslki=',prslki(i) + ! &,' tsurf=',tsurf(i) + endif + enddo + + ! run nst model: dtm + slm + ! + zsea1 = 0.001_kp*real(nstf_name4) + zsea2 = 0.001_kp*real(nstf_name5) + + !> - Call module_nst_water_prop::density() to compute sea water density. + !> - Call module_nst_water_prop::rhocoef() to compute thermal expansion + !! coefficient (\a alpha) and saline contraction coefficient (\a beta). + do i = 1, im + if ( flag(i) ) then + tsea = tsurf(i) + t12 = tsea*tsea + ulwflx(i) = sfcemis(i) * sbc * t12 * t12 + alon = xlon(i)*rad2deg + grav = grv(sinlat(i)) + soltim = mod(alon/15.0_kp + solhr, 24.0_kp)*3600.0_kp + call density(tsea,sss,rho_w) ! sea water density + call rhocoef(tsea,sss,rho_w,alpha,beta) ! alpha & beta + ! + !> - Calculate sensible heat flux (\a qrain) due to rainfall. + ! + le = (2.501_kp-0.00237_kp*tsea)*1.0e6_kp + dwat = 2.11e-5_kp*(t1(i)/t0k)**1.94_kp ! water vapor diffusivity + dtmp = (one+3.309e-3_kp*(t1(i)-t0k)-1.44e-6_kp*(t1(i)-t0k) & + * (t1(i)-t0k))*0.02411_kp/(rho_a(i)*cp) ! heat diffusivity + wetc = 622.0_kp*le*qss(i)/(rd*t1(i)*t1(i)) + alfac = one / (one + (wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor + tem = (1.0e3_kp * rain(i) / rho_w) * alfac * cp_w + qrain(i) = tem * (tsea-t1(i)+1.0e3_kp*(qss(i)-q0(i))*le/cp) + + !> - Calculate input non solar heat flux as upward = positive to models here + + f_nsol = hflx(i) + evap(i) + ulwflx(i) - dlwflx(i) + omg_sh*qrain(i) + + ! if (lprnt .and. i == ipr) print *,' f_nsol=',f_nsol,' hflx=', + ! &hflx(i),' evap=',evap(i),' ulwflx=',ulwflx(i),' dlwflx=',dlwflx(i) + ! &,' omg_sh=',omg_sh,' qrain=',qrain(i) + + sep = sss*(evap(i)/le-rain(i))/rho_w + ustar_a = sqrt(stress(i)/rho_a(i)) ! air friction velocity + ! + ! sensitivities of heat flux components to ts + ! + rnl_ts = 4.0_kp*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts) + hs_ts = rch(i) + hl_ts = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12) + rf_ts = tem * (one+rch(i)*hl_ts) + q_ts = rnl_ts + hs_ts + hl_ts + omg_sh*rf_ts + ! + !> - Call cool_skin(), which is the sub-layer cooling parameterization + !! (Fairfall et al. (1996) \cite fairall_et_al_1996). + ! & calculate c_0, c_d + ! + call cool_skin(ustar_a,f_nsol,nswsfc(i),evap(i),sss,alpha,beta, & + rho_w,rho_a(i),tsea,q_ts,hl_ts,grav,le, & + dt_cool(i),z_c(i),c_0(i),c_d(i)) + + tem = one / wndmag(i) + cosa = u1(i)*tem + sina = v1(i)*tem + taux = max(stress(i),tau_min)*cosa + tauy = max(stress(i),tau_min)*sina + fc = const_rot*sinlat(i) + ! + ! Run DTM-1p system. + ! + if ( (soltim > solar_time_6am .and. ifd(i) == zero) ) then + else + ifd(i) = one + ! + ! calculate fcl thickness with current forcing and previous time's profile + ! + ! if (lprnt .and. i == ipr) print *,' beg xz=',xz(i) + + !> - Call convdepth() to calculate depth for convective adjustments. + if ( f_nsol > zero .and. xt(i) > zero ) then + call convdepth(kdt,timestep,nswsfc(i),f_nsol,sss,sep,rho_w, & + alpha,beta,xt(i),xs(i),xz(i),d_conv(i)) + else + d_conv(i) = zero + endif + + ! if (lprnt .and. i == ipr) print *,' beg xz1=',xz(i) + ! + ! determine rich: wind speed dependent (right now) + ! + ! if ( wind(i) < 1.0 ) then + ! rich = 0.25 + 0.03*wind(i) + ! elseif ( wind(i) >= 1.0 .and. wind(i) < 1.5 ) then + ! rich = 0.25 + 0.1*wind(i) + ! elseif ( wind(i) >= 1.5 .and. wind(i) < 6.0 ) then + ! rich = 0.25 + 0.6*wind(i) + ! elseif ( wind(i) >= 6.0 ) then + ! rich = 0.25 + min(0.8*wind(i),0.50) + ! endif + + rich = ri_c + + !> - Call the diurnal thermocline layer model dtm_1p(). + call dtm_1p(kdt,timestep,rich,taux,tauy,nswsfc(i), & + f_nsol,sss,sep,q_ts,hl_ts,rho_w,alpha,beta,alon, & + sinlat(i),soltim,grav,le,d_conv(i), & + xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + + ! if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i) + + ! apply mda + if ( xt(i) > zero ) then + !> - If \a dtl heat content \a xt > 0.0, call dtm_1p_mda() to apply + !! minimum depth adjustment (mda). + call dtm_1p_mda(xt(i),xtts(i),xz(i),xzts(i)) + if ( xz(i) >= z_w_max ) then + !> - If \a dtl thickness >= module_nst_parameters::z_w_max, call dtl_reset() + !! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max. + call dtl_reset(xt(i),xs(i),xu(i),xv(i),xz(i),xtts(i), xzts(i)) + + ! if (lprnt .and. i == ipr) print *,' beg xz3=',xz(i),' z_w_max=' + ! &,z_w_max + endif + + ! apply fca + if ( d_conv(i) > zero ) then + !> - If thickness of free convection layer > 0.0, call dtm_1p_fca() + !! to apply free convection adjustment. + !> - If \a dtl thickness >= module_nst_parameters::z_w_max(), call dtl_reset() + !! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max(). + call dtm_1p_fca(d_conv(i),xt(i),xtts(i),xz(i),xzts(i)) + if ( xz(i) >= z_w_max ) then + call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + + ! if (lprnt .and. i == ipr) print *,' beg xz4=',xz(i) + + ! apply tla + dz = min(xz(i),max(d_conv(i),delz)) + ! + !> - Call sw_ps_9b() to compute the fraction of the solar radiation + !! absorbed by the depth \a delz (Paulson and Simpson (1981) \cite paulson_and_simpson_1981). + !! And calculate the total heat absorbed in warm layer. + call sw_ps_9b(delz,fw) + q_warm = fw*nswsfc(i)-f_nsol !total heat absorbed in warm layer + + !> - Call cal_ttop() to calculate the diurnal warming amount at the top layer with + !! thickness of \a dz. + if ( q_warm > zero ) then + call cal_ttop(kdt,timestep,q_warm,rho_w,dz, xt(i),xz(i),ttop0) + + ! if (lprnt .and. i == ipr) print *,' d_conv=',d_conv(i),' delz=', + ! &delz,' kdt=',kdt,' timestep=',timestep,' nswsfc=',nswsfc(i), + ! &' f_nsol=',f_nsol,' rho_w=',rho_w,' dz=',dz,' xt=',xt(i), + ! &' xz=',xz(i),' qrain=',qrain(i) + + ttop = ((xt(i)+xt(i))/xz(i))*(one-dz/((xz(i)+xz(i)))) + + ! if (lprnt .and. i == ipr) print *,' beg xz4a=',xz(i) + ! &,' ttop=',ttop,' ttop0=',ttop0,' xt=',xt(i),' dz=',dz + ! &,' xznew=',(xt(i)+sqrt(xt(i)*(xt(i)-dz*ttop0)))/ttop0 + + !> - Call dtm_1p_tla() to apply top layer adjustment. + if ( ttop > ttop0 ) then + call dtm_1p_tla(dz,ttop0,xt(i),xtts(i),xz(i),xzts(i)) + + ! if (lprnt .and. i == ipr) print *,' beg xz4b=',xz(i),'z_w_max=', + ! &z_w_max + if ( xz(i) >= z_w_max ) then + call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + endif ! if ( q_warm > 0.0 ) then + + ! if (lprnt .and. i == ipr) print *,' beg xz5=',xz(i) + + ! apply mwa + !> - Call dt_1p_mwa() to apply maximum warming adjustment. + t0 = (xt(i)+xt(i))/xz(i) + if ( t0 > tw_max ) then + call dtm_1p_mwa(xt(i),xtts(i),xz(i),xzts(i)) + if ( xz(i) >= z_w_max ) then + call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + + ! if (lprnt .and. i == ipr) print *,' beg xz6=',xz(i) + + ! apply mta + !> - Call dtm_1p_mta() to apply maximum temperature adjustment. + sstc = tref(i) + (xt(i)+xt(i))/xz(i) - dt_cool(i) + + if ( sstc > sst_max ) then + dta = sstc - sst_max + call dtm_1p_mta(dta,xt(i),xtts(i),xz(i),xzts(i)) + ! write(*,'(a,f3.0,7f8.3)') 'mta, sstc,dta :',islimsk(i), + ! & sstc,dta,tref(i),xt(i),xz(i),2.0*xt(i)/xz(i),dt_cool(i) + if ( xz(i) >= z_w_max ) then + call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + ! + endif ! if ( xt(i) > 0.0 ) then + ! reset dtl at midnight and when solar zenith angle > 89.994 degree + if ( abs(soltim) < 2.0_kp*timestep ) then + call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + + endif ! if (solar_time > solar_time_6am .and. ifd(i) == 0.0 ) then: too late to start the first day + + ! if (lprnt .and. i == ipr) print *,' beg xz7=',xz(i) + + ! update tsurf (when flag(i) .eqv. .true. ) + !> - Call get_dtzm_point() to computes \a dtz and \a tsurf. + call get_dtzm_point(xt(i),xz(i),dt_cool(i),z_c(i), zsea1,zsea2,dtz) + tsurf(i) = max(tgice, tref(i) + dtz ) + + ! if (lprnt .and. i == ipr) print *,' tsurf=',tsurf(i),' tref=', + ! &tref(i),' xz=',xz(i),' dt_cool=',dt_cool(i) + + !> - Call cal_w() to calculate \a w_0 and \a w_d. + if ( xt(i) > zero ) then + call cal_w(kdt,xz(i),xt(i),xzts(i),xtts(i),w_0(i),w_d(i)) + else + w_0(i) = zero + w_d(i) = zero + endif + + ! if ( xt(i) > 0.0 ) then + ! rig(i) = grav*xz(i)*xz(i)*(alpha*xt(i)-beta*xs(i)) + ! & /(2.0*(xu(i)*xu(i)+xv(i)*xv(i))) + ! else + ! rig(i) = 0.25 + ! endif + + ! qrain(i) = rig(i) + zm(i) = wind(i) + + endif + enddo + + ! restore nst-related prognostic fields for guess run + do i=1, im + ! if (wet(i) .and. .not.icy(i)) then + if (wet(i) .and. use_lake_model(i)/=1) then + if (flag_guess(i)) then ! when it is guess of + xt(i) = xt_old(i) + xs(i) = xs_old(i) + xu(i) = xu_old(i) + xv(i) = xv_old(i) + xz(i) = xz_old(i) + zm(i) = zm_old(i) + xtts(i) = xtts_old(i) + xzts(i) = xzts_old(i) + ifd(i) = ifd_old(i) + tskin(i) = tskin_old(i) + dt_cool(i) = dt_cool_old(i) + z_c(i) = z_c_old(i) + else + ! + ! update tskin when coupled and not guess run + ! (all other NSST variables have been updated in this case) + ! + if ( nstf_name1 > 1 ) then + tskin(i) = tsurf(i) + endif ! if nstf_name1 > 1 then + endif ! if flag_guess(i) then + endif ! if wet(i) .and. .not.icy(i) then + enddo + + ! if (lprnt .and. i == ipr) print *,' beg xz8=',xz(i) + + if ( nstf_name1 > 1 ) then + !> - Calculate latent and sensible heat flux over open water with updated tskin + !! for the grids of open water and the iteration is on. + do i = 1, im + if ( flag(i) ) then + qss(i) = fpvs( tskin(i) ) + qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) + qsurf(i) = qss(i) + evap(i) = elocp*rch(i) * (qss(i) - q0(i)) + + if(thsfc_loc) then ! Use local potential temperature + hflx(i) = rch(i) * (tskin(i) - theta1(i)) + else ! Use potential temperature referenced to 1000 hPa + hflx(i) = rch(i) * (tskin(i)/prsik1(i) - theta1(i)) + endif + + endif + enddo + endif ! if ( nstf_name1 > 1 ) then + ! + !> - Include sea spray effects + ! + do i=1,im + if(lseaspray .and. flag(i)) then + f10m = fm10(i) / fm(i) + u10m = f10m * u1(i) + v10m = f10m * v1(i) + ws10 = sqrt(u10m*u10m + v10m*v10m) + ws10 = max(ws10,1.) + ws10 = min(ws10,ws10cr) + tem = .015 * ws10 * ws10 + ru10 = 1. - .087 * log(10./tem) + qss1 = fpvs(t1(i)) + qss1 = eps * qss1 / (prsl1(i) + epsm1 * qss1) + tem = rd * cp * t1(i) * t1(i) + tem = 1. + eps * hvap * hvap * qss1 / tem + bb1 = 1. / tem + evaps = conlf * (ws10**5.4) * ru10 * bb1 + evaps = evaps * rho_a(i) * hvap * (qss1 - q0(i)) + evap(i) = evap(i) + alps * evaps + hflxs = consf * (ws10**3.4) * ru10 + hflxs = hflxs * rho_a(i) * cp * (tskin(i) - t1(i)) + ptem = alps - gams + hflx(i) = hflx(i) + bets * hflxs - ptem * evaps + endif + enddo + ! + do i=1,im + if ( flag(i) ) then + tem = one / rho_a(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif + enddo + ! + ! if (lprnt) print *,' tskin=',tskin(ipr) + + return + end subroutine sfc_nst_run + !> @} +end module sfc_nst diff --git a/physics/sfc_nst.meta b/physics/SFC_Layer/UFS/sfc_nst.meta similarity index 99% rename from physics/sfc_nst.meta rename to physics/SFC_Layer/UFS/sfc_nst.meta index dc35ec959..131daaab0 100644 --- a/physics/sfc_nst.meta +++ b/physics/SFC_Layer/UFS/sfc_nst.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = sfc_nst type = scheme - dependencies = date_def.f,funcphys.f90,machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 + dependencies = date_def.f,../../tools/funcphys.f90,../../hooks/machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/SFC_Layer/UFS/sfc_nst_post.f90 b/physics/SFC_Layer/UFS/sfc_nst_post.f90 new file mode 100644 index 000000000..174d5df76 --- /dev/null +++ b/physics/SFC_Layer/UFS/sfc_nst_post.f90 @@ -0,0 +1,87 @@ +!> \file sfc_nst_post.f90 +!! This file contains code to be executed after the GFS NSST model. + +module sfc_nst_post + + use machine , only : kind_phys, kp => kind_phys + use module_nst_water_prop , only : get_dtzm_2d + + implicit none + +contains + + ! \defgroup GFS_NSST_POST GFS Near-Surface Sea Temperature Post + + !> \section arg_table_sfc_nst_post_run Argument Table + !! \htmlinclude sfc_nst_post_run.html + !! + ! \section NSST_general_post_algorithm General Algorithm + ! + ! \section NSST_detailed_post_algorithm Detailed Algorithm + ! @{ + subroutine sfc_nst_post_run & + ( im, kdt, rlapse, tgice, wet, use_lake_model, icy, oro, & + oro_uf, nstf_name1, & + nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, & + tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg & + ) + ! --- inputs: + integer, intent(in) :: im, kdt, nthreads + logical, dimension(:), intent(in) :: wet, icy + integer, dimension(:), intent(in) :: use_lake_model + real (kind=kind_phys), intent(in) :: rlapse, tgice + real (kind=kind_phys), dimension(:), intent(in) :: oro, oro_uf + integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5 + real (kind=kind_phys), dimension(:), intent(in) :: xt, xz, dt_cool, z_c, tref, xlon + + ! --- input/outputs: + real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, tsfc_wat + + ! --- outputs: + real (kind=kind_phys), dimension(:), intent(out) :: dtzm + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! --- locals + integer :: i + real(kind=kind_phys) :: zsea1, zsea2 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), + ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), + ! & ' kdt=',kdt + + ! do i = 1, im + ! if (wet(i) .and. .not. icy(i)) then + ! tsurf_wat(i) = tsurf_wat(i) - (oro(i)-oro_uf(i)) * rlapse + ! endif + ! enddo + + ! --- ... run nsst model ... --- + + if (nstf_name1 > 1) then + zsea1 = 0.001_kp*real(nstf_name4) + zsea2 = 0.001_kp*real(nstf_name5) + call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, im, 1, nthreads, dtzm) + do i = 1, im + ! if (wet(i) .and. .not.icy(i)) then + ! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then + if (wet(i) .and. use_lake_model(i) /=1) then + tsfc_wat(i) = max(tgice, tref(i) + dtzm(i)) + ! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - & + ! (oro(i)-oro_uf(i))*rlapse + endif + enddo + endif + + ! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & + ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt + + return + end subroutine sfc_nst_post_run + +end module sfc_nst_post diff --git a/physics/sfc_nst_post.meta b/physics/SFC_Layer/UFS/sfc_nst_post.meta similarity index 98% rename from physics/sfc_nst_post.meta rename to physics/SFC_Layer/UFS/sfc_nst_post.meta index 7f66118e9..caa487384 100644 --- a/physics/sfc_nst_post.meta +++ b/physics/SFC_Layer/UFS/sfc_nst_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = sfc_nst_post type = scheme - dependencies = machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 + dependencies = ../../hooks/machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/SFC_Layer/UFS/sfc_nst_pre.f90 b/physics/SFC_Layer/UFS/sfc_nst_pre.f90 new file mode 100644 index 000000000..3e77f2d6b --- /dev/null +++ b/physics/SFC_Layer/UFS/sfc_nst_pre.f90 @@ -0,0 +1,89 @@ +!> \file sfc_nst_pre.f90 +!! This file contains preparation for the GFS NSST model. + +module sfc_nst_pre + + use machine , only : kind_phys + use module_nst_water_prop , only : get_dtzm_2d + use module_nst_parameters , only : zero, one + + implicit none + +contains + + !> \defgroup GFS_NSST_PRE GFS Near-Surface Sea Temperature Pre + !! + !! The NSST scheme is one of the three schemes used to represent the + !! surface in the GFS physics suite. The other two are the Noah land + !! surface model and the sice simplified ice model. + !! + !! \section arg_table_sfc_nst_pre_run Argument Table + !! \htmlinclude sfc_nst_pre_run.html + !! + !> \section NSST_general_pre_algorithm General Algorithm + subroutine sfc_nst_pre_run & + (im, wet, tgice, tsfco, tsurf_wat, & + tseal, xt, xz, dt_cool, z_c, tref, cplflx, & + oceanfrac, nthreads, errmsg, errflg) + + ! --- inputs: + integer, intent(in) :: im, nthreads + logical, dimension(:), intent(in) :: wet + real (kind=kind_phys), intent(in) :: tgice + real (kind=kind_phys), dimension(:), intent(in) :: tsfco, xt, xz, dt_cool, z_c, oceanfrac + logical, intent(in) :: cplflx + + ! --- input/outputs: + real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, tseal, tref + + ! --- outputs: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! --- locals + integer :: i + real(kind=kind_phys), parameter :: omz1 = 2.0_kind_phys + real(kind=kind_phys) :: tem2, dnsst + real(kind=kind_phys), dimension(im) :: dtzm, z_c_0 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1,im + if (wet(i) .and. oceanfrac(i) > 0.0) then + ! tem = (oro(i)-oro_uf(i)) * rlapse + ! DH* 20190927 simplyfing this code because tem is zero + !tem = zero + !tseal(i) = tsfco(i) + tem + tseal(i) = tsfco(i) + !tsurf_wat(i) = tsurf_wat(i) + tem + ! *DH + endif + enddo + ! + ! update tsfc & tref with T1 from OGCM & NSST Profile if coupled + ! + if (cplflx) then + z_c_0 = zero + call get_dtzm_2d (xt, xz, dt_cool, z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm) + do i=1,im + if (wet(i) .and. oceanfrac(i) > zero ) then + ! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf + tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile + ! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update + ! tseal(i) = tsfc_wat(i) + if (abs(xz(i)) > zero) then + tem2 = one / xz(i) + else + tem2 = zero + endif + tseal(i) = tref(i) + (xt(i)+xt(i)) * tem2 - dt_cool(i) + tsurf_wat(i) = tseal(i) + endif + enddo + endif + + return + end subroutine sfc_nst_pre_run +end module sfc_nst_pre diff --git a/physics/sfc_nst_pre.meta b/physics/SFC_Layer/UFS/sfc_nst_pre.meta similarity index 97% rename from physics/sfc_nst_pre.meta rename to physics/SFC_Layer/UFS/sfc_nst_pre.meta index 88788ff5c..e9cdef0d1 100644 --- a/physics/sfc_nst_pre.meta +++ b/physics/SFC_Layer/UFS/sfc_nst_pre.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = sfc_nst_pre type = scheme - dependencies = machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 + dependencies = ../../hooks/machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/clm_lake.f90 b/physics/SFC_Models/Lake/CLM/clm_lake.f90 similarity index 97% rename from physics/clm_lake.f90 rename to physics/SFC_Models/Lake/CLM/clm_lake.f90 index 4fa6dacb6..91e8c71b7 100644 --- a/physics/clm_lake.f90 +++ b/physics/SFC_Models/Lake/CLM/clm_lake.f90 @@ -229,6 +229,34 @@ end subroutine is_salty !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine calculate_z_dz_lake(i,input_lakedepth,clm_lakedepth,z_lake,dz_lake) + implicit none + integer, intent(in) :: i + real(kind_phys), intent(inout) :: clm_lakedepth(:) ! lake depth used by clm + real(kind_phys), intent(in) :: input_lakedepth(:) ! lake depth before correction (m) + real(kind_lake) :: z_lake(nlevlake) ! layer depth for lake (m) + real(kind_lake) :: dz_lake(nlevlake) ! layer thickness for lake (m) + real(kind_lake) :: depthratio + + if (input_lakedepth(i) == spval .or. input_lakedepth(i) < 0.1) then + ! This is a safeguard against: + ! 1. missing in the lakedepth database (== spval) + ! 2. errors in model cycling or unexpected changes in the orography database (< 0.1) + clm_lakedepth(i) = zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake) + z_lake(1:nlevlake) = zlak(1:nlevlake) + dz_lake(1:nlevlake) = dzlak(1:nlevlake) + else + depthratio = input_lakedepth(i) / (zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake)) + z_lake(1) = zlak(1) + dz_lake(1) = dzlak(1) + dz_lake(2:nlevlake) = dzlak(2:nlevlake)*depthratio + z_lake(2:nlevlake) = zlak(2:nlevlake)*depthratio + dz_lake(1)*(1._kind_lake - depthratio) + end if + + end subroutine calculate_z_dz_lake + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !> \section arg_table_clm_lake_run Argument Table !! \htmlinclude clm_lake_run.html !! @@ -242,8 +270,8 @@ SUBROUTINE clm_lake_run( & ! Atmospheric model state inputs: tg3, pgr, zlvl, gt0, prsi, phii, qvcurr, gu0, gv0, xlat_d, xlon_d, & - ch, cm, dlwsfci, dswsfci, oro_lakedepth, wind, rho0, tsfc, & - flag_iter, ISLTYP, rainncprv, raincprv, & + ch, cm, dlwsfci, dswsfci, oro_lakedepth, wind, tsfc, & + flag_iter, flag_lakefreeze, ISLTYP, rainncprv, raincprv, & ! Feedback to atmosphere: evap_wat, evap_ice, hflx_wat, hflx_ice, gflx_wat, gflx_ice, & @@ -258,8 +286,8 @@ SUBROUTINE clm_lake_run( & salty, savedtke12d, snowdp2d, h2osno2d, snl2d, t_grnd2d, t_lake3d, & lake_icefrac3d, t_soisno3d, h2osoi_ice3d, h2osoi_liq3d, h2osoi_vol3d, & - z3d, dz3d, zi3d, z_lake3d, dz_lake3d, watsat3d, csol3d, sand3d, clay3d, & - tkmg3d, tkdry3d, tksatu3d, clm_lakedepth, cannot_freeze, & + z3d, dz3d, zi3d, t1, qv1, prsl1, & + input_lakedepth, clm_lakedepth, cannot_freeze, & ! Error reporting: errflg, errmsg) @@ -296,10 +324,12 @@ SUBROUTINE clm_lake_run( & ! REAL(KIND_PHYS), DIMENSION(:), INTENT(IN):: & tg3, pgr, zlvl, qvcurr, xlat_d, xlon_d, ch, cm, & - dlwsfci, dswsfci, oro_lakedepth, wind, rho0, & - rainncprv, raincprv + dlwsfci, dswsfci, oro_lakedepth, wind, & + rainncprv, raincprv, t1, qv1, prsl1 REAL(KIND_PHYS), DIMENSION(:,:), INTENT(in) :: gu0, gv0, prsi, gt0, phii LOGICAL, DIMENSION(:), INTENT(IN) :: flag_iter + LOGICAL, DIMENSION(:), INTENT(INOUT) :: flag_lakefreeze + INTEGER, DIMENSION(:), INTENT(IN) :: ISLTYP ! @@ -336,14 +366,8 @@ SUBROUTINE clm_lake_run( & dz3d real(kind_phys), dimension( :,-nlevsnow+0: ) ,INTENT(inout) :: zi3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: z_lake3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: dz_lake3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: watsat3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: csol3d, sand3d, clay3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkmg3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkdry3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tksatu3d REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: clm_lakedepth + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: input_lakedepth ! ! Error reporting: @@ -430,10 +454,11 @@ SUBROUTINE clm_lake_run( & character*255 :: message logical, parameter :: feedback_to_atmosphere = .true. ! FIXME: REMOVE - real(kind_lake) :: to_radians, lat_d, lon_d, qss + real(kind_lake) :: to_radians, lat_d, lon_d, qss, tkm, bd + real(kind_lake) :: rho0 ! lowest model level air density - integer :: month,num1,num2,day_of_month - real(kind_lake) :: wght1,wght2,Tclim + integer :: month,num1,num2,day_of_month,isl + real(kind_lake) :: wght1,wght2,Tclim,depthratio logical salty_flag, cannot_freeze_flag @@ -451,31 +476,19 @@ SUBROUTINE clm_lake_run( & lakedepth_default=lakedepth_default, fhour=fhour, & oro_lakedepth=oro_lakedepth, savedtke12d=savedtke12d, snowdp2d=snowdp2d, & h2osno2d=h2osno2d, snl2d=snl2d, t_grnd2d=t_grnd2d, t_lake3d=t_lake3d, & - lake_icefrac3d=lake_icefrac3d, z_lake3d=z_lake3d, dz_lake3d=dz_lake3d, & + lake_icefrac3d=lake_icefrac3d, & t_soisno3d=t_soisno3d, h2osoi_ice3d=h2osoi_ice3d, h2osoi_liq3d=h2osoi_liq3d, & - h2osoi_vol3d=h2osoi_vol3d, z3d=z3d, dz3d=dz3d, zi3d=zi3d, watsat3d=watsat3d, & - csol3d=csol3d, tkmg3d=tkmg3d, fice=fice, hice=hice, min_lakeice=min_lakeice, & + h2osoi_vol3d=h2osoi_vol3d, z3d=z3d, dz3d=dz3d, zi3d=zi3d, & + fice=fice, hice=hice, min_lakeice=min_lakeice, & tsfc=tsfc, & - use_lake_model=use_lake_model, use_lakedepth=use_lakedepth, tkdry3d=tkdry3d, & - tksatu3d=tksatu3d, im=im, prsi=prsi, xlat_d=xlat_d, xlon_d=xlon_d, & - clm_lake_initialized=clm_lake_initialized, sand3d=sand3d, clay3d=clay3d, & + use_lake_model=use_lake_model, use_lakedepth=use_lakedepth, & + im=im, prsi=prsi, xlat_d=xlat_d, xlon_d=xlon_d, & + clm_lake_initialized=clm_lake_initialized, input_lakedepth=input_lakedepth, & tg3=tg3, clm_lakedepth=clm_lakedepth, km=km, me=me, master=master, & errmsg=errmsg, errflg=errflg) if(errflg/=0) then return endif - if(any(clay3d>0 .and. clay3d<1)) then - write(message,*) 'Invalid clay3d. Abort.' - errmsg=trim(message) - errflg=1 - return - endif - if(any(dz_lake3d>0 .and. dz_lake3d<.1)) then - write(message,*) 'Invalid dz_lake3d. Abort.' - errmsg=trim(message) - errflg=1 - return - endif lake_points=0 snow_points=0 @@ -540,6 +553,26 @@ SUBROUTINE clm_lake_run( & lake_points = lake_points+1 + call calculate_z_dz_lake(i,input_lakedepth,clm_lakedepth,z_lake(1,:),dz_lake(1,:)) + + do c = 2,column + z_lake(c,:) = z_lake(1,:) + dz_lake(c,:) = dz_lake(1,:) + enddo + + ! Soil hydraulic and thermal properties + isl = ISLTYP(i) + if (isl == 0 ) isl = 14 + if (isl == 14 ) isl = isl + 1 + + watsat = 0.489_kind_lake - 0.00126_kind_lake*sand(isl) + csol = (2.128_kind_lake*sand(isl)+2.385_kind_lake*clay(isl)) / (sand(isl)+clay(isl))*1.e6_kind_lake ! J/(m3 K) + tkm = (8.80_kind_lake*sand(isl)+2.92_kind_lake*clay(isl))/(sand(isl)+clay(isl)) ! W/(m K) + bd = (1._kind_lake-watsat(1,1))*2.7e3_kind_lake + tkmg = tkm ** (1._kind_lake- watsat(1,1)) + tkdry = (0.135_kind_lake*bd + 64.7_kind_lake) / (2.7e3_kind_lake - 0.947_kind_lake*bd) + tksatu = tkmg(1,1)*0.57_kind_lake**watsat(1,1) + do c = 1,column forc_t(c) = SFCTMP ! [K] @@ -567,8 +600,6 @@ SUBROUTINE clm_lake_run( & do k = 1,nlevlake t_lake(c,k) = t_lake3d(i,k) lake_icefrac(c,k) = lake_icefrac3d(i,k) - z_lake(c,k) = z_lake3d(i,k) - dz_lake(c,k) = dz_lake3d(i,k) enddo do k = -nlevsnow+1,nlevsoil t_soisno(c,k) = t_soisno3d(i,k) @@ -581,14 +612,6 @@ SUBROUTINE clm_lake_run( & do k = -nlevsnow+0,nlevsoil zi(c,k) = zi3d(i,k) enddo - do k = 1,nlevsoil - watsat(c,k) = watsat3d(i,k) - csol(c,k) = csol3d(i,k) - tkmg(c,k) = tkmg3d(i,k) - tkdry(c,k) = tkdry3d(i,k) - tksatu(c,k) = tksatu3d(i,k) - enddo - enddo eflx_lwrad_net = -9999 @@ -676,12 +699,13 @@ SUBROUTINE clm_lake_run( & !-- The CLM output is combined for fractional ice and water if( t_grnd(c) >= tfrz ) then - qfx = eflx_lh_tot(c)*invhvap + qfx = eflx_lh_tot(c)*invhvap else - qfx = eflx_lh_tot(c)*invhsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2)) + qfx = eflx_lh_tot(c)*invhsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2)) endif - evap_wat(i) = qfx/rho0(i) ! kinematic_surface_upward_latent_heat_flux_over_water - hflx_wat(i)=eflx_sh_tot(c)/(rho0(i)*cpair) ! kinematic_surface_upward_sensible_heat_flux_over_water + rho0 = prsl1(i) / (rair*t1(i)*(1.0 + con_fvirt*qv1(i))) + evap_wat(i) = qfx/rho0 ! kinematic_surface_upward_latent_heat_flux_over_water + hflx_wat(i) = eflx_sh_tot(c)/(rho0*cpair) ! kinematic_surface_upward_sensible_heat_flux_over_water gflx_wat(I) = eflx_gnet(c) ![W/m/m] upward_heat_flux_in_soil_over_water ep1d_water(i) = eflx_lh_tot(c) ![W/m/m] surface_upward_potential_latent_heat_flux_over_water tsurf_water(I) = t_grnd(c) ![K] surface skin temperature after iteration over water @@ -737,6 +761,11 @@ SUBROUTINE clm_lake_run( & weasd(i) = weasdi(i) snowd(i) = snodi(c) ! surface_snow_thickness_water_equivalent_over_ice + + if (.not. icy(i)) then + flag_lakefreeze(i)=.true. + end if + ! Ice points are icy: icy(i)=.true. ! flag_nonzero_sea_ice_surface_fraction ice_points = ice_points+1 @@ -747,7 +776,7 @@ SUBROUTINE clm_lake_run( & hice(I) = 0 ! sea_ice_thickness do k=1,nlevlake if(lake_icefrac3d(i,k)>0) then - hice(i) = hice(i) + dz_lake3d(i,k) + hice(i) = hice(i) + dz_lake(c,k) endif end do else ! Not an ice point @@ -5315,14 +5344,14 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, weasd, lakedepth_default, fhour, & oro_lakedepth, savedtke12d, snowdp2d, h2osno2d, & !o snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & - z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & + t_soisno3d, h2osoi_ice3d, & h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & - zi3d, watsat3d, csol3d, tkmg3d, & + zi3d, & fice, hice, min_lakeice, tsfc, & use_lake_model, use_lakedepth, & - tkdry3d, tksatu3d, im, prsi, & + im, prsi, & xlat_d, xlon_d, clm_lake_initialized, & - sand3d, clay3d, tg3, clm_lakedepth, & + input_lakedepth, tg3, clm_lakedepth, & km, me, master, errmsg, errflg) !> Some fields in lakeini are not available during initialization, @@ -5360,6 +5389,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, real(kind_phys), intent(in) :: lakedepth_default real(kind_phys), dimension(IM),intent(inout) :: clm_lakedepth + real(kind_phys), dimension(IM),intent(inout) :: input_lakedepth real(kind_phys), dimension(IM),intent(in) :: oro_lakedepth real(kind_phys), dimension(IM),intent(out) :: savedtke12d real(kind_phys), dimension(IM),intent(out) :: snowdp2d, & @@ -5368,43 +5398,24 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, t_grnd2d real(kind_phys), dimension(IM,nlevlake),INTENT(out) :: t_lake3d, & - lake_icefrac3d, & - z_lake3d, & - dz_lake3d + lake_icefrac3d real(kind_phys), dimension(IM,-nlevsnow+1:nlevsoil ),INTENT(out) :: t_soisno3d, & h2osoi_ice3d, & h2osoi_liq3d, & h2osoi_vol3d, & z3d, & dz3d - real(kind_phys), dimension(IM,nlevsoil),INTENT(out) :: watsat3d, & - csol3d, & - tkmg3d, & - tkdry3d, & - tksatu3d - real(kind_phys), dimension(IM,nlevsoil),INTENT(inout) :: clay3d, & - sand3d real(kind_phys), dimension( IM,-nlevsnow+0:nlevsoil ),INTENT(out) :: zi3d !LOGICAL, DIMENSION( : ),intent(out) :: lake !REAL(KIND_PHYS), OPTIONAL, DIMENSION( : ), INTENT(IN) :: lake_depth ! no separate variable for this in CCPP - real(kind_lake), dimension( 1:im,1:nlevsoil ) :: bsw3d, & - bsw23d, & - psisat3d, & - vwcsat3d, & - watdry3d, & - watopt3d, & - hksat3d, & - sucsat3d integer :: n,i,j,k,ib,lev,bottom ! indices real(kind_lake),dimension(1:im ) :: bd2d ! bulk density of dry soil material [kg/m^3] real(kind_lake),dimension(1:im ) :: tkm2d ! mineral conductivity real(kind_lake),dimension(1:im ) :: xksat2d ! maximum hydraulic conductivity of soil [mm/s] real(kind_lake),dimension(1:im ) :: depthratio2d ! ratio of lake depth to standard deep lake depth - real(kind_lake),dimension(1:im ) :: clay2d ! temporary - real(kind_lake),dimension(1:im ) :: sand2d ! temporary logical,parameter :: arbinit = .false. real(kind_lake),parameter :: defval = -999.0 @@ -5413,16 +5424,19 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, character*256 :: message real(kind_lake) :: ht real(kind_lake) :: rhosn - real(kind_lake) :: depth + real(kind_lake) :: depth, lakedepth logical :: climatology_limits + real(kind_lake) :: z_lake(nlevlake) ! layer depth for lake (m) + real(kind_lake) :: dz_lake(nlevlake) ! layer thickness for lake (m) + integer, parameter :: xcheck=38 integer, parameter :: ycheck=92 integer :: used_lakedepth_default, init_points, month, julday integer :: mon, iday, num2, num1, juld, day2, day1, wght1, wght2 - real(kind_lake) :: Tclim + real(kind_lake) :: Tclim, watsat used_lakedepth_default=0 @@ -5456,6 +5470,8 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, cycle endif + input_lakedepth=clm_lakedepth + snl2d(i) = defval do k = -nlevsnow+1,nlevsoil h2osoi_liq3d(i,k) = defval @@ -5468,8 +5484,6 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, do k = 1,nlevlake t_lake3d(i,k) = defval lake_icefrac3d(i,k) = defval - z_lake3d(i,k) = defval - dz_lake3d(i,k) = defval enddo if (use_lake_model(i) == 1) then @@ -5499,60 +5513,9 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, isl = ISLTYP(i) if (isl == 0 ) isl = 14 if (isl == 14 ) isl = isl + 1 - do k = 1,nlevsoil - sand3d(i,k) = sand(isl) - clay3d(i,k) = clay(isl) - - ! Cannot continue if either of these checks fail. - if(clay3d(i,k)>0 .and. clay3d(i,k)<1) then - write(message,*) 'bad clay3d ',clay3d(i,k) - write(0,'(A)') trim(message) - errmsg = trim(message) - errflg = 1 - return - endif - if(sand3d(i,k)>0 .and. sand3d(i,k)<1) then - write(message,*) 'bad sand3d ',sand3d(i,k) - write(0,'(A)') trim(message) - errmsg = trim(message) - errflg = 1 - return - endif - enddo - do k = 1,nlevsoil - clay2d(i) = clay3d(i,k) - sand2d(i) = sand3d(i,k) - watsat3d(i,k) = 0.489_kind_lake - 0.00126_kind_lake*sand2d(i) - bd2d(i) = (1._kind_lake-watsat3d(i,k))*2.7e3_kind_lake - xksat2d(i) = 0.0070556_kind_lake *( 10._kind_lake**(-0.884_kind_lake+0.0153_kind_lake*sand2d(i)) ) ! mm/s - tkm2d(i) = (8.80_kind_lake*sand2d(i)+2.92_kind_lake*clay2d(i))/(sand2d(i)+clay2d(i)) ! W/(m K) - - bsw3d(i,k) = 2.91_kind_lake + 0.159_kind_lake*clay2d(i) - bsw23d(i,k) = -(3.10_kind_lake + 0.157_kind_lake*clay2d(i) - 0.003_kind_lake*sand2d(i)) - psisat3d(i,k) = -(exp((1.54_kind_lake - 0.0095_kind_lake*sand2d(i) + 0.0063_kind_lake*(100.0_kind_lake-sand2d(i) & - -clay2d(i)))*log(10.0_kind_lake))*9.8e-5_kind_lake) - vwcsat3d(i,k) = (50.5_kind_lake - 0.142_kind_lake*sand2d(i) - 0.037_kind_lake*clay2d(i))/100.0_kind_lake - hksat3d(i,k) = xksat2d(i) - sucsat3d(i,k) = 10._kind_lake * ( 10._kind_lake**(1.88_kind_lake-0.0131_kind_lake*sand2d(i)) ) - tkmg3d(i,k) = tkm2d(i) ** (1._kind_lake- watsat3d(i,k)) - tksatu3d(i,k) = tkmg3d(i,k)*0.57_kind_lake**watsat3d(i,k) - tkdry3d(i,k) = (0.135_kind_lake*bd2d(i) + 64.7_kind_lake) / (2.7e3_kind_lake - 0.947_kind_lake*bd2d(i)) - csol3d(i,k) = (2.128_kind_lake*sand2d(i)+2.385_kind_lake*clay2d(i)) / (sand2d(i)+clay2d(i))*1.e6_kind_lake ! J/(m3 K) - watdry3d(i,k) = watsat3d(i,k) * (316230._kind_lake/sucsat3d(i,k)) ** (-1._kind_lake/bsw3d(i,k)) - watopt3d(i,k) = watsat3d(i,k) * (158490._kind_lake/sucsat3d(i,k)) ** (-1._kind_lake/bsw3d(i,k)) - end do - if (clm_lakedepth(i) == spval) then - clm_lakedepth(i) = zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake) - z_lake3d(i,1:nlevlake) = zlak(1:nlevlake) - dz_lake3d(i,1:nlevlake) = dzlak(1:nlevlake) - else - depthratio2d(i) = clm_lakedepth(i) / (zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake)) - z_lake3d(i,1) = zlak(1) - dz_lake3d(i,1) = dzlak(1) - dz_lake3d(i,2:nlevlake) = dzlak(2:nlevlake)*depthratio2d(i) - z_lake3d(i,2:nlevlake) = zlak(2:nlevlake)*depthratio2d(i) + dz_lake3d(i,1)*(1._kind_lake - depthratio2d(i)) - end if + call calculate_z_dz_lake(i,input_lakedepth,clm_lakedepth,z_lake,dz_lake) + z3d(i,1:nlevsoil) = zsoi(1:nlevsoil) zi3d(i,0:nlevsoil) = zisoi(0:nlevsoil) dz3d(i,1:nlevsoil) = dzsoi(1:nlevsoil) @@ -5633,9 +5596,9 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, if(lake_icefrac3d(i,1) > 0.) then depth = 0. do k=2,nlevlake - depth = depth + dz_lake3d(i,k) + depth = depth + dz_lake(k) if(hice(i) >= depth) then - lake_icefrac3d(i,k) = max(0.,lake_icefrac3d(i,1)+(0.-lake_icefrac3d(i,1))/z_lake3d(i,nlevlake)*depth) + lake_icefrac3d(i,k) = max(0.,lake_icefrac3d(i,1)+(0.-lake_icefrac3d(i,1))/z_lake(nlevlake)*depth) else lake_icefrac3d(i,k) = 0. endif @@ -5649,8 +5612,8 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, t_grnd2d(i) = max(tfrz,tsfc(i)) endif do k = 2, nlevlake - if(z_lake3d(i,k).le.depth_c) then - t_lake3d(i,k) = tsfc(i)+(277.2_kind_lake-tsfc(i))/depth_c*z_lake3d(i,k) + if(z_lake(k).le.depth_c) then + t_lake3d(i,k) = tsfc(i)+(277.2_kind_lake-tsfc(i))/depth_c*z_lake(k) else t_lake3d(i,k) = 277.2_kind_lake end if @@ -5684,7 +5647,8 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, do k = 1,nlevsoil h2osoi_vol3d(i,k) = 1.0_kind_lake - h2osoi_vol3d(i,k) = min(h2osoi_vol3d(i,k),watsat3d(i,k)) + watsat = 0.489_kind_lake - 0.00126_kind_lake*sand(isl) + h2osoi_vol3d(i,k) = min(h2osoi_vol3d(i,k),watsat) ! soil layers if (t_soisno3d(i,k) <= tfrz) then diff --git a/physics/clm_lake.meta b/physics/SFC_Models/Lake/CLM/clm_lake.meta similarity index 91% rename from physics/clm_lake.meta rename to physics/SFC_Models/Lake/CLM/clm_lake.meta index 3de543078..99c7970d3 100644 --- a/physics/clm_lake.meta +++ b/physics/SFC_Models/Lake/CLM/clm_lake.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = clm_lake type = scheme - dependencies = machine.F + dependencies = ../../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -289,6 +289,14 @@ type = real kind = kind_phys intent = in +[input_lakedepth] + standard_name = lake_depth_before_correction + long_name = lake depth_before_correction + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level @@ -297,14 +305,6 @@ type = real kind = kind_phys intent = in -[rho0] - standard_name = air_pressure_at_surface_adjacent_layer - long_name = mean pressure at lowest model layer - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [tsfc] standard_name = surface_skin_temperature long_name = surface skin temperature @@ -320,6 +320,13 @@ dimensions = (horizontal_loop_extent) type = logical intent = in +[flag_lakefreeze] + standard_name = flag_for_lake_water_freeze + long_name = flag for lake water freeze + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout [isltyp] standard_name = soil_type_classification long_name = soil type at each grid cell @@ -716,80 +723,34 @@ type = real kind = kind_phys intent = inout -[z_lake3d] - standard_name = depth_of_lake_interface_layers - long_name = depth of lake interface layers - units = fraction - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[dz_lake3d] - standard_name = thickness_of_lake_layers - long_name = thickness of lake layers - units = fraction - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[watsat3d] - standard_name = saturated_volumetric_soil_water_in_lake_model - long_name = saturated volumetric soil water in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[csol3d] - standard_name = soil_heat_capacity_in_lake_model - long_name = soil heat capacity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[sand3d] - standard_name = clm_lake_percent_sand - long_name = percent sand in clm lake model - units = percent - dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_clm_lake_model) - type = integer - intent = inout -[clay3d] - standard_name = clm_lake_percent_clay - long_name = percent clay in clm lake model - units = percent - dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_clm_lake_model) - type = integer - intent = inout -[tkmg3d] - standard_name = soil_mineral_thermal_conductivity_in_lake_model - long_name = soil mineral thermal conductivity in lake model +[clm_lakedepth] + standard_name = clm_lake_depth + long_name = clm internal copy of lake depth with 10.0 replaced by default lake depth units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = inout -[tkdry3d] - standard_name = dry_soil_thermal_conductivity_in_lake_model - long_name = dry soil thermal conductivity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + intent = in +[t1] + standard_name = air_temperature_at_surface_adjacent_layer + long_name = mean temperature at lowest model layer + units = K + dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = inout -[tksatu3d] - standard_name = saturated_soil_thermal_conductivity_in_lake_model - long_name = saturated soil thermal conductivity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + intent = in +[qv1] + standard_name = specific_humidity_at_surface_adjacent_layer + long_name = water vapor specific humidity at lowest model layer + units = kg kg-1 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = inout -[clm_lakedepth] - standard_name = clm_lake_depth - long_name = clm internal copy of lake depth with 10.0 replaced by default lake depth - units = m + intent = in +[prsl1] + standard_name = air_pressure_at_surface_adjacent_layer + long_name = mean pressure at lowest model layer + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys diff --git a/physics/flake.F90 b/physics/SFC_Models/Lake/Flake/flake.F90 similarity index 100% rename from physics/flake.F90 rename to physics/SFC_Models/Lake/Flake/flake.F90 diff --git a/physics/flake_driver.F90 b/physics/SFC_Models/Lake/Flake/flake_driver.F90 similarity index 100% rename from physics/flake_driver.F90 rename to physics/SFC_Models/Lake/Flake/flake_driver.F90 diff --git a/physics/flake_driver.meta b/physics/SFC_Models/Lake/Flake/flake_driver.meta similarity index 99% rename from physics/flake_driver.meta rename to physics/SFC_Models/Lake/Flake/flake_driver.meta index e665dc962..22ab62d1e 100644 --- a/physics/flake_driver.meta +++ b/physics/SFC_Models/Lake/Flake/flake_driver.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = flake_driver type = scheme - dependencies = flake.F90,machine.F + dependencies = ../../../hooks/machine.F,flake.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/lsm_noah.f b/physics/SFC_Models/Land/Noah/lsm_noah.f similarity index 100% rename from physics/lsm_noah.f rename to physics/SFC_Models/Land/Noah/lsm_noah.f diff --git a/physics/lsm_noah.meta b/physics/SFC_Models/Land/Noah/lsm_noah.meta similarity index 99% rename from physics/lsm_noah.meta rename to physics/SFC_Models/Land/Noah/lsm_noah.meta index e059a22c6..f3ce1d19b 100644 --- a/physics/lsm_noah.meta +++ b/physics/SFC_Models/Land/Noah/lsm_noah.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = lsm_noah type = scheme - dependencies = funcphys.f90,machine.F,set_soilveg.f,sflx.f,surface_perturbation.F90 + dependencies = ../../../tools/funcphys.f90,../../../hooks/machine.F + dependencies = set_soilveg.f,sflx.f,surface_perturbation.F90,namelist_soilveg.f ######################################################################## [ccpp-arg-table] diff --git a/physics/namelist_soilveg.f b/physics/SFC_Models/Land/Noah/namelist_soilveg.f similarity index 100% rename from physics/namelist_soilveg.f rename to physics/SFC_Models/Land/Noah/namelist_soilveg.f diff --git a/physics/set_soilveg.f b/physics/SFC_Models/Land/Noah/set_soilveg.f similarity index 99% rename from physics/set_soilveg.f rename to physics/SFC_Models/Land/Noah/set_soilveg.f index 37f2c2a73..35f4ace37 100644 --- a/physics/set_soilveg.f +++ b/physics/SFC_Models/Land/Noah/set_soilveg.f @@ -44,6 +44,9 @@ subroutine set_soilveg(me,isot,ivet,nlunit,errmsg,errflg) & DEFINED_SLOPE, FXEXP_DATA, NROOT_DATA, REFKDT_DATA, Z0_DATA, & CZIL_DATA, LAI_DATA, CSOIL_DATA + errmsg = '' + errflg = 0 + cmy end locals if(ivet.eq.2) then diff --git a/physics/sflx.f b/physics/SFC_Models/Land/Noah/sflx.f similarity index 100% rename from physics/sflx.f rename to physics/SFC_Models/Land/Noah/sflx.f diff --git a/physics/surface_perturbation.F90 b/physics/SFC_Models/Land/Noah/surface_perturbation.F90 similarity index 100% rename from physics/surface_perturbation.F90 rename to physics/SFC_Models/Land/Noah/surface_perturbation.F90 diff --git a/physics/module_sf_noahmp_glacier.F90 b/physics/SFC_Models/Land/Noahmp/module_sf_noahmp_glacier.F90 similarity index 99% rename from physics/module_sf_noahmp_glacier.F90 rename to physics/SFC_Models/Land/Noahmp/module_sf_noahmp_glacier.F90 index 6e34c43af..fcbe40a70 100644 --- a/physics/module_sf_noahmp_glacier.F90 +++ b/physics/SFC_Models/Land/Noahmp/module_sf_noahmp_glacier.F90 @@ -2652,7 +2652,7 @@ subroutine snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in !to obtain equilibrium state of snow in glacier region - if(sneqv > mwd) then ! 100 mm -> maximum water depth + if(sneqv > mwd .and. isnow /= 0) then ! 100 mm -> maximum water depth bdsnow = snice(0) / dzsnso(0) snoflow = (sneqv - mwd) snice(0) = snice(0) - snoflow diff --git a/physics/module_sf_noahmplsm.F90 b/physics/SFC_Models/Land/Noahmp/module_sf_noahmplsm.F90 similarity index 99% rename from physics/module_sf_noahmplsm.F90 rename to physics/SFC_Models/Land/Noahmp/module_sf_noahmplsm.F90 index 86853dabe..6abd59f69 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/SFC_Models/Land/Noahmp/module_sf_noahmplsm.F90 @@ -2116,7 +2116,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in ! thermal properties of soil, snow, lake, and frozen soil call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in - dt ,snowh ,snice ,snliq , & !in + dt ,snowh ,snice ,snliq , shdfac, & !in smc ,sh2o ,tg ,stc ,ur , & !in lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out @@ -2463,7 +2463,7 @@ end subroutine energy !>\ingroup NoahMP_LSM subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in - dt ,snowh ,snice ,snliq , & !in + dt ,snowh ,snice ,snliq , shdfac, & !in smc ,sh2o ,tg ,stc ,ur , & !in lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out @@ -2480,6 +2480,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys) , intent(in) :: dt !< time step [s] real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice !< snow ice mass (kg/m2) real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq !< snow liq mass (kg/m2) + real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0] real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !< thickness of snow/soil layers [m] real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc !< soil moisture (ice + liq.) [m3/m3] real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sh2o !< liquid soil moisture [m3/m3] @@ -2539,6 +2540,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) + df(1) = df(1) * exp (sbeta * shdfac) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -4888,7 +4890,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & end if endif ! 4 -! use sfc_diag to calculate t2mv and q2v for opt_sfc=1&3 +! use sfc_diag to calculate t2mb and q2b for opt_sfc=1&3 if(opt_diag ==3) then if(opt_sfc == 1 .or. opt_sfc == 3) then @@ -5823,7 +5825,8 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, elseif (opt_trs == chen09) then - z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg)) +! z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg)) + z0m_out = fveg * z0m + (1.0 - fveg) * z0mg czil = 10.0 ** (- 0.4 * parameters%hvt) reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c @@ -5873,7 +5876,7 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, z0h_out = z0m_out - elseif (opt_trs == tessel) then + elseif (opt_trs == chen09 .or. opt_trs == tessel) then if (vegtyp <= 5) then z0h_out = z0m_out @@ -5881,7 +5884,7 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, z0h_out = z0m_out * 0.01 endif - elseif (opt_trs == blumel99 .or. opt_trs == chen09) then + elseif (opt_trs == blumel99) then reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c if (reyn > 2.0) then diff --git a/physics/noahmp_tables.f90 b/physics/SFC_Models/Land/Noahmp/noahmp_tables.f90 similarity index 99% rename from physics/noahmp_tables.f90 rename to physics/SFC_Models/Land/Noahmp/noahmp_tables.f90 index 3b06d7f53..753c8ff24 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/SFC_Models/Land/Noahmp/noahmp_tables.f90 @@ -484,6 +484,9 @@ subroutine read_mp_table_parameters(errmsg, errflg) sr2006_psi_e_a, sr2006_psi_e_b, sr2006_psi_e_c, sr2006_smcmax_a, & sr2006_smcmax_b + errmsg = '' + errflg = 0 + ! initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. ! vegetation parameters isurban_table = -99999 @@ -783,7 +786,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if ( ierr /= 0 ) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -914,7 +917,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if ( ierr /= 0 ) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -957,7 +960,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if ( ierr /= 0 ) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -982,7 +985,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -1011,7 +1014,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -1069,7 +1072,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -1096,7 +1099,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -1249,7 +1252,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -1278,7 +1281,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') diff --git a/physics/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 similarity index 99% rename from physics/noahmpdrv.F90 rename to physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 4500d51a8..c2c03d0de 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -450,7 +450,7 @@ subroutine noahmpdrv_run & integer :: iopt_pedo = 1 ! option for pedotransfer function integer :: iopt_crop = 0 ! option for crop model integer :: iopt_gla = 2 ! option for glacier treatment - integer :: iopt_z0m = 2 ! option for z0m treatment + integer :: iopt_z0m = 1 ! option for z0m treatment ! ! --- local inputs to noah-mp and glacier subroutines; listed in order in noah-mp call diff --git a/physics/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta similarity index 99% rename from physics/noahmpdrv.meta rename to physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 820da5740..64372bdb8 100644 --- a/physics/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = noahmpdrv type = scheme - dependencies = funcphys.f90,machine.F,sfc_diff.f,module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90,set_soilveg.f + dependencies = ../../../tools/funcphys.f90,../../../hooks/machine.F + dependencies = module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90 + dependencies = ../Noah/set_soilveg.f ######################################################################## [ccpp-arg-table] diff --git a/physics/noahmptable.tbl b/physics/SFC_Models/Land/Noahmp/noahmptable.tbl similarity index 100% rename from physics/noahmptable.tbl rename to physics/SFC_Models/Land/Noahmp/noahmptable.tbl diff --git a/physics/lsm_ruc.F90 b/physics/SFC_Models/Land/RUC/lsm_ruc.F90 similarity index 96% rename from physics/lsm_ruc.F90 rename to physics/SFC_Models/Land/RUC/lsm_ruc.F90 index 665fe6d14..ba1b1b4e9 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/SFC_Models/Land/RUC/lsm_ruc.F90 @@ -359,6 +359,8 @@ subroutine lsm_ruc_run & ! inputs & qsurf_ice, gflux_ice, evap_ice, ep1d_ice, hflx_ice, & & cm_ice, ch_ice, snowfallac_ice, acsnow_ice, snowmt_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & + & add_fire_heat_flux, fire_heat_flux_out, & + & frac_grid_burned_out, & ! --- out & rhosnf, sbsno, & & cmm_lnd, chh_lnd, cmm_ice, chh_ice, & @@ -381,7 +383,7 @@ subroutine lsm_ruc_run & ! inputs real (kind_phys), dimension(:), intent(in) :: oro, sigma real (kind_phys), dimension(:), intent(in) :: & - & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & + & t1, sigmaf, dlwflx, dswsfc, tg3, & & coszen, prsl1, wind, shdmin, shdmax, & & sfalb_lnd_bck, snoalb, zf, qc, q1, & ! for land @@ -417,7 +419,7 @@ subroutine lsm_ruc_run & ! inputs real (kind_phys), dimension(:), intent(in) :: zs real (kind_phys), dimension(:), intent(in) :: srflag real (kind_phys), dimension(:), intent(inout) :: & - & canopy, trans, smcwlt2, smcref2, & + & canopy, trans, smcwlt2, smcref2, laixy, & ! for land & weasd_lnd, snwdph_lnd, tskin_lnd, & & tsurf_lnd, z0rl_lnd, tsnow_lnd, & @@ -430,6 +432,9 @@ subroutine lsm_ruc_run & ! inputs ! --- in real (kind_phys), dimension(:), intent(in) :: & & rainnc, rainc, ice, snow, graupel, rhonewsn1 + real (kind_phys), dimension(:), intent(in) :: fire_heat_flux_out, & + frac_grid_burned_out + logical, intent(in) :: add_fire_heat_flux ! --- in/out: ! --- on RUC levels real (kind_phys), dimension(:,:), intent(inout) :: & @@ -505,12 +510,13 @@ subroutine lsm_ruc_run & ! inputs & solnet_lnd, sfcexc, & & runoff1, runoff2, acrunoff, semis_bck, & & sfcems_lnd, hfx_lnd, shdfac, shdmin1d, shdmax1d, & + & fire_heat_flux1d, & & sneqv_lnd, snoalb1d_lnd, snowh_lnd, snoh_lnd, tsnav_lnd, & & snomlt_lnd, sncovr_lnd, soilw, soilm, ssoil_lnd, & & soilt_lnd, tbot, & & xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, & - & precipfr, snfallac_lnd, acsn_lnd, & - & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq + & precipfr, snfallac_lnd, acsn_lnd, soilt1_lnd, chklowq, & + & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, smcwlt, smcref ! ice real (kind_phys),dimension (im,1) :: & & albbck_ice, alb_ice, chs_ice, flhc_ice, flqc_ice, & @@ -540,7 +546,7 @@ subroutine lsm_ruc_run & ! inputs integer :: l, k, i, j, fractional_seaice, ilst real (kind_phys) :: dm, cimin(im) logical :: flag(im), flag_ice(im), flag_ice_uncoupled(im) - logical :: rdlai2d, myj, frpcpn + logical :: myj, frpcpn logical :: debug_print !-- diagnostic point @@ -645,15 +651,27 @@ subroutine lsm_ruc_run & ! inputs nsoil = lsoil_ruc do i = 1, im ! i - horizontal loop - ! reassign smcref2 and smcwlt2 to RUC values if(.not. land(i)) then !water and sea ice - smcref2 (i) = one - smcwlt2 (i) = zero + smcref (i,1) = one + smcwlt (i,1) = zero + xlai (i,1) = zero + elseif (kdt == 1) then + !land + ! reassign smcref2 and smcwlt2 to RUC values at kdt=1 + smcref (i,1) = REFSMC(stype(i)) + smcwlt (i,1) = WLTSMC(stype(i)) + !-- rdlai is .true. when the LAI data is available in the INPUT/sfc_data.nc on cold-start + if(rdlai) then + xlai(i,1) = laixy(i) + else + xlai(i,1) = LAITBL(vtype(i)) + endif else - !land - smcref2 (i) = REFSMC(stype(i)) - smcwlt2 (i) = WLTSMC(stype(i)) + !-- land and kdt > 1, parameters has sub-grid heterogeneity + smcref (i,1) = smcref2 (i) + smcwlt (i,1) = smcwlt2 (i) + xlai (i,1) = laixy (i) endif enddo @@ -813,10 +831,6 @@ subroutine lsm_ruc_run & ! inputs ffrozp(i,j) = real(nint(srflag(i)),kind_phys) endif - !-- rdlai is .false. when the LAI data is not available in the - ! - INPUT/sfc_data.nc - - rdlai2d = rdlai conflx2(i,1,j) = zf(i) * 2._kind_phys ! factor 2. is needed to get the height of ! atm. forcing inside RUC LSM (inherited @@ -843,14 +857,15 @@ subroutine lsm_ruc_run & ! inputs !!\n \a graupelncv - time-step graupel (\f$kg m^{-2} \f$) !!\n \a snowncv - time-step snow (\f$kg m^{-2} \f$) !!\n \a precipfr - time-step precipitation in solid form (\f$kg m^{-2} \f$) -!!\n \a shdfac - areal fractional coverage of green vegetation (0.0-1.0) -!!\n \a shdmin - minimum areal fractional coverage of green vegetation -> !shdmin1d -!!\n \a shdmax - maximum areal fractional coverage of green vegetation -> !shdmax1d +!!\n \a shdfac - areal fractional coverage of green vegetation (0.0-100.%) +!!\n \a shdmin - minimum areal fractional coverage of green vegetation in % -> !shdmin1d +!!\n \a shdmax - maximum areal fractional coverage of green vegetation in % -> !shdmax1d !!\n \a tbot - bottom soil temperature (local yearly-mean sfc air temp) lwdn(i,j) = dlwflx(i) !..downward lw flux at sfc in w/m2 swdn(i,j) = dswsfc(i) !..downward sw flux at sfc in w/m2 + ! all precip input to RUC LSM is in [mm] !prcp(i,j) = rhoh2o * tprcp(i) ! tprcp in [m] - convective plus explicit !raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip @@ -918,17 +933,12 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'MODIS landuse is not available' endif - if(rdlai2d) then - xlai(i,j) = laixy(i) - else - xlai(i,j) = zero - endif - semis_bck(i,j) = semisbase(i) ! --- units % shdfac(i,j) = sigmaf(i)*100._kind_phys shdmin1d(i,j) = shdmin(i)*100._kind_phys shdmax1d(i,j) = shdmax(i)*100._kind_phys + fire_heat_flux1d(i,j) = fire_heat_flux_out(i) ! JLS if (land(i)) then ! at least some land in the grid cell @@ -976,7 +986,6 @@ subroutine lsm_ruc_run & ! inputs snoalb1d_lnd(i,j) = snoalb(i) albbck_lnd(i,j) = min(0.9_kind_phys,albbcksol(i)) !sfalb_lnd_bck(i) - !-- spp_lsm if (spp_lsm == 1) then !-- spp for LSM is dimentioned as (1:lsoil_ruc) @@ -999,6 +1008,19 @@ subroutine lsm_ruc_run & ! inputs alb_lnd(i,j) = albbck_lnd(i,j) * (one-sncovr_lnd(i,j)) + snoalb(i) * sncovr_lnd(i,j) ! sfalb_lnd(i) solnet_lnd(i,j) = dswsfc(i)*(one-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 + IF ( add_fire_heat_flux .and. fire_heat_flux_out(i) > 0) then ! JLS + if (debug_print) then + print *,'alb_lnd before fire, xlat/xlon ', alb_lnd(i,j), xlat_d(i),xlon_d(i) + print *,'fire_heat_flux_out, frac_grid_burned_out, xlat/xlon ', & + fire_heat_flux_out(i),frac_grid_burned_out(i),xlat_d(i),xlon_d(i) + endif + ! limit albedo in the areas affected by the fire + alb_lnd(i,j) = alb_lnd(i,j) * (one-frac_grid_burned_out(i)) + 0.08_kind_phys*frac_grid_burned_out(i) + if (debug_print) then + print *,'alb_lnd after fire, xlat/xlon ', alb_lnd(i,j), xlat_d(i),xlon_d(i) + endif + ENDIF + cmc(i,j) = canopy(i) ! [mm] soilt_lnd(i,j) = tsurf_lnd(i) ! sanity check for snow temperature tsnow @@ -1163,7 +1185,7 @@ subroutine lsm_ruc_run & ! inputs & wet(i,j), cmc(i,j), shdfac(i,j), alb_lnd(i,j), znt_lnd(i,j), & & z0_lnd(i,j), snoalb1d_lnd(i,j), albbck_lnd(i,j), & & xlai(i,j), landusef(i,:,j), nlcat, & - & soilctop(i,:,j), nscat, & + & soilctop(i,:,j), nscat, smcwlt(i,j), smcref(i,j), & & qsfc_lnd(i,j), qsg_lnd(i,j), qvg_lnd(i,j), qcg_lnd(i,j), & & dew_lnd(i,j), soilt1_lnd(i,j), & & tsnav_lnd(i,j), tbot(i,j), vtype_lnd(i,j), stype_lnd(i,j), & @@ -1178,8 +1200,9 @@ subroutine lsm_ruc_run & ! inputs & infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), & & sfcexc(i,j), acceta(i,j), ssoil_lnd(i,j), & & snfallac_lnd(i,j), acsn_lnd(i,j), snomlt_lnd(i,j), & - & smfrsoil(i,:,j),keepfrsoil(i,:,j), .false., & - & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & + & smfrsoil(i,:,j),keepfrsoil(i,:,j), & + & add_fire_heat_flux,fire_heat_flux1d(i,j), .false., & + & shdmin1d(i,j), shdmax1d(i,j), rdlai, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte, errmsg, errflg ) if(debug_print) then @@ -1218,7 +1241,7 @@ subroutine lsm_ruc_run & ! inputs 'ssoil(i,j) =',ssoil_lnd(i,j), & 'snfallac(i,j) =',snfallac_lnd(i,j), & 'acsn_lnd(i,j) =',acsn_lnd(i,j), & - 'snomlt(i,j) =',snomlt_lnd(i,j) + 'snomlt(i,j) =',snomlt_lnd(i,j),'xlai(i,j) =',xlai(i,j) endif endif @@ -1289,6 +1312,10 @@ subroutine lsm_ruc_run & ! inputs ! --- ... unit conversion (from m to mm) snwdph_lnd(i) = snowh_lnd(i,j) * rhoh2o + laixy(i) = xlai(i,j) + smcwlt2(i) = smcwlt(i,j) + smcref2(i) = smcref(i,j) + canopy(i) = cmc(i,j) ! mm weasd_lnd(i) = sneqv_lnd(i,j) ! mm sncovr1_lnd(i) = sncovr_lnd(i,j) @@ -1318,6 +1345,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'LAND -i,j,stype_lnd,vtype_lnd',i,j,stype_lnd(i,j),vtype_lnd(i,j) write (0,*)'i,j,tsurf_lnd(i)',i,j,tsurf_lnd(i) write (0,*)'kdt,iter,stsoil(i,:,j)',kdt,iter,stsoil(i,:,j) + write (0,*)'laixy(i)',laixy(i) endif endif ! end of land @@ -1449,7 +1477,7 @@ subroutine lsm_ruc_run & ! inputs & wet_ice(i,j), cmc(i,j), shdfac(i,j), alb_ice(i,j), & & znt_ice(i,j), z0_ice(i,j), snoalb1d_ice(i,j), & & albbck_ice(i,j), xlai(i,j),landusef(i,:,j), nlcat, & - & soilctop(i,:,j), nscat, & + & soilctop(i,:,j), nscat, smcwlt(i,j), smcref(i,j), & & qsfc_ice(i,j), qsg_ice(i,j), qvg_ice(i,j), qcg_ice(i,j), & & dew_ice(i,j), soilt1_ice(i,j), & & tsnav_ice(i,j), tbot(i,j), vtype_ice(i,j), stype_ice(i,j), & @@ -1464,8 +1492,9 @@ subroutine lsm_ruc_run & ! inputs & infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), & & sfcexc(i,j), acceta(i,j), ssoil_ice(i,j), & & snfallac_ice(i,j), acsn_ice(i,j), snomlt_ice(i,j), & - & smfrice(i,:,j),keepfrice(i,:,j), .false., & - & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & + & smfrice(i,:,j),keepfrice(i,:,j), & + & add_fire_heat_flux,fire_heat_flux1d(i,j), .false., & + & shdmin1d(i,j), shdmax1d(i,j), rdlai, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte, & & errmsg, errflg) @@ -1502,6 +1531,10 @@ subroutine lsm_ruc_run & ! inputs albivis_ice(i) = sfalb_ice(i) albinir_ice(i) = sfalb_ice(i) + laixy(i) = zero + smcwlt2(i) = zero + smcref2(i) = one + stm(i) = 3.e3_kind_phys ! kg m-2 do k = 1, lsoil_ruc tsice(i,k) = stsice(i,k,j) @@ -1517,6 +1550,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'ICE - i,j,stype_ice,vtype_ice)',i,j,stype_ice(i,j),vtype_ice(i,j) write (0,*)'i,j,tsurf_ice(i)',i,j,tsurf_ice(i) write (0,*)'kdt,iter,stsice(i,:,j)',kdt,iter,stsice(i,:,j) + write (0,*)'laixy(i)',laixy(i) endif endif ! ice @@ -1762,6 +1796,8 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in tbot(i,j) = tg3(i) ivgtyp(i,j) = vtype(i) isltyp(i,j) = stype(i) + if(isltyp(i,j)==0) isltyp(i,j)=14 + if(ivgtyp(i,j)==0) ivgtyp(i,j)=17 if (landfrac(i) > zero .or. fice(i) > zero) then !-- land or ice tsk(i,j) = tskin_lnd(i) diff --git a/physics/lsm_ruc.meta b/physics/SFC_Models/Land/RUC/lsm_ruc.meta similarity index 98% rename from physics/lsm_ruc.meta rename to physics/SFC_Models/Land/RUC/lsm_ruc.meta index 34a5b8a8b..bc4d358e3 100644 --- a/physics/lsm_ruc.meta +++ b/physics/SFC_Models/Land/RUC/lsm_ruc.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = lsm_ruc type = scheme - dependencies = machine.F,module_sf_ruclsm.F90,module_soil_pre.F90,namelist_soilveg_ruc.F90,set_soilveg_ruc.F90 + dependencies = ../../../hooks/machine.F,../../../hooks/physcons.F90 + dependencies = module_sf_ruclsm.F90,module_soil_pre.F90,namelist_soilveg_ruc.F90,set_soilveg_ruc.F90 ######################################################################## [ccpp-arg-table] @@ -813,7 +814,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in + intent = inout [dlwflx] standard_name = surface_downwelling_longwave_flux long_name = surface downwelling longwave flux at current time @@ -1747,6 +1748,29 @@ dimensions = () type = logical intent = in +[add_fire_heat_flux] + standard_name = flag_for_fire_heat_flux + long_name = flag to add fire heat flux to LSM + units = flag + dimensions = () + type = logical + intent = in +[fire_heat_flux_out] + standard_name = surface_fire_heat_flux + long_name = heat flux of fire at the surface + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[frac_grid_burned_out] + standard_name = fraction_of_grid_cell_burning + long_name = ration of the burnt area to the grid cell area + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_sf_ruclsm.F90 b/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 similarity index 97% rename from physics/module_sf_ruclsm.F90 rename to physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 index 160127e43..b15592052 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 @@ -97,6 +97,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & MAVAIL,CANWAT,VEGFRA, & ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, & landusef, nlcat, soilctop, nscat, & + smcwlt, smcref, & QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & TBOT,IVGTYP,ISLTYP,XLAND, & ISWATER,ISICE,XICE,XICE_THRESHOLD, & @@ -107,6 +108,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & RUNOFF1,RUNOFF2,ACRUNOFF,SFCEXC, & SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, & SMFR3D,KEEPFR3DFLAG, & + add_fire_heat_flux,fire_heat_flux, & myj,shdmin,shdmax,rdlai2d, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -239,6 +241,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev + LOGICAL, intent(in) :: add_fire_heat_flux + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: fire_heat_flux LOGICAL, intent(in) :: rdlai2d real (kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: ZS @@ -252,6 +256,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & SNOALB, & ALB, & LAI, & + SMCWLT, & + SMCREF, & EMISS, & EMISBCK, & MAVAIL, & @@ -757,6 +763,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & !-- update background emissivity for land points, can have vegetation mosaic effect EMISBCK(I,J) = EMISSL(I,J) + smcwlt(i,j) = wilt + smcref(i,j) = ref IF (debug_print ) THEN if(init)then @@ -961,6 +969,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & snoalb(i,j),albbck(i,j),lai(i,j), & hgt(i,j),stdev(i,j), & !new myj,seaice(i,j),isice, & + add_fire_heat_flux,fire_heat_flux(i,j), & !--- soil fixed fields QWRTZ, & rhocs,dqm,qmin,ref, & @@ -1212,6 +1221,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia QKMS,TKMS,PC,MAVAIL,CST,VEGFRA,ALB,ZNT, & ALB_SNOW,ALB_SNOW_FREE,lai,hgt,stdev, & MYJ,SEAICE,ISICE, & + add_fire_heat_flux,fire_heat_flux, & QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & !--- soil fixed fields sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn, & !--- constants @@ -1256,7 +1266,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SEAICE, & RHO, & QKMS, & - TKMS + TKMS, & + fire_heat_flux + LOGICAL, INTENT(IN ) :: add_fire_heat_flux INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables @@ -1509,7 +1521,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ENDIF if(snhei.gt.0.0081_kind_phys*rhowater/rhosn) then -!*** Update snow density for current temperature (Koren et al. 1999) +!*** Update snow density for current temperature (Koren et al 1999,doi:10.1029/1999JD900232.) BSN=delt/3600._kind_phys*c1sn*exp(0.08_kind_phys*min(zero,tsnav)-c2sn*rhosn*1.e-3_kind_phys) if(bsn*snwe*100._kind_phys.lt.1.e-4_kind_phys) goto 777 XSN=rhosn*(exp(bsn*snwe*100._kind_phys)-one)/(bsn*snwe*100._kind_phys) @@ -1691,7 +1703,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia IF (NEWSN > zero .and. snowfracnewsn > 0.99_kind_phys .and. rhosnfall < 450._kind_phys) THEN ! new snow KEEP_SNOW_ALBEDO = one - !snow_mosaic=0. ! ??? + ! turn off separate treatment of snow covered and snow-free portions of the grid cell + snow_mosaic=0. ! ??? ENDIF IF (debug_print ) THEN @@ -1813,6 +1826,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia UPFLUX = T3 *SOILT XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET + IF ( add_fire_heat_flux .and. fire_heat_flux >0 ) then ! JLS + IF (debug_print ) THEN + print *,'RNET snow-free, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon + ENDIF + RNET = RNET + fire_heat_flux + ENDIF + IF (debug_print ) THEN print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet @@ -1837,7 +1857,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ilands = ivgtyp - CALL SOIL(debug_print,xlat,xlon, & + CALL SOIL(debug_print,xlat, xlon, testptlat, testptlon,& !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin, & @@ -1933,6 +1953,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if (SEAICE .LT. 0.5_kind_phys) then ! LAND + IF ( add_fire_heat_flux .and. fire_heat_flux>0 ) then ! JLS + IF (debug_print ) THEN + print *,'RNET snow, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon + ENDIF + RNET = RNET + fire_heat_flux + ENDIF if(snow_mosaic==one)then snfr=one else @@ -2051,7 +2077,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia hfx = hfxs*(one-snowfrac) + hfx*snowfrac s = ss*(one-snowfrac) + s*snowfrac evapl = evapls*(one-snowfrac) - sublim = sublim*snowfrac prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac fltot = fltots*(one-snowfrac) + fltot*snowfrac ALB = MAX(keep_snow_albedo*alb, & @@ -2063,10 +2088,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac - smelt = smelt * snowfrac - snoh = snoh * snowfrac - snflx = snflx * snowfrac - snom = snom * snowfrac mavail = mavails*(one-snowfrac) + one*snowfrac infiltr = infiltrs*(one-snowfrac) + infiltr*snowfrac @@ -2090,7 +2111,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia qvg = qvgs*(one-snowfrac) + qvg*snowfrac qsg = qsgs*(one-snowfrac) + qsg*snowfrac qcg = qcgs*(one-snowfrac) + qcg*snowfrac - sublim = eeta*snowfrac + sublim = eeta eeta = eetas*(one-snowfrac) + eeta*snowfrac qfx = qfxs*(one-snowfrac) + qfx*snowfrac hfx = hfxs*(one-snowfrac) + hfx*snowfrac @@ -2104,10 +2125,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia (emissn - emiss_snowfree) * snowfrac), emissn)) runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac - smelt = smelt * snowfrac - snoh = snoh * snowfrac - snflx = snflx * snowfrac - snom = snom * snowfrac IF (debug_print ) THEN print *,'SOILT combined on ice', soilt ENDIF @@ -2190,15 +2207,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia IF (debug_print ) then !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then print *,'Snowfallac xlat, xlon',xlat,xlon - print *,'newsn,rhonewsn,newsnowratio=',newsn,rhonewsn,newsnowratio + print *,'newsn [m],rhonewsn,newsnowratio=',newsn,rhonewsn,newsnowratio print *,'Time-step newsn depth [m], swe [m]',newsn,newsn*rhonewsn print *,'Time-step smelt: swe [m]' ,smelt*delt print *,'Time-step sublim: swe,[kg m-2]',sublim*delt endif - snowfallac = snowfallac + max(zero,(newsn*rhonewsn - & ! source of snow (swe) [m] - (smelt+sublim*1.e-3_kind_phys)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m] - /rhonewsn)*rhowater ! snow accumulation in snow depth [mm] + snowfallac = snowfallac + newsn * 1.e3_kind_phys ! accumulated snow depth [mm], using variable snow density IF (debug_print ) THEN !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then @@ -2223,7 +2238,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(SEAICE .LT. 0.5_kind_phys) then ! LAND - CALL SOIL(debug_print,xlat,xlon, & + IF ( add_fire_heat_flux .and. fire_heat_flux>0) then ! JLS + IF (debug_print ) THEN + print *,'RNET no snow, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon + endif + RNET = RNET + fire_heat_flux + ENDIF + + CALL SOIL(debug_print,xlat, xlon, testptlat, testptlon,& !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin, & @@ -2316,7 +2338,7 @@ END FUNCTION QSN !>\ingroup lsm_ruc_group !> This subroutine calculates energy and moisture budget for vegetated surfaces !! without snow, heat diffusion and Richards eqns in soil. - SUBROUTINE SOIL (debug_print,xlat,xlon, & + SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM, & GLW,GSW,GSWin,EMISS,RNET, & @@ -2398,7 +2420,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind_phys), INTENT(IN ) :: DELT,CONFLX + real (kind_phys), INTENT(IN ) :: xlat,xlon,testptlat,testptlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables real (kind_phys), & @@ -2622,6 +2645,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! hydraulic condeuctivities !****************************************************************** CALL SOILPROP( debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,fwsat,lwsat,tav,keepfr, & soilmois,soiliqw,soilice, & @@ -2657,6 +2681,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! TRANSF computes transpiration function !************************************************************** CALL TRANSF(debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nroot,soiliqw,tabs,lai,gswin, & !--- soil fixed fields @@ -2714,7 +2739,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! SOILTEMP soilves heat budget and diffusion eqn. in soil !************************************************************** - CALL SOILTEMP(debug_print,xlat,xlon, & + CALL SOILTEMP(debug_print,xlat,xlon,testptlat,testptlon,& !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & @@ -2784,6 +2809,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! and Richards eqn. !************************************************************************* CALL SOILMOIST (debug_print, & + xlat, xlon, testptlat, testptlon, & !-- input delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & @@ -3578,6 +3604,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ! hydraulic condeuctivities !****************************************************************** CALL SOILPROP(debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,fwsat,lwsat,tav,keepfr, & soilmois,soiliqw,soilice, & @@ -3628,6 +3655,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ! TRANSF computes transpiration function !************************************************************** CALL TRANSF(debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nroot,soiliqw,tabs,lai,gswin, & !--- soil fixed fields @@ -3723,7 +3751,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- TQCAN FOR SOLUTION OF MOISTURE BALANCE (Smirnova et al. 1996, EQ.22,28) ! AND TSO,ETA PROFILES !************************************************************************* - CALL SOILMOIST (debug_print, & + CALL SOILMOIST (debug_print,xlat,xlon,testptlat,testptlon,& !-- input delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & @@ -4046,35 +4074,25 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & RHOnewCSN=sheatsn * RHOnewSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -4510,35 +4528,25 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsn > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -4679,7 +4687,7 @@ END SUBROUTINE SNOWSEAICE !>\ingroup lsm_ruc_group !> This subroutine solves energy budget equation and heat diffusion !! equation. - SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & + SUBROUTINE SOILTEMP( debug_print,xlat,xlon,testptlat,testptlon,& i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,TABS,QVATM,QCATM, & @@ -4749,7 +4757,8 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF + real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon real (kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables real (kind_phys), & @@ -5193,27 +5202,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN RHOnewCSN=sheatsn* RHOnewSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys if(debug_print) then print *,'SnowTemp xlat,xlon,rhosn,keff', xlat,xlon,rhosn,keff,keff/rhocsn*fact print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn @@ -5223,12 +5221,13 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -5587,7 +5586,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & nmelt = 1 soiltfrac=snowfrac*tfrz+(one-snowfrac)*SOILT QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) - qvg=qsg + qvg=snowfrac*qsg+(one-snowfrac)*qvg T3 = STBOLT*TN*TN*TN UPFLUX = T3 * 0.5_kind_phys*(TN + SOILTfrac) XINET = EMISS*(GLW-UPFLUX) @@ -5776,27 +5775,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys if(debug_print) then print *,'End SNOWTEMP - xlat,xlon,rhosn,keff',xlat,xlon,rhosn,keff print *,'End SNOWTEMP - 0.265/rhocsn',0.265/rhocsn @@ -5807,12 +5795,13 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -5959,6 +5948,7 @@ END SUBROUTINE SNOWTEMP !! This subroutine solves moisture budget and computes soil moisture !! and surface and sub-surface runoffs. SUBROUTINE SOILMOIST ( debug_print, & + xlat, xlon, testptlat, testptlon, & DELT,NZS,NDDZS,DTDZS,DTDZS2,RIW, & !--- input parameters ZSMAIN,ZSHALF,DIFFU,HYDRO, & QSG,QVG,QCG,QCATM,QVATM,PRCP, & @@ -6012,6 +6002,7 @@ SUBROUTINE SOILMOIST ( debug_print, & !--- input variables LOGICAL, INTENT(IN ) :: debug_print real (kind_phys), INTENT(IN ) :: DELT + real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon INTEGER, INTENT(IN ) :: NZS,NDDZS ! input variables @@ -6099,8 +6090,12 @@ SUBROUTINE SOILMOIST ( debug_print, & DENOM=one+X2+X4-Q2*COSMC(K) COSMC(K+1)=Q4/DENOM IF (debug_print ) THEN - print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' & - ,q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' & + ,q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k + endif ENDIF RHSMC(K+1)=(SOILMOIS(KN)+Q2*RHSMC(K) & +TRANSP(KN) & @@ -6131,8 +6126,12 @@ SUBROUTINE SOILMOIST ( debug_print, & TOTLIQ=PRCP-DRIP/DELT-(one-VEGFRAC)*DEW*RAS-SMELT IF (debug_print ) THEN -print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & - UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & + UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT + endif ENDIF FLX=TOTLIQ @@ -6175,7 +6174,7 @@ SUBROUTINE SOILMOIST ( debug_print, & INFMAX1 = zero ENDIF IF (debug_print ) THEN - print *,'INFMAX1 before frozen part',INFMAX1 + print *,'INFMAX1 before frozen part',INFMAX1 ENDIF ! ----------- FROZEN GROUND VERSION -------------------------- @@ -6209,8 +6208,8 @@ SUBROUTINE SOILMOIST ( debug_print, & INFMAX = MAX(INFMAX1,HYDRO(1)*SOILMOIS(1)) INFMAX = MIN(INFMAX, -TOTLIQ) IF (debug_print ) THEN -print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', & - INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ + print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', & + INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ ENDIF !---- IF (-TOTLIQ.GT.INFMAX)THEN @@ -6260,8 +6259,12 @@ SUBROUTINE SOILMOIST ( debug_print, & END IF IF (debug_print ) THEN - print *,'SOILMOIS,SOILIQW, soilice',SOILMOIS,SOILIQW,soilice*riw - print *,'COSMC,RHSMC',COSMC,RHSMC + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'SOILMOIS,SOILIQW, soilice',SOILMOIS,SOILIQW,soilice*riw + print *,'COSMC,RHSMC',COSMC,RHSMC + endif ENDIF !--- FINAL SOLUTION FOR SOILMOIS ! DO K=2,NZS1 @@ -6287,7 +6290,11 @@ SUBROUTINE SOILMOIST ( debug_print, & END IF END DO IF (debug_print ) THEN - print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw + endif ENDIF MAVAIL=max(.00001_kind_phys,min(one,(SOILMOIS(1)/(REF-QMIN)*(one-snowfrac)+one*snowfrac))) @@ -6299,6 +6306,7 @@ END SUBROUTINE SOILMOIST !! This subroutine computes thermal diffusivity, and diffusional and !! hydraulic condeuctivities in soil. SUBROUTINE SOILPROP( debug_print, & + xlat, xlon, testptlat, testptlon, & nzs,fwsat,lwsat,tav,keepfr, & !--- input variables soilmois,soiliqw,soilice, & soilmoism,soiliqwm,soilicem, & @@ -6332,6 +6340,8 @@ SUBROUTINE SOILPROP( debug_print, & !--- soil properties LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: NZS + real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & @@ -6508,6 +6518,7 @@ END SUBROUTINE SOILPROP !> This subroutine solves the transpiration function (EQs. 18,19 in !! Smirnova et al.(1997) \cite Smirnova_1997) SUBROUTINE TRANSF( debug_print, & + xlat,xlon,testptlat,testptlon, & nzs,nroot,soiliqw,tabs,lai,gswin, & !--- input variables dqm,qmin,ref,wilt,zshalf,pc,iland, & !--- soil fixed fields tranf,transum) !--- output variables @@ -6528,6 +6539,7 @@ SUBROUTINE TRANSF( debug_print, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,nzs,iland + real (kind_phys), INTENT(IN ) :: xlat,xlon,testptlat,testptlon real (kind_phys) , & INTENT(IN ) :: GSWin, TABS, lai @@ -6574,7 +6586,7 @@ SUBROUTINE TRANSF( debug_print, & ap4=59.656_kind_phys gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 if(totliq.ge.ref) gx=one - if(totliq.le.zero) gx=zero + if(totliq.le.wilt) gx=zero if(gx.gt.one) gx=one if(gx.lt.zero) gx=zero DID=zshalf(2) @@ -6587,7 +6599,7 @@ SUBROUTINE TRANSF( debug_print, & TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID ENDIF !-- uncomment next line for non-linear root distribution - TRANF(1)=part(1) + !TRANF(1)=part(1) DO K=2,NROOT totliq=soiliqw(k)+qmin @@ -6597,7 +6609,7 @@ SUBROUTINE TRANSF( debug_print, & sm4=sm3*sm1 gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 if(totliq.ge.ref) gx=one - if(totliq.le.zero) gx=zero + if(totliq.le.wilt) gx=zero if(gx.gt.one) gx=one if(gx.lt.zero) gx=zero DID=zshalf(K+1)-zshalf(K) @@ -6611,8 +6623,16 @@ SUBROUTINE TRANSF( debug_print, & /(REF-WILT)*DID ENDIF !-- uncomment next line for non-linear root distribution -! TRANF(k)=part(k) + !TRANF(k)=part(k) END DO + IF (debug_print ) THEN + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'soiliqw =',soiliqw,'wilt=',wilt,'qmin= ',qmin + print *,'tranf = ',tranf + endif + ENDIF ! For LAI> 3 => transpiration at potential rate (F.Tardieu, 2013) if(lai > 4._kind_phys) then @@ -6624,7 +6644,11 @@ SUBROUTINE TRANSF( debug_print, & ! pctot=min(0.8,max(pc,pc*lai)) endif IF ( debug_print ) THEN - print *,'pctot,lai,pc',pctot,lai,pc + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'pctot,lai,pc',pctot,lai,pc + endif ENDIF !--- !--- air temperature function @@ -6634,9 +6658,6 @@ SUBROUTINE TRANSF( debug_print, & ELSE FTEM = one / (one + EXP(0.5_kind_phys * (TABS - 314.0_kind_phys))) ENDIF - IF ( debug_print ) THEN - print *,'tabs,ftem',tabs,ftem - ENDIF !--- incoming solar function cmin = one/rsmax_data cmax = one/rstbl(iland) @@ -6659,27 +6680,33 @@ SUBROUTINE TRANSF( debug_print, & else fsol = one endif - IF ( debug_print ) THEN - print *,'GSWin,lai,f1,fsol',gswin,lai,f1,fsol - ENDIF !--- total conductance totcnd =(cmin + (cmax - cmin)*pctot*ftem*fsol)/cmax IF ( debug_print ) THEN - print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' & - ,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'GSWin,Tabs,lai,f1,cmax,cmin,pc,pctot,ftem,fsol',GSWin,Tabs,lai,f1,cmax,cmin,pc,pctot,ftem,fsol + print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' & + ,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd + endif ENDIF !-- TRANSUM - total for the rooting zone transum=zero DO K=1,NROOT ! linear root distribution - TRANF(k)=max(cmin,TRANF(k)*totcnd) + TRANF(k)=max(zero,TRANF(k)*totcnd) transum=transum+tranf(k) END DO IF ( debug_print ) THEN - print *,'transum,TRANF',transum,tranf - endif + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'transum,TRANF',transum,tranf + endif + ENDIF !----------------------------------------------------------------- END SUBROUTINE TRANSF diff --git a/physics/module_soil_pre.F90 b/physics/SFC_Models/Land/RUC/module_soil_pre.F90 similarity index 100% rename from physics/module_soil_pre.F90 rename to physics/SFC_Models/Land/RUC/module_soil_pre.F90 diff --git a/physics/namelist_soilveg_ruc.F90 b/physics/SFC_Models/Land/RUC/namelist_soilveg_ruc.F90 similarity index 100% rename from physics/namelist_soilveg_ruc.F90 rename to physics/SFC_Models/Land/RUC/namelist_soilveg_ruc.F90 diff --git a/physics/set_soilveg_ruc.F90 b/physics/SFC_Models/Land/RUC/set_soilveg_ruc.F90 similarity index 100% rename from physics/set_soilveg_ruc.F90 rename to physics/SFC_Models/Land/RUC/set_soilveg_ruc.F90 diff --git a/physics/sfc_ocean.F b/physics/SFC_Models/Ocean/UFS/sfc_ocean.F similarity index 100% rename from physics/sfc_ocean.F rename to physics/SFC_Models/Ocean/UFS/sfc_ocean.F diff --git a/physics/sfc_ocean.meta b/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta similarity index 99% rename from physics/sfc_ocean.meta rename to physics/SFC_Models/Ocean/UFS/sfc_ocean.meta index 15812e723..848c2e3ed 100644 --- a/physics/sfc_ocean.meta +++ b/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = sfc_ocean type = scheme - dependencies = funcphys.f90,machine.F + dependencies = ../../../tools/funcphys.f90,../../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/sfc_cice.f b/physics/SFC_Models/SeaIce/CICE/sfc_cice.f similarity index 100% rename from physics/sfc_cice.f rename to physics/SFC_Models/SeaIce/CICE/sfc_cice.f diff --git a/physics/sfc_cice.meta b/physics/SFC_Models/SeaIce/CICE/sfc_cice.meta similarity index 99% rename from physics/sfc_cice.meta rename to physics/SFC_Models/SeaIce/CICE/sfc_cice.meta index 796fb2f5d..c44f9d6b5 100644 --- a/physics/sfc_cice.meta +++ b/physics/SFC_Models/SeaIce/CICE/sfc_cice.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = sfc_cice type = scheme - dependencies = machine.F + relative_path = ../../../ + dependencies = hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/sfc_sice.f b/physics/SFC_Models/SeaIce/CICE/sfc_sice.f similarity index 100% rename from physics/sfc_sice.f rename to physics/SFC_Models/SeaIce/CICE/sfc_sice.f diff --git a/physics/sfc_sice.meta b/physics/SFC_Models/SeaIce/CICE/sfc_sice.meta similarity index 99% rename from physics/sfc_sice.meta rename to physics/SFC_Models/SeaIce/CICE/sfc_sice.meta index 75aab21a4..828a83939 100644 --- a/physics/sfc_sice.meta +++ b/physics/SFC_Models/SeaIce/CICE/sfc_sice.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = sfc_sice type = scheme - dependencies = funcphys.f90,machine.F + relative_path = ../../../ + dependencies = tools/funcphys.f90,hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/docs/library.bib b/physics/docs/library.bib index 34bb54e8f..4260fc3c2 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -3760,8 +3760,6 @@ @inproceedings{yudin_et_al_2019 @article{mansell_2013, author = {Edward R. Mansell and Conrad L. Ziegler}, - date-added = {2015-02-26 22:32:59 +0000}, - date-modified = {2020-02-10 23:06:41 +0000}, doi = {10.1175/JAS-D-12-0264.1}, journal = {Journal of the Atmospheric Sciences}, keywords = {storm electrification, microphysics 2-moment}, @@ -3774,8 +3772,6 @@ @article{mansell_2013 @article{mansell_2010, author = {Edward R. Mansell}, - date-added = {2011-02-22 10:34:11 -0600}, - date-modified = {2011-02-22 10:35:34 -0600}, doi = {10.1175/2010JAS3341.1}, journal = {Journal of the Atmospheric Sciences}, keywords = {advection, microphysics 2-moment}, @@ -3787,8 +3783,6 @@ @article{mansell_2010 @article{mansell_etal_2010, author = {E. R. Mansell and C. L. Ziegler and E. C. Bruning}, - date-added = {2007-08-20 15:44:13 -0500}, - date-modified = {2010-04-13 16:55:16 -0500}, doi = {10.1175/2009JAS2965.1}, journal = {Journal of the Atmospheric Sciences}, keywords = {storm electrification, microphysics 2-moment}, @@ -3798,6 +3792,17 @@ @article{mansell_etal_2010 year = {2010}, bdsk-url-1 = {https://doi.org/10.1175/2009JAS2965.1}} +@article{mansell:2020, + Author = {Edward R. Mansell and Dawson, II, Daniel T. and Jerry M. Straka}, + Doi = {10.1175/JAS-D-19-0268.1}, + Journal = jas, + Keywords = {microphysics 3-moment}, + Pages = {3361-3385}, + Title = {Bin-emulating Hail Melting in 3-moment bulk microphysics}, + Volume = {77}, + Year = {2020}, + Bdsk-Url-1 = {https://dx.doi.org/10.1175/JAS-D-12-0264.1}, + @inproceedings{yudin_et_al_2020, author = {Yudin, V. A. and Yang, F. and Karol, S. I. and Fuller-Rowell T. J. and Kubaryk, A. and Juang, H. and Kar, S. and Alpert, J. C. and Li, Z.}, booktitle = {1st UFS Users' Workshop}, diff --git a/physics/docs/pdftxt/NSSLMICRO.txt b/physics/docs/pdftxt/NSSLMICRO.txt index 3d35c9fd2..44d1f069b 100644 --- a/physics/docs/pdftxt/NSSLMICRO.txt +++ b/physics/docs/pdftxt/NSSLMICRO.txt @@ -2,7 +2,7 @@ \page NSSLMICRO_page NSSL 2-moment Cloud Microphysics Scheme \section nssl2m_descrp Description -The NSSL two-moment bulk microphysical parameterization scheme that describes form and phase changes among a range of liquid and ice hydrometeors, as described in Mansell et al. (2010) \cite Mansell_etal_2010 and Mansell and Ziegler (2013) \cite Mansell_2013. The microphysical parameterization predicts the mass mixing ratio and number concentration of cloud droplets, raindrops, cloud ice crystals (columns), snow particles (including large crystals and aggregates), graupel, and (optionally) hail. +The NSSL 2/3-moment bulk microphysical parameterization scheme that describes form and phase changes among a range of liquid and ice hydrometeors, as described in Mansell et al. (2010) \cite Mansell_etal_2010, Mansell and Ziegler (2013) \cite Mansell_2013, and Mansell et al. (2020) \cite Mansell_etal_2020. The microphysical parameterization predicts the mass mixing ratio and number concentration of cloud droplets, raindrops, cloud ice crystals (columns), snow particles (including large crystals and aggregates), graupel, and (optionally) hail. Optionally, a third moment (reflectivity or 6th moment) of rain, graupel, and hail can be activated. The graupel and hail particle densities are also calculated by predicting the total particle volume. The graupel category therefore emulates a range of characteristics from high-density frozen drops (includes small hail) to low-density graupel (from rimed ice crystals/snow) in its size and density spectrum. The hail category is designed to simulate larger hail sizes. Hail is only produced from higher-density large graupel. @@ -10,7 +10,7 @@ Hydrometeor size distributions are assumed to follow a gamma functional form. Mi Cloud concentration nuclei (CCN) concentration is predicted as in Mansell et al. (2010) \cite Mansell_etal_2010 with a bulk activation spectrum approximating small aerosols. The model tracks the number of unactivated CCN, and the local CCN concentration is depleted as droplets are activated, either at cloud base or in cloud. The CCN are subjected to advection and subgrid turbulent mixing but have no other interactions with hydrometeors; for example, scavenging by raindrops is omitted. CCN are restored by droplet evaporation and by a gradual regeneration when no hydrometeors are present. Aerosol sensitivity is enhanced by explicitly treating droplet condensation instead of using a saturation adjustment. Supersaturation (within reason) is allowed to persist in updraft with low droplet concentration. -Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010 \cite Mansell_2010). +Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010 \cite Mansell_2010). Activating the 3-moment scheme provides a natural sedimentation feedback that narrows the size spectrum as size-sorting procedes without the the artificial breakup induced by the 2-moment scheme. The NSSL scheme is designed with deep (severe) convection in mind at grid spacings of up to 4 km, but can also be run at larger grid spacing as needed for nesting etc. It is also able to capture non-severe and winter weather. diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index e986fc322..c4bb5003b 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -54,7 +54,7 @@ show some variables in the namelist that must match the SDF.
  • 10: Morrison-Gettelman microphysics scheme
  • 11: GFDL microphysics scheme
  • 17: NSSL microphysics scheme with background CCN -
  • 18: NSSL microphysics scheme with predicted CCN (compatibility) +
  • 18: NSSL microphysics scheme with predicted CCN (compatibility: 18 = 17 + nssl_ccn_on=.true.) 99 \b Parameters \b related \b to \b radiation \b scheme \b options @@ -406,6 +406,7 @@ show some variables in the namelist that must match the SDF. nssl_ehw0_in mp_nssl constant or max assumed graupel-droplet collection efficiency 0.9 nssl_ehlw0_in mp_nssl constant or max assumed hail-droplet collection efficiency 0.9 nssl_hail_on mp_nssl NSSL flag to activate the hail category .false. +nssl_3moment mp_nssl NSSL flag to activate 3-moment for rain/graupel (and hail if activated).false. nssl_ccn_on mp_nssl NSSL flag to activate the CCN category .true. nssl_invertccn mp_nssl NSSL flag to treat CCN as activated or unactivated .true. nssl_ehw0 mp_nssl NSSL graupel-droplet collection efficiency 0.9 diff --git a/physics/gfs_phy_tracer_config.F b/physics/gfs_phy_tracer_config.F deleted file mode 100644 index 647919a23..000000000 --- a/physics/gfs_phy_tracer_config.F +++ /dev/null @@ -1,228 +0,0 @@ - -! -!! ! Module: gfs_phy_tracer_config -! -! ! Description: gfs physics tracer configuration module -! -! ! Revision history: -! Oct 16 2009 Sarah Lu, adopted from dyn fc -! Nov 21 2009 Sarah Lu, chem tracer specified from ChemRegistry -! Dec 10 2009 Sarah Lu, add doing_GOCART -! Jan 12 2010 Sarah Lu, add trcindx -! Feb 08 2009 Sarah Lu, ri/cpi added to gfs_phy_tracer_type -! Aug 17 2010 Sarah Lu, remove debug print -! Oct 16 2010 Sarah Lu, add fscav -! Aug 08 2011 Jun Wang, remove gocart dependency when not running GOCART -! Sep 17 2011 Sarah Lu, revise chem tracer initialization -! Nov 11 2011 Sarah Lu, allocate but not assign value for cpi/ri array -! Apr 06 2012 Henry Juang, relax hardwire num_tracer, add tracer 4 and 5 -! Apr 23 2012 Jun Wang, remove save attibute for gfs_phy_tracer (already defined) -! --- -- 2016 Anning Cheng add ntiw,ntlnc,ntinc -! May 03 2016 S Moorthi add nto, nto2 -! ------------------------------------------------------------------------- -! - module gfs_phy_tracer_config - use machine , only : kind_phys - - implicit none - SAVE -! -! tracer specification: add fscav -! - type gfs_phy_tracer_type - character*20 , pointer :: chem_name(:) ! chem_tracer name - character*20 , pointer :: vname(:) ! variable name - real(kind=kind_phys), pointer :: ri(:) - real(kind=kind_phys), pointer :: cpi(:) - real(kind=kind_phys), pointer :: fscav(:) - integer :: ntrac, ntrac_met, ntrac_chem - logical :: doing_DU, doing_SU, doing_SS - &, doing_OC, doing_BC, doing_GOCART - endtype gfs_phy_tracer_type - - type (gfs_phy_tracer_type) :: gfs_phy_tracer -! -! misc tracer options -! - logical :: glbsum = .true. -! - -! --- public interface - public tracer_config_init, trcindx - - contains - -! ------------------------------------------------------------------- -! ------------------------------------------------------------------- -! subroutine tracer_config_init (gfs_phy_tracer,ntrac, - subroutine tracer_config_init (ntrac,ntoz,ntcw,ncld, - & ntiw,ntlnc,ntinc, - & fprcp,ntrw,ntsw,ntrnc,ntsnc, - & ntke,nto,nto2,me) - -c -c This subprogram sets up gfs_phy_tracer -c - implicit none -! input - integer, intent(in) :: me, ntoz,ntcw,ntke, - & ntiw,ntlnc,ntinc,nto,nto2, - & fprcp,ntrw,ntsw,ntrnc,ntsnc -! output -! type (gfs_phy_tracer_type), intent(out) :: gfs_phy_tracer -! input/output - integer, intent(inout) :: ntrac -! local - integer :: i, j, status, ierr - character*20 :: rgname - -! initialize ntrac_chem (the default is no chemistry) - gfs_phy_tracer%ntrac_chem = 0 - gfs_phy_tracer%doing_GOCART = .false. - -! initialize chem tracers - call gocart_tracer_config(me) - -! input ntrac is meteorological tracers - gfs_phy_tracer%ntrac_met = ntrac - -! update ntrac = total number of tracers - gfs_phy_tracer%ntrac = gfs_phy_tracer%ntrac_met + - & gfs_phy_tracer%ntrac_chem - ntrac = gfs_phy_tracer%ntrac - - if(me==0) then - print *, 'LU_TRCp: ntrac_met =',gfs_phy_tracer%ntrac_met - print *, 'LU_TRCp: ntrac_chem=',gfs_phy_tracer%ntrac_chem - print *, 'LU_TRCp: ntrac =',gfs_phy_tracer%ntrac - endif - -! Set up tracer name, cpi, and ri - if ( gfs_phy_tracer%ntrac > 0 ) then - allocate(gfs_phy_tracer%vname(ntrac), stat=status) - if( status /= 0 ) then - print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me - return - endif - allocate(gfs_phy_tracer%ri(0:ntrac), stat=status) - if( status /= 0 ) then - print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me - return - endif - allocate(gfs_phy_tracer%cpi(0:ntrac), stat=status) - if( status /= 0 ) then - print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me - return - endif - allocate(gfs_phy_tracer%fscav(ntrac), stat=status) - if( status /= 0 ) then - print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me - return - endif - -!--- fill in met tracers - gfs_phy_tracer%vname(1) = 'spfh' - if(ntcw > 0) gfs_phy_tracer%vname(ntcw) = 'clwmr' - if(ntiw > 0) gfs_phy_tracer%vname(ntiw) = 'climr' - if(ntlnc > 0) gfs_phy_tracer%vname(ntlnc) = 'lnc' - if(ntinc > 0) gfs_phy_tracer%vname(ntinc) = 'inc' - if(ntrw > 0) gfs_phy_tracer%vname(ntrw) = 'rnmr' - if(ntsw > 0) gfs_phy_tracer%vname(ntsw) = 'snwmr' - if(ntrnc > 0) gfs_phy_tracer%vname(ntrnc) = 'rnc' - if(ntsnc > 0) gfs_phy_tracer%vname(ntsnc) = 'snc' - if(ntke > 0) gfs_phy_tracer%vname(ntke) = 'tke' -#ifdef MULTI_GASES - print *,' ++++ ntoz nto nto2 ',ntoz,nto,nto2 - if(ntoz > 0) gfs_phy_tracer%vname(ntoz) = 'spo3' - if(nto > 0) gfs_phy_tracer%vname(nto) = 'spo' - if(nto2 > 0) gfs_phy_tracer%vname(nto2) = 'spo2' -#else - if(ntoz > 0) gfs_phy_tracer%vname(ntoz) = 'o3mr' - if(nto > 0) gfs_phy_tracer%vname(nto) = 'o' - if(nto2 > 0) gfs_phy_tracer%vname(nto2) = 'o2' -#endif - - - gfs_phy_tracer%fscav(1:gfs_phy_tracer%ntrac_met) = 0. - -!--- fill in chem tracers - if ( gfs_phy_tracer%ntrac_chem > 0 ) then - do i = 1,gfs_phy_tracer%ntrac_chem - j = i + gfs_phy_tracer%ntrac_met - rgname = trim(gfs_phy_tracer%chem_name(i)) - if(me==0)print *, 'LU_TRC_phy: vname=',j,rgname - gfs_phy_tracer%vname(j) = rgname - enddo - endif - - endif !! - - return - - end subroutine tracer_config_init -! ------------------------------------------------------------------- -! ------------------------------------------------------------------- - function trcindx( specname, tracer ) - implicit none - - character*(*), intent(in) :: specname - type (gfs_phy_tracer_type), intent(in) :: tracer - - character*10 :: name1, name2 - integer :: i, trcindx - -! -- set default value - trcindx = -999 - -! -- convert specname to upper case - call fixchar(specname, name1, 1) - do i = 1, tracer%ntrac - call fixchar(tracer%vname(i), name2, 1) - if( name1 == name2 ) then - trcindx = i - exit - endif - enddo - - return - end function trcindx - -! ------------------------------------------------------------------- - subroutine fixchar(name_in, name_out, option) - implicit none - - character*(*), intent(in) :: name_in - character*(*), intent(out) :: name_out - integer, intent(in) :: option - - character*10 :: temp - integer :: i, ic - - name_out= ' ' - temp = trim(adjustl(name_in)) - do i = 1, len_trim(temp) - ic = IACHAR(temp(i:i)) - if(option == 1 ) then !<--- convert to upper case - if(ic .ge. 97 .and. ic .le. 122) then - name_out(i:i) = CHAR( IC-32 ) - else - name_out(i:i) = temp(i:i) - endif - endif - if(option == 2 ) then !<--- convert to lower case - if(ic .ge. 65 .and. ic .le. 90) then - name_out(i:i) = CHAR( IC+32 ) - else - name_out(i:i) = temp(i:i) - endif - endif - - enddo - name_out = trim(name_out) - return - - end subroutine fixchar - -! ========================================================================= - - end module gfs_phy_tracer_config diff --git a/physics/gocart_tracer_config_stub.f b/physics/gocart_tracer_config_stub.f deleted file mode 100644 index d6df297c7..000000000 --- a/physics/gocart_tracer_config_stub.f +++ /dev/null @@ -1,17 +0,0 @@ -! -!! ! Subroutine : gocart_tracer_config -! -! ! Description: stub for resetting gfs phys when gocart is running -! -! ! Revision history: -! Aug 09 2011 Jun Wang, initial code -! ------------------------------------------------------------------------- -! - subroutine gocart_tracer_config() -! - -! print *,'TRAC_CONFIG: gocart is not running.' - - return - - end subroutine gocart_tracer_config diff --git a/physics/machine.F b/physics/hooks/machine.F similarity index 100% rename from physics/machine.F rename to physics/hooks/machine.F diff --git a/physics/machine.meta b/physics/hooks/machine.meta similarity index 100% rename from physics/machine.meta rename to physics/hooks/machine.meta diff --git a/physics/physcons.F90 b/physics/hooks/physcons.F90 similarity index 98% rename from physics/physcons.F90 rename to physics/hooks/physcons.F90 index e7ec8fb77..4d86301e2 100644 --- a/physics/physcons.F90 +++ b/physics/hooks/physcons.F90 @@ -33,7 +33,7 @@ !> This module contains some of the most frequently used math and physics !! constants for GCM models. - module physcons + module physcons ! use machine, only: kind_phys, kind_dyn ! @@ -44,7 +44,7 @@ module physcons !> \name Math constants ! real(kind=kind_phys),parameter:: con_pi =3.1415926535897931 !< pi real(kind=kind_phys),parameter:: con_pi =4.0d0*atan(1.0d0) !< pi - real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0_kind_phys !< square root of 2 + real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0_kind_phys !< square root of 2 real(kind=kind_phys),parameter:: con_sqrt3 =1.732051e+0_kind_phys !< quare root of 3 !> \name Geophysics/Astronomy constants @@ -97,6 +97,7 @@ module physcons real(kind=kind_phys),parameter:: con_dldt =con_cvap-con_cliq real(kind=kind_phys),parameter:: con_xpona =-con_dldt/con_rv real(kind=kind_phys),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp) + real(kind=kind_phys),parameter:: con_1ovg = 1._kind_phys/con_g !> \name Other Physics/Chemistry constants (source: 2002 CODATA) real(kind=kind_phys),parameter:: con_c =2.99792458e+8_kind_phys !< speed of light (\f$m/s\f$) diff --git a/physics/module_nst_model.f90 b/physics/module_nst_model.f90 deleted file mode 100644 index 980035fe6..000000000 --- a/physics/module_nst_model.f90 +++ /dev/null @@ -1,971 +0,0 @@ -!>\file module_nst_model.f90 -!! This file contains the diurnal thermocline layer model (DTM) of -!! the GFS NSST scheme. - -!>\defgroup dtm_module GFS NSST Diurnal Thermocline Model -!> This module contains the diurnal thermocline layer model (DTM) of -!! the GFS NSST scheme. -!>\ingroup gfs_nst_main_mod - -!> This module contains the diurnal thermocline layer model (DTM) of -!! the GFS NSST scheme. -module nst_module - -! -! the module of diurnal thermocline layer model -! - use machine , only : kind_phys - use module_nst_parameters, only: z_w_max,z_w_min,z_w_ini,eps_z_w,eps_conv, & - eps_sfs,niter_z_w,niter_conv,niter_sfs,ri_c, & - ri_g,omg_m,omg_sh, kw => tc_w,visw,t0k,cp_w, & - z_c_max,z_c_ini,ustar_a_min,delz,exp_const, & - rad2deg,const_rot,tw_max,sst_max - use module_nst_water_prop, only: sw_rad_skin,sw_ps_9b,sw_ps_9b_aw - implicit none - - contains - -!>\ingroup gfs_nst_main_mod -!! This subroutine contains the module of diurnal thermocline layer model. - subroutine dtm_1p(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & - alpha,beta,alon,sinlat,soltim,grav,le,d_conv, & - xt,xs,xu,xv,xz,xzts,xtts) - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& - hl_ts,rho,alpha,beta,alon,sinlat,soltim,& - grav,le,d_conv - real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts -! local variables - -! -! input variables -! -! timestep: integration time step in seconds -! rich : critical ri (flow dependent) -! tox : x wind stress (n*m^-2 or kg/m/s^2) -! toy : y wind stress (n*m^-2 or kg/m/s^2) -! i0 : solar radiation flux at the surface (wm^-2) -! q : non-solar heat flux at the surface (wm^-2) -! sss : salinity (ppt) -! sep : sr(e-p) (ppt*m/s) -! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes -! hl_ts : d(hl)/d(ts) -! rho : sea water density (kg*m^-3) -! alpha : thermal expansion coefficient (1/k) -! beta : saline contraction coefficient (1/ppt) -! sinlat : sine (lat) -! grav : gravity accelleration -! le : le=(2.501-.00237*tsea)*1e6 -! d-conv : fcl thickness -! -! inout variables -! -! xt : dtl heat content (m*k) -! xs : dtl salinity content (m*ppt) -! xu : dtl x current content (m*m/s) -! xv : dtl y current content (m*m/s) -! xz : dtl thickness (m) -! xzts : d(xz)/d(ts) (m/k ) -! xtts : d(xt)/d(ts) (m) -! -! logical lprnt - -! if (lprnt) print *,' first xt=',xt - if ( xt <= 0.0 ) then ! dtl doesn't exist yet - call dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha,& - beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts) - elseif ( xt > 0.0 ) then ! dtl already exists -! -! forward the system one time step -! - call eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & - beta,alon,sinlat,soltim,grav,le,d_conv, & - xt,xs,xu,xv,xz,xzts,xtts) - endif ! if ( xt == 0 ) then - - end subroutine dtm_1p - -!>\ingroup gfs_nst_main_mod -!! This subroutine integrates one time step with modified Euler method. - subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha,& - beta,alon,sinlat,soltim,grav,le,d_conv, & - xt,xs,xu,xv,xz,xzts,xtts) - -! -! subroutine eulerm: integrate one time step with modified euler method -! - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& - hl_ts,rho,alpha,beta,alon,sinlat,soltim,& - grav,le,d_conv - real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts -! local variables - real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0,xzts0,xtts0 - real(kind=kind_phys) :: fw,aw,q_warm - real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1,xzts1,xtts1 - real(kind=kind_phys) :: xt2,xs2,xu2,xv2,xz2,xzts2,xtts2 - real(kind=kind_phys) :: dzw,drho,fc - real(kind=kind_phys) :: alat,speed -! logical lprnt - -! -! input variables -! -! timestep: integration time step in seconds -! rich : critial ri (flow/mass dependent) -! tox : x wind stress (n*m^-2 or kg/m/s^2) -! toy : y wind stress (n*m^-2 or kg/m/s^2) -! i0 : solar radiation flux at the surface (wm^-2) -! q : non-solar heat flux at the surface (wm^-2) -! sss : salinity (ppt) -! sep : sr(e-p) (ppt*m/s) -! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes -! hl_ts : d(hl)/d(ts) -! rho : sea water density (kg*m^-3) -! alpha : thermal expansion coefficient (1/k) -! beta : saline contraction coefficient (1/ppt) -! alon : longitude (deg) -! sinlat : sine (lat) -! soltim : solar time -! grav : gravity accelleration -! le : le=(2.501-.00237*tsea)*1e6 -! d_conv : fcl thickness (m) -! -! inout variables -! -! xt : dtl heat content (m*k) -! xs : dtl salinity content (m*ppt) -! xu : dtl x current content (m*m/s) -! xv : dtl y current content (m*m/s) -! xz : dtl thickness (m) -! xzts : d(xz)/d(ts) (m/k ) -! xtts : d(xt)/d(ts) (m) - - xt0 = xt - xs0 = xs - xu0 = xu - xv0 = xv - xz0 = xz - xtts0 = xtts - xzts0 = xzts - speed = max(1.0e-8, xu0*xu0+xv0*xv0) - - alat = asin(sinlat)*rad2deg - - fc = const_rot*sinlat - - call sw_ps_9b(xz0,fw) - - q_warm = fw*i0-q !total heat abs in warm layer - - call sw_ps_9b_aw(xz0,aw) - - drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep - -! dzw = xz0*(tox*xu0+toy*xv0) / (rho*(xu0*xu0+xv0*xv0)) & -! + xz0*xz0*xz0*drho*grav / (4.0*rich*(xu0*xu0+xv0*xv0)) - dzw = xz0 * ((tox*xu0+toy*xv0) / (rho*speed) & - + xz0*xz0*drho*grav / (4.0*rich*speed)) - - xt1 = xt0 + timestep*q_warm/(rho*cp_w) - xs1 = xs0 + timestep*sep - xu1 = xu0 + timestep*(fc*xv0+tox/rho) - xv1 = xv0 + timestep*(-fc*xu0+toy/rho) - xz1 = xz0 + timestep*dzw - -! if (lprnt) print *,' xt1=',xt1,' xz1=',xz1,' xz0=',xz0,' dzw=',dzw, & -! 'timestep=',timestep,tox,toy,xu0,xv0,rho,drho,grav,rich - - if ( xt1 <= 0.0 .or. xz1 <= 0.0 .or. xz1 > z_w_max ) then - call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) - return - endif - -! call dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt1,xs1,xu1,xv1,xz1,tr_mda,tr_fca,tr_tla,tr_mwa) - - xzts1 = xzts0 + timestep*((1.0/(xu0*xu0+xv0*xv0)) * & - ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz0**3/(4.0*rich*rho)& - +( (tox*xu0+toy*xv0)/rho+(3.0*drho-alpha*i0*aw*xz0/(rho*cp_w)) & - *grav*xz0*xz0/(4.0*rich) )*xzts0 )) - xtts1 = xtts0 + timestep*(i0*aw*xzts0-q_ts)/(rho*cp_w) - -! if ( 2.0*xt1/xz1 > 0.001 ) then -! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_01 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,& -! 2.0*xt1/xz1,2.0*xs1/xz1,2.0*xu1/xz1,2.0*xv1/xz1,xz1,xtts1,xzts1,d_conv,t_fcl,te -! endif - - call sw_ps_9b(xz1,fw) - q_warm = fw*i0-q !total heat abs in warm layer - call sw_ps_9b_aw(xz1,aw) - drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep - dzw = xz1*(tox*xu1+toy*xv1) / (rho*(xu1*xu1+xv1*xv1)) & - + xz1*xz1*xz1*drho*grav / (4.0*rich*(xu1*xu1+xv1*xv1)) - - xt2 = xt0 + timestep*q_warm/(rho*cp_w) - xs2 = xs0 + timestep*sep - xu2 = xu0 + timestep*(fc*xv1+tox/rho) - xv2 = xv0 + timestep*(-fc*xu1+toy/rho) - xz2 = xz0 + timestep*dzw - -! if (lprnt) print *,' xt2=',xt2,' xz2=',xz2 - - if ( xt2 <= 0.0 .or. xz2 <= 0.0 .or. xz2 > z_w_max ) then - call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) - return - endif - - xzts2 = xzts0 + timestep*((1.0/(xu1*xu1+xv1*xv1)) * & - ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz1**3/(4.0*rich*rho)& - +( (tox*xu1+toy*xv1)/rho+(3.0*drho-alpha*i0*aw*xz1/(rho*cp_w))* & - grav*xz1*xz1/(4.0*rich) )*xzts1 )) - xtts2 = xtts0 + timestep*(i0*aw*xzts1-q_ts)/(rho*cp_w) - - xt = 0.5*(xt1 + xt2) - xs = 0.5*(xs1 + xs2) - xu = 0.5*(xu1 + xu2) - xv = 0.5*(xv1 + xv2) - xz = 0.5*(xz1 + xz2) - xzts = 0.5*(xzts1 + xzts2) - xtts = 0.5*(xtts1 + xtts2) - - if ( xt <= 0.0 .or. xz < 0.0 .or. xz > z_w_max ) then - call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) - endif - -! if (lprnt) print *,' xt=',xt,' xz=',xz -! if ( 2.0*xt/xz > 0.001 ) then -! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_02 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,& -! 2.0*xt/xz,2.0*xs/xz,2.0*xu/xz,2.0*xv/xz,xz,xtts,xzts,d_conv,t_fcl,te -! endif - return - - end subroutine eulerm - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies xz adjustment. - subroutine dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt,xs,xu,xv,xz,tr_mda,tr_fca,tr_tla,tr_mwa) -! apply xz adjustment: minimum depth adjustment (mda) -! free convection adjustment (fca); -! top layer adjustment (tla); -! maximum warming adjustment (mwa) -! - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,i0,q,rho,d_conv - real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz - real(kind=kind_phys), intent(out) :: tr_mda,tr_fca,tr_tla,tr_mwa -! local variables - real(kind=kind_phys) :: dz,t0,ttop0,ttop,fw,q_warm - real(kind=kind_phys) :: xz_fca,xz_tla,xz_mwa -! - real(kind=kind_phys) xz_mda - - tr_mda = 0.0; tr_fca = 0.0; tr_tla = 0.0; tr_mwa = 0.0 - -! apply mda - if ( z_w_min > xz ) then - xz_mda = z_w_min - endif -! apply fca - if ( d_conv > 0.0 ) then - xz_fca = 2.0*xt/((2.0*xt/xz)*(1.0-d_conv/(2.0*xz))) - tr_fca = 1.0 - if ( xz_fca >= z_w_max ) then - call dtl_reset_cv(xt,xs,xu,xv,xz) - go to 10 - endif - endif -! apply tla - dz = min(xz,max(d_conv,delz)) - call sw_ps_9b(dz,fw) - q_warm=fw*i0-q !total heat abs in warm layer - - if ( q_warm > 0.0 ) then - call cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop0) -! ttop = (2.0*xt/xz)*(1.0-dz/(2.0*xz)) - ttop = ((xt+xt)/xz)*(1.0-dz/(xz+xz)) - if ( ttop > ttop0 ) then - xz_tla = (xt+sqrt(xt*(xt-delz*ttop0)))/ttop0 - tr_tla = 1.0 - if ( xz_tla >= z_w_max ) then - call dtl_reset_cv(xt,xs,xu,xv,xz) - go to 10 - endif - endif - endif - -! apply mwa - t0 = 2.0*xt/xz - if ( t0 > tw_max ) then - if ( xz >= z_w_max ) then - call dtl_reset_cv(xt,xs,xu,xv,xz) - go to 10 - endif - endif - - xz = max(xz_mda,xz_fca,xz_tla,xz_mwa) - - 10 continue - - end subroutine dtm_1p_zwa - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies free convection adjustment(fca). - subroutine dtm_1p_fca(d_conv,xt,xtts,xz,xzts) - -! apply xz adjustment: free convection adjustment (fca); -! - real(kind=kind_phys), intent(in) :: d_conv,xt,xtts - real(kind=kind_phys), intent(inout) :: xz,xzts -! local variables - real(kind=kind_phys) :: t_fcl,t0 -! - t0 = 2.0*xt/xz - t_fcl = t0*(1.0-d_conv/(2.0*xz)) - xz = 2.0*xt/t_fcl -! xzts = 2.0*xtts/t_fcl - - end subroutine dtm_1p_fca - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies top layer adjustment (tla). - subroutine dtm_1p_tla(dz,te,xt,xtts,xz,xzts) - -! apply xz adjustment: top layer adjustment (tla); -! - real(kind=kind_phys), intent(in) :: dz,te,xt,xtts - real(kind=kind_phys), intent(inout) :: xz,xzts -! local variables - real(kind=kind_phys) tem -! - tem = xt*(xt-dz*te) - if (tem > 0.0) then - xz = (xt+sqrt(xt*(xt-dz*te)))/te - else - xz = z_w_max - endif -! xzts = xtts*(1.0+0.5*(2.0*xt-dz*te)/sqrt(xt*(xt-dz*te)))/te - end subroutine dtm_1p_tla - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies maximum warming adjustment (mwa). - subroutine dtm_1p_mwa(xt,xtts,xz,xzts) - -! apply xz adjustment: maximum warming adjustment (mwa) -! - real(kind=kind_phys), intent(in) :: xt,xtts - real(kind=kind_phys), intent(inout) :: xz,xzts -! local variables -! - xz = 2.0*xt/tw_max -! xzts = 2.0*xtts/tw_max - end subroutine dtm_1p_mwa - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies minimum depth adjustment (xz adjustment). - subroutine dtm_1p_mda(xt,xtts,xz,xzts) - -! apply xz adjustment: minimum depth adjustment (mda) -! - real(kind=kind_phys), intent(in) :: xt,xtts - real(kind=kind_phys), intent(inout) :: xz,xzts -! local variables - real(kind=kind_phys) :: ta -! - xz = max(z_w_min,xz) - ta = 2.0*xt/xz -! xzts = 2.0*xtts/ta - - end subroutine dtm_1p_mda - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies maximum temperature adjustment (mta). - subroutine dtm_1p_mta(dta,xt,xtts,xz,xzts) - -! apply xz adjustment: maximum temperature adjustment (mta) -! - real(kind=kind_phys), intent(in) :: dta,xt,xtts - real(kind=kind_phys), intent(inout) :: xz,xzts -! local variables - real(kind=kind_phys) :: ta -! - ta = max(0.0,2.0*xt/xz-dta) - if ( ta > 0.0 ) then - xz = 2.0*xt/ta - else - xz = z_w_max - endif -! xzts = 2.0*xtts/ta - - end subroutine dtm_1p_mta - -!>\ingroup gfs_nst_main_mod -!! This subroutine calculates depth for convective adjustment. -subroutine convdepth(kdt,timestep,i0,q,sss,sep,rho,alpha,beta,xt,xs,xz,d_conv) - -! -! calculate depth for convective adjustment -! - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,i0,q,sss,sep,rho,alpha,beta - real(kind=kind_phys), intent(in) :: xt,xs,xz - real(kind=kind_phys), intent(out) :: d_conv - real(kind=kind_phys) :: t,s,d_conv_ini,d_conv2,fxp,aw,s1,s2,fac1 - integer :: n -! -! input variables -! -! timestep: time step in seconds -! i0 : solar radiation flux at the surface (wm^-2) -! q : non-solar heat flux at the surface (wm^-2) -! sss : salinity (ppt) -! sep : sr(e-p) (ppt*m/s) -! rho : sea water density (kg*m^-3) -! alpha : thermal expansion coefficient (1/k) -! beta : saline contraction coefficient (1/ppt) -! xt : initial heat content (k*m) -! xs : initial salinity content (ppt*m) -! xz : initial dtl thickness (m) -! -! output variables -! -! d_conv : free convection depth (m) - -! t : initial diurnal warming t (k) -! s : initial diurnal warming s (ppt) - - n = 0 - t = 2.0*xt/xz - s = 2.0*xs/xz - - s1 = alpha*rho*t-omg_m*beta*rho*s - - if ( s1 == 0.0 ) then - d_conv = 0.0 - else - - fac1 = alpha*q/cp_w+omg_m*beta*rho*sep - if ( i0 <= 0.0 ) then - d_conv2=(2.0*xz*timestep/s1)*fac1 - if ( d_conv2 > 0.0 ) then - d_conv = sqrt(d_conv2) - else - d_conv = 0.0 - endif - elseif ( i0 > 0.0 ) then - - d_conv_ini = 0.0 - - iter_conv: do n = 1, niter_conv - call sw_ps_9b(d_conv_ini,fxp) - call sw_ps_9b_aw(d_conv_ini,aw) - s2 = alpha*(q-(fxp-aw*d_conv_ini)*i0)/cp_w+omg_m*beta*rho*sep - d_conv2=(2.0*xz*timestep/s1)*s2 - if ( d_conv2 < 0.0 ) then - d_conv = 0.0 - exit iter_conv - endif - d_conv = sqrt(d_conv2) - if ( abs(d_conv-d_conv_ini) < eps_conv .and. n <= niter_conv ) exit iter_conv - d_conv_ini = d_conv - enddo iter_conv - d_conv = max(0.0,min(d_conv,z_w_max)) - endif ! if ( i0 <= 0.0 ) then - - endif ! if ( s1 == 0.0 ) then - -! if ( d_conv > 0.01 ) then -! write(*,'(a,i4,i3,10f9.3,3f10.6,f10.1,f6.2)') ' d_conv : ',kdt,n,d_conv,d_conv_ini,q,i0,rho,cp_w,timestep,xt,xs,xz,sep, & -! s1,s2,d_conv2,aw -! endif - - end subroutine convdepth - -!>\ingroup gfs_nst_main_mod - subroutine dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & - alpha,beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts) -! -! determine xz iteratively (starting wit fw = 0.5) and then update the other 6 variables -! - - integer,intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& - hl_ts,rho,alpha,beta,alon,sinlat,soltim,grav,le - real(kind=kind_phys), intent(out) :: xt,xs,xu,xv,xz,xzts,xtts - real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0 - real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1 - real(kind=kind_phys) :: fw,aw,q_warm,ft0,fs0,fu0,fv0,fz0,ft1,fs1,fu1,fv1,fz1 - real(kind=kind_phys) :: coeff1,coeff2,ftime,z_w,z_w_tmp,fc,warml,alat - integer :: n -! -! input variables -! -! timestep: time step in seconds -! tox : x wind stress (n*m^-2 or kg/m/s^2) -! toy : y wind stress (n*m^-2 or kg/m/s^2) -! i0 : solar radiation flux at the surface (wm^-2) -! q : non-solar heat flux at the surface (wm^-2) -! sss : salinity (ppt) -! sep : sr(e-p) (ppt*m/s) -! rho : sea water density (kg*m^-3) -! alpha : thermal expansion coefficient (1/k) -! beta : saline contraction coefficient (1/ppt) -! alon : longitude -! sinlat : sine(latitude) -! grav : gravity accelleration -! le : le=(2.501-.00237*tsea)*1e6 -! -! output variables -! -! xt : onset t content in dtl -! xs : onset s content in dtl -! xu : onset u content in dtl -! xv : onset v content in dtl -! xz : onset dtl thickness (m) -! xzts : onset d(xz)/d(ts) (m/k ) -! xtts : onset d(xt)/d(ts) (m) - - fc=1.46/10000.0/2.0*sinlat - alat = asin(sinlat) -! -! initializing dtl (just before the onset) -! - xt0 = 0.0 - xs0 = 0.0 - xu0 = 0.0 - xv0 = 0.0 - - z_w_tmp=z_w_ini - - call sw_ps_9b(z_w_tmp,fw) -! fw=0.5 ! - q_warm=fw*i0-q !total heat abs in warm layer - - if ( abs(alat) > 1.0 ) then - ftime=sqrt((2.0-2.0*cos(fc*timestep))/(fc*fc*timestep)) - else - ftime=timestep - endif - - coeff1=alpha*grav/cp_w - coeff2=omg_m*beta*grav*rho - warml = coeff1*q_warm-coeff2*sep - - if ( warml > 0.0 .and. q_warm > 0.0) then - iters_z_w: do n = 1,niter_z_w - if ( warml > 0.0 .and. q_warm > 0.0 ) then - z_w=sqrt(2.0*rich*ftime/rho)*sqrt(tox**2+toy**2)/sqrt(warml) - else - z_w = z_w_max - exit iters_z_w - endif - -! write(*,'(a,i4,i4,10f9.3,f9.6,f3.0)') ' z_w = ',kdt,n,z_w,z_w_tmp,timestep,q_warm,q,i0,fw,tox,toy,sep,warml,omg_m - - if (abs(z_w - z_w_tmp) < eps_z_w .and. z_w/=z_w_max .and. n < niter_z_w) exit iters_z_w - z_w_tmp=z_w - call sw_ps_9b(z_w_tmp,fw) - q_warm = fw*i0-q - warml = coeff1*q_warm-coeff2*sep - end do iters_z_w - else - z_w=z_w_max - endif - - xz0 = max(z_w,z_w_min) - -! -! update xt, xs, xu, xv -! - if ( z_w < z_w_max .and. q_warm > 0.0) then - - call sw_ps_9b(z_w,fw) - q_warm=fw*i0-q !total heat abs in warm layer - - ft0 = q_warm/(rho*cp_w) - fs0 = sep - fu0 = fc*xv0+tox/rho - fv0 = -fc*xu0+toy/rho - - xt1 = xt0 + timestep*ft0 - xs1 = xs0 + timestep*fs0 - xu1 = xu0 + timestep*fu0 - xv1 = xv0 + timestep*fv0 - - fz0 = xz0*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz0*xz0/(4.0*rich) & - -alpha*grav*q_warm*xz0*xz0/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1) - xz1 = xz0 + timestep*fz0 - - xz1 = max(xz1,z_w_min) - - if ( xt1 < 0.0 .or. xz1 > z_w_max ) then - call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts) - return - endif - - call sw_ps_9b(xz1,fw) - q_warm=fw*i0-q !total heat abs in warm layer - - ft1 = q_warm/(rho*cp_w) - fs1 = sep - fu1 = fc*xv1+tox/rho - fv1 = -fc*xu1+toy/rho - - fz1 = xz1*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz1*xz1/(4.0*rich) & - -alpha*grav*q_warm*xz1*xz1/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1) - - xt = xt0 + 0.5*timestep*(ft0+ft1) - xs = xs0 + 0.5*timestep*(fs0+fs1) - xu = xu0 + 0.5*timestep*(fu0+fu1) - xv = xv0 + 0.5*timestep*(fv0+fv1) - xz = xz0 + 0.5*timestep*(fz0+fz1) - - xz = max(xz,z_w_min) - - call sw_ps_9b_aw(xz,aw) - -! xzts = (q_ts+(cp_w*omg_m*beta*sss/(le*alpha))*hl_ts)*xz/(i0*xz*aw+2.0*q_warm-2.0*(rho*cp_w*omg_m*beta*sss/alpha)*(sep/sss)) - xzts = (q_ts+omg_m*rho*cp_w*beta*sss*hl_ts*xz/(le*alpha))/(i0*xz*aw+2.0*q_warm-2.0*omg_m*rho*cp_w*beta*sss*sep/(le*alpha)) - xtts = timestep*(i0*aw*xzts-q_ts)/(rho*cp_w) - endif - - if ( xt < 0.0 .or. xz > z_w_max ) then - call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts) - endif - - return - - end subroutine dtm_onset - -!>\ingroup gfs_nst_main_mod -!! This subroutine computes coefficients (\a w_0 and \a w_d) to -!! calculate d(tw)/d(ts). - subroutine cal_w(kdt,xz,xt,xzts,xtts,w_0,w_d) -! -! abstract: calculate w_0,w_d -! -! input variables -! -! kdt : the number of time step -! xt : dtl heat content -! xz : dtl depth -! xzts : d(zw)/d(ts) -! xtts : d(xt)/d(ts) -! -! output variables -! -! w_0 : coefficint 1 to calculate d(tw)/d(ts) -! w_d : coefficint 2 to calculate d(tw)/d(ts) - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: xz,xt,xzts,xtts - real(kind=kind_phys), intent(out) :: w_0,w_d - - w_0 = 2.0*(xtts-xt*xzts/xz)/xz - w_d = (2.0*xt*xzts/xz**2-w_0)/xz - -! if ( 2.0*xt/xz > 1.0 ) then -! write(*,'(a,i4,2f9.3,4f10.4))') ' cal_w : ',kdt,xz,xt,w_0,w_d,xzts,xtts -! endif - end subroutine cal_w - -!>\ingroup gfs_nst_main_mod -!! This subroutine calculates the diurnal warming amount at the top layer -!! with thickness of \a delz. - subroutine cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop) -! -! abstract: calculate -! -! input variables -! -! kdt : the number of record -! timestep : the number of record -! q_warm : total heat abs in layer dz -! rho : sea water density -! dz : dz = max(delz,d_conv) top layer thickness defined to adjust xz -! xt : heat content in dtl at previous time -! xz : dtl thickness at previous time -! -! output variables -! -! ttop : the diurnal warming amount at the top layer with thickness of delz - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,q_warm,rho,dz,xt,xz - real(kind=kind_phys), intent(out) :: ttop - real(kind=kind_phys) :: dt_warm,t0 - - dt_warm = (xt+xt)/xz - t0 = dt_warm*(1.0-dz/(xz+xz)) - ttop = t0 + q_warm*timestep/(rho*cp_w*dz) - - end subroutine cal_ttop - -!>\ingroup gfs_nst_main_mod -!! This subroutine adjust dtm-1p dtl thickness by applying shear flow stability -!! with assumed exponential profile. - subroutine app_sfs(kdt,xt,xs,xu,xv,alpha,beta,grav,d_1p,xz) -! -! abstract: adjust dtm-1p dtl thickness by applying shear flow stability with assumed exponetial profile -! -! input variables -! -! kdt : the number of record -! xt : heat content in dtl -! xs : salinity content in dtl -! xu : u-current content in dtl -! xv : v-current content in dtl -! alpha -! beta -! grav -! d_1p : dtl depth before sfs applied -! -! output variables -! -! xz : dtl depth - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: xt,xs,xu,xv,alpha,beta,grav,d_1p - real(kind=kind_phys), intent(out) :: xz -! real(kind=kind_phys) :: ze,cc,xz0,l,d_sfs, t_sfs, tem - real(kind=kind_phys) :: cc,l,d_sfs,tem - real(kind=kind_phys), parameter :: c2 = 0.3782 - integer :: n - - cc = ri_g/(grav*c2) - - tem = alpha*xt - beta*xs - if (tem > 0.0) then - d_sfs = sqrt(2.0*cc*(xu*xu+xv*xv)/tem) - else - d_sfs = 0.0 - endif - -! xz0 = d_1p -! iter_sfs: do n = 1, niter_sfs -! l = int_epn(0.0,xz0,0.0,xz0,2) -! d_sfs = cc*(xu*xu+xv*xv)/((alpha*xt-beta*xs)*l) -! write(*,'(a,i6,i3,4f9.4))') ' app_sfs_iter : ',kdt,n,cc,l,xz0,d_sfs -! if ( abs(d_sfs-xz0) < eps_sfs .and. n <= niter_sfs ) exit iter_sfs -! xz0 = d_sfs -! enddo iter_sfs - -! ze = a2*d_sfs ! not used! - - l = int_epn(0.0,d_sfs,0.0,d_sfs,2) - -! t_sfs = xt/l -! xz = (xt+xt) / t_sfs - - xz = l + l - -! write(*,'(a,i6,6f9.4))') ' app_sfs : ',kdt,xz0,d_sfs,d_1p,xz,2.0*xt/d_1p,t_sfs - end subroutine app_sfs - -!>\ingroup gfs_nst_main_mod -!! This subroutine calculates d(tz)/d(ts). - subroutine cal_tztr(kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr) -! -! abstract: calculate d(tz)/d(ts) -! -! input variables -! -! kdt : the number of record -! xt : heat content in dtl -! xz : dtl depth (m) -! c_0 : coefficint 1 to calculate d(tc)/d(ts) -! c_d : coefficint 2 to calculate d(tc)/d(ts) -! w_0 : coefficint 1 to calculate d(tw)/d(ts) -! w_d : coefficint 2 to calculate d(tw)/d(ts) -! -! output variables -! -! tztr : d(tz)/d(tr) - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: xt,c_0,c_d,w_0,w_d,zc,zw,z - real(kind=kind_phys), intent(out) :: tztr - - if ( xt > 0.0 ) then - if ( z <= zc ) then -! tztr = 1.0/(1.0-w_0+c_0)+z*(w_d-c_d)/(1.0-w_0+c_0) - tztr = (1.0+z*(w_d-c_d))/(1.0-w_0+c_0) - elseif ( z > zc .and. z < zw ) then -! tztr = (1.0+c_0)/(1.0-w_0+c_0)+z*w_d/(1.0-w_0+c_0) - tztr = (1.0+c_0+z*w_d)/(1.0-w_0+c_0) - elseif ( z >= zw ) then - tztr = 1.0 - endif - elseif ( xt == 0.0 ) then - if ( z <= zc ) then -! tztr = 1.0/(1.0+c_0)-z*c_d/(1.0+c_0) - tztr = (1.0-z*c_d)/(1.0+c_0) - else - tztr = 1.0 - endif - else - tztr = 1.0 - endif - -! write(*,'(a,i4,9f9.4))') ' cal_tztr : ',kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr - end subroutine cal_tztr - -!>\ingroup gfs_nst_main_mod -!> This subroutine contains the upper ocean cool-skin parameterization -!! (Fairall et al, 1996 \cite fairall_et_al_1996). -subroutine cool_skin(ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le,deltat_c,z_c,c_0,c_d) -! -! upper ocean cool-skin parameterizaion, fairall et al, 1996. -! -! input: -! ustar_a : atmosphreic friction velocity at the air-sea interface (m/s) -! f_nsol : the "nonsolar" part of the surface heat flux (w/m^s) -! f_sol_0 : solar radiation at the ocean surface (w/m^2) -! evap : latent heat flux (w/m^2) -! sss : ocean upper mixed layer salinity (ppu) -! alpha : thermal expansion coefficient -! beta : saline contraction coefficient -! rho_w : oceanic density -! rho_a : atmospheric density -! ts : oceanic surface temperature -! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes -! hl_ts : d(hl)/d(ts) -! grav : gravity -! le : -! -! output: -! deltat_c: cool-skin temperature correction (degrees k) -! z_c : molecular sublayer (cool-skin) thickness (m) -! c_0 : coefficient1 to calculate d(tz)/d(ts) -! c_d : coefficient2 to calculate d(tz)/d(ts) - -! - real(kind=kind_phys), intent(in) :: ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le - real(kind=kind_phys), intent(out):: deltat_c,z_c,c_0,c_d -! declare local variables - real(kind=kind_phys), parameter :: a1=0.065, a2=11.0, a3=6.6e-5, a4=8.0e-4, tcw=0.6 & - , tcwi=1.0/tcw - real(kind=kind_phys) :: a_c,b_c,zc_ts,bc1,bc2 - real(kind=kind_phys) :: xi,hb,ustar1_a,bigc,deltaf,fxp - real(kind=kind_phys) :: zcsq - real(kind=kind_phys) :: cc1,cc2,cc3 - - - z_c = z_c_ini ! initial guess - - ustar1_a = max(ustar_a,ustar_a_min) - - call sw_rad_skin(z_c,fxp) - deltaf = f_sol_0*fxp - - hb = alpha*(f_nsol-deltaf)+beta*sss*cp_w*evap/le - bigc = 16*grav*cp_w*(rho_w*visw)**3/(rho_a*rho_a*kw*kw) - - if ( hb > 0 ) then - xi = 6./(1+(bigc*hb/ustar1_a**4)**0.75)**0.3333333 - else - xi = 6.0 - endif - z_c = min(z_c_max,xi*visw/(sqrt(rho_a/rho_w)*ustar1_a )) - - call sw_rad_skin(z_c,fxp) - - deltaf = f_sol_0*fxp - deltaf = f_nsol - deltaf - if ( deltaf > 0 ) then - deltat_c = deltaf * z_c / kw - else - deltat_c = 0. - z_c = 0. - endif -! -! calculate c_0 & c_d -! - if ( z_c > 0.0 ) then - cc1 = 6.0*visw / (tcw*ustar1_a*sqrt(rho_a/rho_w)) - cc2 = bigc*alpha / max(ustar_a,ustar_a_min)**4 - cc3 = beta*sss*cp_w/(alpha*le) - zcsq = z_c * z_c - a_c = a2 + a3/zcsq - (a3/(a4*z_c)+a3/zcsq) * exp(-z_c/a4) - - if ( hb > 0.0 .and. zcsq > 0.0 .and. alpha > 0.0) then - bc1 = zcsq * (q_ts+cc3*hl_ts) - bc2 = zcsq * f_sol_0*a_c - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq) - zc_ts = bc1/bc2 -! b_c = z_c**2*(q_ts+cc3*hl_ts)/(z_c**2*f_sol_0*a_c-4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*z_c**2)) ! d(z_c)/d(ts) - b_c = (q_ts+cc3*hl_ts)/(f_sol_0*a_c & - - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq*zcsq)) ! d(z_c)/d(ts) - c_0 = (z_c*q_ts+(f_nsol-deltaf-f_sol_0*a_c*z_c)*b_c)*tcwi - c_d = (f_sol_0*a_c*z_c*b_c-q_ts)*tcwi - - else - b_c = 0.0 - zc_ts = 0.0 - c_0 = z_c*q_ts*tcwi - c_d = -q_ts*tcwi - endif - -! if ( c_0 < 0.0 ) then -! write(*,'(a,2f12.6,10f10.6)') ' c_0, c_d = ',c_0,c_d,b_c,zc_ts,hb,bc1,bc2,z_c,cc1,cc2,cc3,z_c**2 -! endif - -! c_0 = z_c*q_ts/tcw -! c_d = -q_ts/tcw - - else - c_0 = 0.0 - c_d = 0.0 - endif ! if ( z_c > 0.0 ) then - - end subroutine cool_skin -! -!====================== -! -!>\ingroup gfs_nst_main_mod -!! This function calculates a definitive integral of an exponential curve (power of 2). - real function int_epn(z1,z2,zmx,ztr,n) -! -! abstract: calculate a definitive integral of an exponetial curve (power of 2) -! - real(kind_phys) :: z1,z2,zmx,ztr,zi - real(kind_phys) :: fa,fb,fi,int - integer :: m,i,n - - m = nint((z2-z1)/delz) - fa = exp(-exp_const*((z1-zmx)/(ztr-zmx))**n) - fb = exp(-exp_const*((z2-zmx)/(ztr-zmx))**n) - int = 0.0 - do i = 1, m-1 - zi = z1 + delz*float(i) - fi = exp(-exp_const*((zi-zmx)/(ztr-zmx))**n) - int = int + fi - enddo - int_epn = delz*((fa+fb)/2.0 + int) - end function int_epn - -!>\ingroup gfs_nst_main_mod -!! This subroutine resets the value of xt,xs,xu,xv,xz. - subroutine dtl_reset_cv(xt,xs,xu,xv,xz) - real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz - xt = 0.0 - xs = 0.0 - xu = 0.0 - xv = 0.0 - xz = z_w_max - end subroutine dtl_reset_cv - -!>\ingroup gfs_nst_main_mod -!! This subroutine resets the value of xt,xs,xu,xv,xz,xtts,xzts. - subroutine dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) - real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts - xt = 0.0 - xs = 0.0 - xu = 0.0 - xv = 0.0 - xz = z_w_max - xtts = 0.0 - xzts = 0.0 - end subroutine dtl_reset - -end module nst_module diff --git a/physics/module_nst_parameters.f90 b/physics/module_nst_parameters.f90 deleted file mode 100644 index ee0a34914..000000000 --- a/physics/module_nst_parameters.f90 +++ /dev/null @@ -1,143 +0,0 @@ -!>\file module_nst_parameters.f90 -!! This file contains constants and paramters used in GFS -!! near surface sea temperature scheme. - -!>\defgroup nst_parameters GFS NSST Parameter Module -!! \ingroup gfs_nst_main_mod -!! This module contains constants and parameters used in GFS -!! near surface sea temperature scheme. -!! history: -!! 20210305: X.Li, reduce z_w_max from 30 m to 20 m -module module_nst_parameters - use machine, only : kind_phys - ! - ! air constants and coefficients from the atmospehric model - use physcons, only: & - eps => con_eps & - ,cp_a => con_cp & !< spec heat air @p (j/kg/k) - , epsm1 => con_epsm1 & - , hvap => con_hvap & !< lat heat h2o cond (j/kg) - ,sigma_r => con_sbc & !< stefan-boltzmann (w/m2/k4) - ,grav => con_g & !< acceleration due to gravity (kg/m/s^2) - ,omega => con_omega & !< ang vel of earth (1/s) - ,rvrdm1 => con_fvirt & - ,rd => con_rd & - ,rocp => con_rocp & !< r/cp - ,pi => con_pi - ! - ! note: take timestep from here later - public - integer :: & - niter_conv = 5, & - niter_z_w = 5, & - niter_sfs = 5 - real (kind=kind_phys), parameter :: & - ! - ! general constants - sec_in_day=86400. & - ,sec_in_hour=3600. & - ,solar_time_6am=21600.0 & - ,const_rot=0.000073 & !< constant to calculate corioli force - ,ri_c=0.65 & - ,ri_g=0.25 & - ,eps_z_w=0.01 & !< criteria to finish iterations for z_w - ,eps_conv=0.01 & !< criteria to finish iterations for d_conv - ,eps_sfs=0.01 & !< criteria to finish iterations for d_sfs - ,z_w_max=20.0 & !< max warm layer thickness - ,z_w_min=0.2 & !< min warm layer thickness - ,z_w_ini=0.2 & !< initial warm layer thickness in dtl_onset - ,z_c_max=0.01 & !< maximum of sub-layer thickness (m) - ,z_c_ini=0.001 & !< initial value of z_c - ,ustar_a_min=0.031 & !< minimum of friction wind speed (m/s): 0.031 ~ 1m/s at 10 m hight - ,tau_min=0.005 & !< minimum of wind stress for dtm - ,exp_const=9.5 & !< coefficient in exponet profile - ,delz=0.1 & !< vertical increment for integral calculation (m) - ,von=0.4 & !< von karman's "constant" - ,t0k=273.16 & !< celsius to kelvin - ,gray=0.97 & - ,sst_max=308.16 & - ,tw_max=5.0 & - ,wd_max=2.0 & - ,omg_m =1.0 & !< trace factor to apply salinity effect - ,omg_rot = 1.0 & !< trace factor to apply rotation effect - ,omg_sh = 1.0 & !< trace factor to apply sensible heat due to rainfall effect - ,visw=1.e-6 & !< m2/s kinematic viscosity water - ,novalue=0 & - ,smallnumber=1.e-6 & - ,timestep_oc=sec_in_day/8. & !< time step in the ocean model (3 hours) - ,radian=2.*pi/180. & - ,rad2deg=180./pi & - ,cp_w=4000. & !< specific heat water (j/kg/k ) - ,rho0_w=1022.0 & !< density water (kg/m3 ) (or 1024.438) - ,vis_w=1.e-6 & !< kinematic viscosity water (m2/s ) - ,tc_w=0.6 & !< thermal conductivity water (w/m/k ) - ,capa_w =3950.0 & !< heat capacity of sea water ! - ,thref =1.0e-3 !< reference value of specific volume (m**3/kg) - -!!$!============================================ -!!$ -!!$ ,lvapor=2.453e6 & ! latent heat of vaporization note: make it function of t ????? note the same as hvap -!!$ ,alpha=1 ! thermal expansion coefficient -!!$ ,beta ! saline contraction coefficient -!!$ ,cp=1 !=1 specific heat of sea water -!!$ ,g=1 ! acceleration due to gravity -!!$ ,kw=1 ! thermal conductivity of water -!!$ ,nu=1 !kinematic wiscosity -!!$ ,rho_w=1 !water density -!!$ ,rho_a=1 !air density -!!$ ,l_vapr=2.453e6 -!!$ ,novalue=--1.0e+10 -!!$ -!!$c factors -!!$ beta=1.2 !given as 1.25 in fairall et al.(1996) -!!$ von=0.4 ! von karman's "constant" -!!$c fdg=1.00 ! fairall's lkb rr to von karman adjustment -!!$ fdg=1.00 !based on results from flux workshop august 1995 -!!$ tok=273.16 ! celsius to kelvin -!!$ twopi=3.14159*2. -!!$ -!!$c air constants and coefficients -!!$ rgas=287.1 !j/kg/k gas const. dry air -!!$ xlv=(2.501-0.00237*ts)*1e+6 !j/kg latent heat of vaporization at ts -!!$ cpa=1004.67 !j/kg/k specific heat of dry air (businger 1982) -!!$ cpv=cpa*(1+0.84*q) !moist air - currently not used (businger 1982) -!!$ rhoa=p*100./(rgas*(t+tok)*(1.+.61*q)) !kg/m3 moist air density ( " ) -!!$ visa=1.326e-5*(1+6.542e-3*t+8.301e-6*t*t-4.84e-9*t*t*t) !m2/s -!!$ !kinematic viscosity of dry air - andreas (1989) crrel rep. 89-11 -!!$c -!!$c cool skin constants -!!$ al=2.1e-5*(ts+3.2)**0.79 !water thermal expansion coefft. -!!$ be=0.026 !salinity expansion coefft. -!!$ cpw=4000. !j/kg/k specific heat water -!!$ rhow=1022. !kg/m3 density water -!!$ visw=1.e-6 !m2/s kinematic viscosity water -!!$ tcw=0.6 !w/m/k thermal conductivity water -!!$ bigc=16.*grav*cpw*(rhow*visw)**3/(tcw*tcw*rhoa*rhoa) -!!$ wetc=0.622*xlv*qs/(rgas*(ts+tok)**2) !correction for dq;slope of sat. vap. -!!$ -!!$! -!!$! functions -!!$ -!!$ -!!$ real, parameter :: timestep=86400. !integration time step, second -!!$ -!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 -!!$ real, parameter :: capa =3950.0 !heat capacity of sea water -!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 -!!$ real , parameter :: hslab=50.0 !slab ocean depth -!!$ real , parameter :: bad=-1.0e+10 -!!$ real , parameter :: tmin=2.68e+02 -!!$ real , parameter :: tmax=3.11e+02 -!!$ -!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 -!!$ real, parameter :: capa =3950.0 !heat capacity of sea water -!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 -!!$ real, parameter :: tmin=2.68e+02 !normal minimal temp -!!$ real, parameter :: tmax=3.11e+02 !normal max temp -!!$ real, parameter :: smin=1.0 !normal minimal salt -!!$ real, parameter :: smax=50. !normal maximum salt -!!$ real, parameter :: visct=1.e-5 !viscocity for temperature diffusion -!!$ real, parameter :: viscs=1.e-5 !viscocity for salt diffusion -!!$ -!!$ -end module module_nst_parameters diff --git a/physics/module_nst_water_prop.f90 b/physics/module_nst_water_prop.f90 deleted file mode 100644 index 6a183da52..000000000 --- a/physics/module_nst_water_prop.f90 +++ /dev/null @@ -1,762 +0,0 @@ -!>\file module_nst_water_prop.f90 -!! This file contains GFS NSST water property subroutines. - -!>\defgroup waterprop GFS NSST Water Property -!!This module contains GFS NSST water property subroutines. -!!\ingroup gfs_nst_main_mod -module module_nst_water_prop - use machine, only : kind_phys - use module_nst_parameters, only : t0k - ! - private - public :: rhocoef,density,sw_rad,sw_rad_aw,sw_rad_sum,sw_rad_upper,sw_rad_upper_aw,sw_rad_skin,grv,solar_time_from_julian,compjd, & - sw_ps_9b,sw_ps_9b_aw,get_dtzm_point,get_dtzm_2d - - ! - interface sw_ps_9b - module procedure sw_ps_9b - end interface - interface sw_ps_9b_aw - module procedure sw_ps_9b_aw - end interface - ! - interface sw_rad - module procedure sw_fairall_6exp_v1 ! sw_wick_v1 - end interface - interface sw_rad_aw - module procedure sw_fairall_6exp_v1_aw - end interface - interface sw_rad_sum - module procedure sw_fairall_6exp_v1_sum - end interface - interface sw_rad_upper - module procedure sw_soloviev_3exp_v2 - end interface - interface sw_rad_upper_aw - module procedure sw_soloviev_3exp_v2_aw - end interface - interface sw_rad_skin - module procedure sw_ohlmann_v1 - end interface -contains - ! ------------------------------------------------------ -!>\ingroup gfs_nst_main_mod -!! This subroutine computes thermal expansion coefficient (alpha) -!! and saline contraction coefficient (beta). - subroutine rhocoef(t, s, rhoref, alpha, beta) - ! ------------------------------------------------------ - - ! compute thermal expansion coefficient (alpha) - ! and saline contraction coefficient (beta) using - ! the international equation of state of sea water - ! (1980). ref: pond and pickard, introduction to - ! dynamical oceanography, pp310. - ! note: compression effects are not included - - implicit none - real(kind=kind_phys), intent(in) :: t, s, rhoref - real(kind=kind_phys), intent(out) :: alpha, beta - real(kind=kind_phys) :: tc - - tc = t - t0k - - alpha = & - 6.793952e-2 & - - 2.0 * 9.095290e-3 * tc + 3.0 * 1.001685e-4 * tc**2 & - - 4.0 * 1.120083e-6 * tc**3 + 5.0 * 6.536332e-9 * tc**4 & - - 4.0899e-3 * s & - + 2.0 * 7.6438e-5 * tc * s - 3.0 * 8.2467e-7 * tc**2 * s & - + 4.0 * 5.3875e-9 * tc**3 * s & - + 1.0227e-4 * s**1.5 - 2.0 * 1.6546e-6 * tc * s**1.5 - - ! note: rhoref - specify - ! - alpha = -alpha/rhoref - - beta = & - 8.24493e-1 - 4.0899e-3 * tc & - + 7.6438e-5 * tc**2 - 8.2467e-7 * tc**3 & - + 5.3875e-9 * tc**4 - 1.5 * 5.72466e-3 * s**.5 & - + 1.5 * 1.0227e-4 * tc * s**.5 & - - 1.5 * 1.6546e-6 * tc**2 * s**.5 & - + 2.0 * 4.8314e-4 * s - - beta = beta / rhoref - - end subroutine rhocoef - ! ---------------------------------------- -!>\ingroup gfs_nst_main_mod -!! This subroutine computes sea water density. - subroutine density(t, s, rho) - ! ---------------------------------------- - implicit none - - ! input - real(kind=kind_phys), intent(in) :: t !unit, k - real(kind=kind_phys), intent(in) :: s !unit, 1/1000 - ! output - real(kind=kind_phys), intent(out) :: rho !unit, kg/m^3 - ! local - real(kind=kind_phys) :: tc - - ! compute density using the international equation - ! of state of sea water 1980, (pond and pickard, - ! introduction to dynamical oceanography, pp310). - ! compression effects are not included - - rho = 0.0 - tc = t - t0k - - ! effect of temperature on density (lines 1-3) - ! effect of temperature and salinity on density (lines 4-8) - rho = & - 999.842594 + 6.793952e-2 * tc & - - 9.095290e-3 * tc**2 + 1.001685e-4 * tc**3 & - - 1.120083e-6 * tc**4 + 6.536332e-9 * tc**5 & - + 8.24493e-1 * s - 4.0899e-3 * tc * s & - + 7.6438e-5 * tc**2 * s - 8.2467e-7 * tc**3 * s & - + 5.3875e-9 * tc**4 * s - 5.72466e-3 * s**1.5 & - + 1.0227e-4 * tc * s**1.5 - 1.6546e-6 * tc**2 * s**1.5 & - + 4.8314e-4 * s**2 - - end subroutine density - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod -!! This subroutine computes the fraction of the solar radiation absorbed -!! by the depth z following Paulson and Simpson (1981) \cite paulson_and_simpson_1981 . - elemental subroutine sw_ps_9b(z,fxp) - ! - ! fraction of the solar radiation absorbed by the ocean at the depth z - ! following paulson and simpson, 1981 - ! - ! input: - ! z: depth (m) - ! - ! output: - ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real,intent(in):: z - real,intent(out):: fxp - real, dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & - ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) - ! - if(z>0) then - fxp=1.0-(f(1)*exp(-z/gamma(1))+f(2)*exp(-z/gamma(2))+f(3)*exp(-z/gamma(3))+ & - f(4)*exp(-z/gamma(4))+f(5)*exp(-z/gamma(5))+f(6)*exp(-z/gamma(6))+ & - f(7)*exp(-z/gamma(7))+f(8)*exp(-z/gamma(8))+f(9)*exp(-z/gamma(9))) - else - fxp=0. - endif - ! - end subroutine sw_ps_9b - ! - !====================== - ! - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod -!! This subroutine - elemental subroutine sw_ps_9b_aw(z,aw) - ! - ! d(fw)/d(z) for 9-band - ! - ! input: - ! z: depth (m) - ! - ! output: - ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real,intent(in):: z - real,intent(out):: aw - real, dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & - ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) - ! - if(z>0) then - aw=(f(1)/gamma(1))*exp(-z/gamma(1))+(f(2)/gamma(2))*exp(-z/gamma(2))+(f(3)/gamma(3))*exp(-z/gamma(3))+ & - (f(1)/gamma(4))*exp(-z/gamma(4))+(f(2)/gamma(5))*exp(-z/gamma(5))+(f(6)/gamma(6))*exp(-z/gamma(6))+ & - (f(1)/gamma(7))*exp(-z/gamma(7))+(f(2)/gamma(8))*exp(-z/gamma(8))+(f(9)/gamma(9))*exp(-z/gamma(9)) - else - aw=0. - endif - ! - end subroutine sw_ps_9b_aw - ! - !====================== -!>\ingroup gfs_nst_main_mod -!! This subroutine computes fraction of the solar radiation absorbed by the ocean at the depth -!! z (Fairall et al. (1996) \cite fairall_et_al_1996, p. 1298) following Paulson and Simpson -!! (1981) \cite paulson_and_simpson_1981 . - elemental subroutine sw_fairall_6exp_v1(z,fxp) - ! - ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) - ! following paulson and simpson, 1981 - ! - ! input: - ! z: depth (m) - ! - ! output: - ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z - real(kind=kind_phys),intent(out):: fxp - real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & - ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) - real(kind=kind_phys),dimension(9) :: zgamma - real(kind=kind_phys),dimension(9) :: f_c - ! - if(z>0) then - zgamma=z/gamma - f_c=f*(1.-1./zgamma*(1-exp(-zgamma))) - fxp=sum(f_c) - else - fxp=0. - endif - ! - end subroutine sw_fairall_6exp_v1 - ! - !====================== - ! - ! -!>\ingroup gfs_nst_main_mod -!! This subroutine calculates fraction of the solar radiation absorbed by the -!! ocean at the depth z (fairall et al.(1996) \cite fairall_et_al_1996; p.1298) -!! following Paulson and Simpson (1981) \cite paulson_and_simpson_1981. - elemental subroutine sw_fairall_6exp_v1_aw(z,aw) - ! - ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) - ! following paulson and simpson, 1981 - ! - ! input: - ! z: depth (m) - ! - ! output: - ! aw: d(fxp)/d(z) - ! - ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z - real(kind=kind_phys),intent(out):: aw - real(kind=kind_phys) :: fxp - real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & - ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) - real(kind=kind_phys),dimension(9) :: zgamma - real(kind=kind_phys),dimension(9) :: f_aw - ! - if(z>0) then - zgamma=z/gamma - f_aw=(f/z)*((gamma/z)*(1-exp(-zgamma))-exp(-zgamma)) - aw=sum(f_aw) - -! write(*,'(a,f6.2,f12.6,9f10.4)') 'z,aw in sw_rad_aw : ',z,aw,f_aw - - else - aw=0. - endif - ! - end subroutine sw_fairall_6exp_v1_aw - ! -!>\ingroup gfs_nst_main_mod -!! This subroutine computes fraction of the solar radiation absorbed by the ocean at the -!! depth z (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1298) following Paulson and -!! Simpson (1981) \cite paulson_and_simpson_1981 . -!>\param[in] z depth (m) -!>\param[out] sum for convection depth calculation - elemental subroutine sw_fairall_6exp_v1_sum(z,sum) - ! - ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) - ! following paulson and simpson, 1981 - ! - ! input: - ! z: depth (m) - ! - ! output: - ! sum: for convection depth calculation - ! - ! - implicit none - real(kind=kind_phys),intent(in):: z - real(kind=kind_phys),intent(out):: sum - real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) - real(kind=kind_phys),dimension(9) :: zgamma - real(kind=kind_phys),dimension(9) :: f_sum - ! -! zgamma=z/gamma -! f_sum=(zgamma/z)*exp(-zgamma) -! sum=sum(f_sum) - - sum=(1.0/gamma(1))*exp(-z/gamma(1))+(1.0/gamma(2))*exp(-z/gamma(2))+(1.0/gamma(3))*exp(-z/gamma(3))+ & - (1.0/gamma(4))*exp(-z/gamma(4))+(1.0/gamma(5))*exp(-z/gamma(5))+(1.0/gamma(6))*exp(-z/gamma(6))+ & - (1.0/gamma(7))*exp(-z/gamma(7))+(1.0/gamma(8))*exp(-z/gamma(8))+(1.0/gamma(9))*exp(-z/gamma(9)) - ! - end subroutine sw_fairall_6exp_v1_sum - ! - !====================== -!>\ingroup gfs_nst_main_mod -!! Solar radiation absorbed by the ocean at the depth z (Fairall et al. (1996) -!! \cite fairall_et_al_1996, p.1298) -!!\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) -!!\param[in] z depth (m) -!!\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) - elemental subroutine sw_fairall_simple_v1(f_sol_0,z,df_sol_z) - ! - ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) - ! - ! input: - ! f_sol_0: solar radiation at the ocean surface (w/m^2) - ! z: depth (m) - ! - ! output: - ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z,f_sol_0 - real(kind=kind_phys),intent(out):: df_sol_z - ! - if(z>0) then - df_sol_z=f_sol_0*(0.137+11.0*z-6.6e-6/z*(1.-exp(-z/8.e-4))) - else - df_sol_z=0. - endif - ! - end subroutine sw_fairall_simple_v1 - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod -!! solar radiation absorbed by the ocean at the depth z (Zeng and Beljaars (2005) -!! \cite zeng_and_beljaars_2005 , p.5). -!>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) -!>\param[in] z depth (m) -!>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) - elemental subroutine sw_wick_v1(f_sol_0,z,df_sol_z) - ! - ! solar radiation absorbed by the ocean at the depth z (zeng and beljaars, 2005, p.5) - ! - ! input: - ! f_sol_0: solar radiation at the ocean surface (w/m^2) - ! z: depth (m) - ! - ! output: - ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z,f_sol_0 - real(kind=kind_phys),intent(out):: df_sol_z - ! - if(z>0) then - df_sol_z=f_sol_0*(0.065+11.0*z-6.6e-5/z*(1.-exp(-z/8.e-4))) - else - df_sol_z=0. - endif - ! - end subroutine sw_wick_v1 - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod -!! This subroutine computes solar radiation absorbed by the ocean at the depth z -!! (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1301) following -!! Soloviev and Vershinsky (1982) \cite soloviev_and_vershinsky_1982. -!>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) -!>\param[in] z depth (m) -!>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) - elemental subroutine sw_soloviev_3exp_v1(f_sol_0,z,df_sol_z) - ! - ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) - ! following soloviev, 1982 - ! - ! input: - ! f_sol_0: solar radiation at the ocean surface (w/m^2) - ! z: depth (m) - ! - ! output: - ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z,f_sol_0 - real(kind=kind_phys),intent(out):: df_sol_z - real(kind=kind_phys),dimension(3) :: f_c - real(kind=kind_phys), dimension(3), parameter :: f=(/0.45,0.27,0.28/) & - ,gamma=(/12.8,0.357,0.014/) - ! - if(z>0) then - f_c = f*gamma(int(1-exp(-z/gamma))) - df_sol_z = f_sol_0*(1.0-sum(f_c)/z) - else - df_sol_z = 0. - endif - ! - end subroutine sw_soloviev_3exp_v1 - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod - elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z) - ! - ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) - ! following soloviev, 1982 - ! - ! input: - ! f_sol_0: solar radiation at the ocean surface (w/m^2) - ! z: depth (m) - ! - ! output: - ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z,f_sol_0 - real(kind=kind_phys),intent(out):: df_sol_z - ! - if(z>0) then - df_sol_z=f_sol_0*(1.0 & - -(0.28*0.014*(1.-exp(-z/0.014)) & - +0.27*0.357*(1.-exp(-z/0.357)) & - +.45*12.82*(1.-exp(-z/12.82)))/z & - ) - else - df_sol_z=0. - endif - ! - end subroutine sw_soloviev_3exp_v2 - -!>\ingroup gfs_nst_main_mod - elemental subroutine sw_soloviev_3exp_v2_aw(z,aw) - ! - ! aw = d(fxp)/d(z) - ! following soloviev, 1982 - ! - ! input: - ! z: depth (m) - ! - ! output: - ! aw: d(fxp)/d(z) - ! - implicit none - real(kind=kind_phys),intent(in):: z - real(kind=kind_phys),intent(out):: aw - real(kind=kind_phys):: fxp - ! - if(z>0) then - fxp=(1.0 & - -(0.28*0.014*(1.-exp(-z/0.014)) & - + 0.27*0.357*(1.-exp(-z/0.357)) & - + 0.45*12.82*(1.-exp(-z/12.82)))/z & - ) - aw=1.0-fxp-(0.28*exp(-z/0.014)+0.27*exp(-z/0.357)+0.45*exp(-z/12.82)) - else - aw=0. - endif - end subroutine sw_soloviev_3exp_v2_aw - ! - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod - elemental subroutine sw_ohlmann_v1(z,fxp) - ! - ! fraction of the solar radiation absorbed by the ocean at the depth z - ! - ! input: - ! z: depth (m) - ! - ! output: - ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z - real(kind=kind_phys),intent(out):: fxp - ! - if(z>0) then - fxp=.065+11.*z-6.6e-5/z*(1.-exp(-z/8.0e-4)) - else - fxp=0. - endif - ! - end subroutine sw_ohlmann_v1 - ! - -!>\ingroup gfs_nst_main_mod -function grv(lat) - real(kind=kind_phys) :: lat - real(kind=kind_phys) :: gamma,c1,c2,c3,c4,pi,phi,x - gamma=9.7803267715 - c1=0.0052790414 - c2=0.0000232718 - c3=0.0000001262 - c4=0.0000000007 - pi=3.141593 - - phi=lat*pi/180 - x=sin(phi) - grv=gamma*(1+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8)) - !print *,'grav=',grv,lat -end function grv - -!>\ingroup gfs_nst_main_mod -!>This subroutine computes solar time from the julian date. -subroutine solar_time_from_julian(jday,xlon,soltim) - ! - ! calculate solar time from the julian date - ! - implicit none - real(kind=kind_phys), intent(in) :: jday - real(kind=kind_phys), intent(in) :: xlon - real(kind=kind_phys), intent(out) :: soltim - real(kind=kind_phys) :: fjd,xhr,xmin,xsec,intime - integer :: nn - ! - fjd=jday-floor(jday) - fjd=jday - xhr=floor(fjd*24.0)-sign(12.0,fjd-0.5) - xmin=nint(fjd*1440.0)-(xhr+sign(12.0,fjd-0.5))*60 - xsec=0 - intime=xhr+xmin/60.0+xsec/3600.0+24.0 - soltim=mod(xlon/15.0+intime,24.0)*3600.0 -end subroutine solar_time_from_julian - -! -!*********************************************************************** -! -!>\ingroup gfs_nst_main_mod -!> This subroutine computes julian day and fraction from year, -!! month, day and time UTC. - subroutine compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) -!fpp$ noconcur r -!$$$ subprogram documentation block -! . . . . -! subprogram: compjd computes julian day and fraction -! prgmmr: kenneth campana org: w/nmc23 date: 89-07-07 -! -! abstract: computes julian day and fraction -! from year, month, day and time utc. -! -! program history log: -! 77-05-06 ray orzol,gfdl -! 98-05-15 iredell y2k compliance -! -! usage: call compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) -! input argument list: -! jyr - year (4 digits) -! jmnth - month -! jday - day -! jhr - hour -! jmn - minutes -! output argument list: -! jd - julian day. -! fjd - fraction of the julian day. -! -! subprograms called: -! iw3jdn compute julian day number -! -! attributes: -! language: fortran. -! -!$$$ - use machine , only :kind_phys - implicit none -! - integer jyr,jmnth,jday,jhr,jmn,jd - integer iw3jdn - real (kind=kind_phys) fjd - jd=iw3jdn(jyr,jmnth,jday) - if(jhr.lt.12) then - jd=jd-1 - fjd=0.5+jhr/24.+jmn/1440. - else - fjd=(jhr-12)/24.+jmn/1440. - endif - end subroutine compjd - -!>\ingroup gfs_nst_main_mod -!>This subroutine computes dtm (the mean of \f$dT(z)\f$). - subroutine get_dtzm_point(xt,xz,dt_cool,zc,z1,z2,dtm) -! ===================================================================== ! -! ! -! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! -! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool ! -! ! -! usage: ! -! ! -! call get_dtm12 ! -! ! -! inputs: ! -! (xt,xz,dt_cool,zc,z1,z2, ! -! outputs: ! -! dtm) ! -! ! -! program history log: ! -! ! -! 2015 -- xu li createad original code ! -! inputs: ! -! xt - real, heat content in dtl 1 ! -! xz - real, dtl thickness 1 ! -! dt_cool - real, sub-layer cooling amount 1 ! -! zc - sub-layer cooling thickness 1 ! -! z1 - lower bound of depth of sea temperature 1 ! -! z2 - upper bound of depth of sea temperature 1 ! -! outputs: ! -! dtm - mean of dT(z) (z1 to z2) 1 ! -! - use machine , only : kind_phys - - implicit none - - real (kind=kind_phys), intent(in) :: xt,xz,dt_cool,zc,z1,z2 - real (kind=kind_phys), intent(out) :: dtm -! Local variables - real (kind=kind_phys) :: dt_warm,dtw,dtc - -! -! get the mean warming in the range of z=z1 to z=z2 -! - dtw = 0.0 - if ( xt > 0.0 ) then - dt_warm = (xt+xt)/xz ! Tw(0) - if ( z1 < z2) then - if ( z2 < xz ) then - dtw = dt_warm*(1.0-(z1+z2)/(xz+xz)) - elseif ( z1 < xz .and. z2 >= xz ) then - dtw = 0.5*(1.0-z1/xz)*dt_warm*(xz-z1)/(z2-z1) - endif - elseif ( z1 == z2 ) then - if ( z1 < xz ) then - dtw = dt_warm*(1.0-z1/xz) - endif - endif - endif -! -! get the mean cooling in the range of z=z1 to z=z2 -! - dtc = 0.0 - if ( zc > 0.0 ) then - if ( z1 < z2) then - if ( z2 < zc ) then - dtc = dt_cool*(1.0-(z1+z2)/(zc+zc)) - elseif ( z1 < zc .and. z2 >= zc ) then - dtc = 0.5*(1.0-z1/zc)*dt_cool*(zc-z1)/(z2-z1) - endif - elseif ( z1 == z2 ) then - if ( z1 < zc ) then - dtc = dt_cool*(1.0-z1/zc) - endif - endif - endif - -! -! get the mean T departure from Tf in the range of z=z1 to z=z2 -! - dtm = dtw - dtc - - end subroutine get_dtzm_point - -!>\ingroup gfs_nst_main_mod - subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,nth,dtm) -!subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) -! ===================================================================== ! -! ! -! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! -! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool ! -! ! -! usage: ! -! ! -! call get_dtzm_2d ! -! ! -! inputs: ! -! (xt,xz,dt_cool,zc,z1,z2, ! -! outputs: ! -! dtm) ! -! ! -! program history log: ! -! ! -! 2015 -- xu li createad original code ! -! inputs: ! -! xt - real, heat content in dtl 1 ! -! xz - real, dtl thickness 1 ! -! dt_cool - real, sub-layer cooling amount 1 ! -! zc - sub-layer cooling thickness 1 ! -! wet - logical, flag for wet point (ocean or lake) 1 ! -! icy - logical, flag for ice point (ocean or lake) 1 ! -! nx - integer, dimension in x-direction (zonal) 1 ! -! ny - integer, dimension in y-direction (meridional) 1 ! -! z1 - lower bound of depth of sea temperature 1 ! -! z2 - upper bound of depth of sea temperature 1 ! -! nth - integer, num of openmp thread 1 ! -! outputs: ! -! dtm - mean of dT(z) (z1 to z2) 1 ! -! - use machine , only : kind_phys - - implicit none - - integer, intent(in) :: nx,ny, nth - real (kind=kind_phys), dimension(nx,ny), intent(in) :: xt,xz,dt_cool,zc - logical, dimension(nx,ny), intent(in) :: wet -! logical, dimension(nx,ny), intent(in) :: wet,icy - real (kind=kind_phys), intent(in) :: z1,z2 - real (kind=kind_phys), dimension(nx,ny), intent(out) :: dtm -! Local variables - integer :: i,j - real (kind=kind_phys) :: dt_warm, dtw, dtc, xzi - real (kind=kind_phys), parameter :: zero=0.0, half=0.5, one=1.0 - - -!$omp parallel do num_threads (nth) private(j,i,dtw,dtc,xzi) - do j = 1, ny - do i= 1, nx - - dtm(i,j) = zero ! initialize dtm - - if ( wet(i,j) ) then -! -! get the mean warming in the range of z=z1 to z=z2 -! - dtw = zero - if ( xt(i,j) > zero ) then - xzi = one / xz(i,j) - dt_warm = (xt(i,j)+xt(i,j)) * xzi ! Tw(0) - if (z1 < z2) then - if ( z2 < xz(i,j) ) then - dtw = dt_warm * (one-half*(z1+z2)*xzi) - elseif (z1 < xz(i,j) .and. z2 >= xz(i,j) ) then - dtw = half*(one-z1*xzi)*dt_warm*(xz(i,j)-z1)/(z2-z1) - endif - elseif (z1 == z2 ) then - if (z1 < xz(i,j) ) then - dtw = dt_warm * (one-z1*xzi) - endif - endif - endif -! -! get the mean cooling in the range of z=0 to z=zsea -! - dtc = zero - if ( zc(i,j) > zero ) then - if ( z1 < z2) then - if ( z2 < zc(i,j) ) then - dtc = dt_cool(i,j) * (one-(z1+z2)/(zc(i,j)+zc(i,j))) - elseif ( z1 < zc(i,j) .and. z2 >= zc(i,j) ) then - dtc = half*(one-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1) - endif - elseif ( z1 == z2 ) then - if ( z1 < zc(i,j) ) then - dtc = dt_cool(i,j) * (one-z1/zc(i,j)) - endif - endif - endif -! get the mean T departure from Tf in the range of z=z1 to z=z2 - dtm(i,j) = dtw - dtc - endif ! if ( wet(i,j)) then - enddo - enddo -! - - end subroutine get_dtzm_2d - -end module module_nst_water_prop diff --git a/physics/ozinterp.f90 b/physics/ozinterp.f90 deleted file mode 100644 index 5b3149d61..000000000 --- a/physics/ozinterp.f90 +++ /dev/null @@ -1,212 +0,0 @@ -!>\file ozinterp.f90 -!! This file contains ozone climatology interpolation subroutines. - -!>\ingroup mod_GFS_phys_time_vary -!! This module contains subroutines of reading and interpolating ozone coefficients. -module ozinterp - - implicit none - - private - - public :: read_o3data, setindxoz, ozinterpol - -contains - - SUBROUTINE read_o3data (ntoz, me, master) - use machine, only: kind_phys - use ozne_def -!--- in/out - integer, intent(in) :: ntoz - integer, intent(in) :: me - integer, intent(in) :: master -!--- locals - integer :: i, n, k - real(kind=4), allocatable, dimension(:) :: oz_lat4, oz_pres4 - real(kind=4), allocatable, dimension(:) :: oz_time4, tempin - real(kind=4) :: blatc4 - - if (ntoz <= 0) then ! Diagnostic ozone - rewind (kozc) - read (kozc,end=101) latsozc, levozc, timeozc, blatc4 - 101 if (levozc < 10 .or. levozc > 100) then - rewind (kozc) - levozc = 17 - latsozc = 18 - blatc = -85.0 - else - blatc = blatc4 - endif - latsozp = 2 - levozp = 1 - timeoz = 1 - oz_coeff = 0 - dphiozc = -(blatc+blatc)/(latsozc-1) - return - endif - - open(unit=kozpl,file='global_o3prdlos.f77', form='unformatted', convert='big_endian') - -!--- read in indices -!--- - read (kozpl) oz_coeff, latsozp, levozp, timeoz - if (me == master) then - write(*,*) 'Reading in o3data from global_o3prdlos.f77 ' - write(*,*) ' oz_coeff = ', oz_coeff - write(*,*) ' latsozp = ', latsozp - write(*,*) ' levozp = ', levozp - write(*,*) ' timeoz = ', timeoz - endif - -!--- read in data -!--- oz_lat - latitude of data (-90 to 90) -!--- oz_pres - vertical pressure level (mb) -!--- oz_time - time coordinate (days) -!--- - allocate (oz_lat(latsozp), oz_pres(levozp),oz_time(timeoz+1)) - allocate (oz_lat4(latsozp), oz_pres4(levozp),oz_time4(timeoz+1)) - rewind (kozpl) - read (kozpl) oz_coeff, latsozp, levozp, timeoz, oz_lat4, oz_pres4, oz_time4 - oz_pres(:) = oz_pres4(:) -!--- convert pressure levels from mb to ln(Pa) - oz_pres(:) = log(100.0*oz_pres(:)) - oz_lat(:) = oz_lat4(:) - oz_time(:) = oz_time4(:) - deallocate (oz_lat4, oz_pres4, oz_time4) - -!--- read in ozplin which is in order of (lattitudes, ozone levels, coeff number, time) -!--- assume latitudes is on a uniform gaussian grid -!--- - allocate (tempin(latsozp)) - allocate (ozplin(latsozp,levozp,oz_coeff,timeoz)) - DO i=1,timeoz - DO n=1,oz_coeff - DO k=1,levozp - READ(kozpl) tempin - ozplin(:,k,n,i) = tempin(:) - ENDDO - ENDDO - ENDDO - deallocate (tempin) - - close(kozpl) - - END SUBROUTINE read_o3data -! -!********************************************************************** -! - SUBROUTINE setindxoz(npts,dlat,jindx1,jindx2,ddy) -! - USE MACHINE, ONLY: kind_phys - USE OZNE_DEF, ONLY: jo3 => latsozp, oz_lat -! - implicit none -! - integer npts, JINDX1(npts),JINDX2(npts) - real(kind=kind_phys) dlat(npts),DDY(npts) -! - integer i,j,lat -! - DO J=1,npts - jindx2(j) = jo3 + 1 - do i=1,jo3 - if (dlat(j) < oz_lat(i)) then - jindx2(j) = i - exit - endif - enddo - jindx1(j) = max(jindx2(j)-1,1) - jindx2(j) = min(jindx2(j),jo3) - if (jindx2(j) .ne. jindx1(j)) then - DDY(j) = (dlat(j) - oz_lat(jindx1(j))) & - / (oz_lat(jindx2(j)) - oz_lat(jindx1(j))) - else - ddy(j) = 1.0 - endif -! print *,' j=',j,' dlat=',dlat(j),' jindx12=',jindx1(j), & -! jjindx2(j),' oz_lat=',oz_lat(jindx1(j)), & -! oz_lat(jindx2(j)),' ddy=',ddy(j) - ENDDO - - RETURN - END SUBROUTINE setindxoz -! -!********************************************************************** -! - SUBROUTINE ozinterpol(me,npts,IDATE,FHOUR,jindx1,jindx2,ozplout,ddy) -! - USE MACHINE, ONLY : kind_phys - USE OZNE_DEF - implicit none - integer iday,j,j1,j2,l,npts,nc,n1,n2 - real(kind=kind_phys) fhour,tem, tx1, tx2 -! - - integer JINDX1(npts), JINDX2(npts) - integer me, idate(4), IDAT(8),JDAT(8) -! - real(kind=kind_phys) DDY(npts) - real(kind=kind_phys) ozplout(npts,levozp,oz_coeff) - real(kind=kind_phys) rjday - integer jdow, jdoy, jday - real(8) rinc(5) - real(4) rinc4(5) - integer w3kindreal,w3kindint -! - IDAT=0 - IDAT(1)=IDATE(4) - IDAT(2)=IDATE(2) - IDAT(3)=IDATE(3) - IDAT(5)=IDATE(1) - RINC=0. - RINC(2)=FHOUR - call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - rinc4=rinc - CALL W3MOVDAT(RINC4,IDAT,JDAT) - else - CALL W3MOVDAT(RINC,IDAT,JDAT) - endif -! - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jdat,jdow,jdoy,jday) - rjday = jdoy + jdat(5) / 24. - IF (RJDAY < oz_time(1)) RJDAY = RJDAY + 365. -! - n2 = timeoz + 1 - do j=2,timeoz - if (rjday < oz_time(j)) then - n2 = j - exit - endif - enddo - n1 = n2 - 1 -! -! if (me == 0) print *,' n1=',n1,' n2=',n2,' rjday=',rjday -! &,'oz_time=',oz_time(n1),oz_time(n2) -! - - tx1 = (oz_time(n2) - rjday) / (oz_time(n2) - oz_time(n1)) - tx2 = 1.0 - tx1 - - if (n2 > timeoz) n2 = n2 - timeoz -! - do nc=1,oz_coeff - DO L=1,levozp - DO J=1,npts - J1 = JINDX1(J) - J2 = JINDX2(J) - TEM = 1.0 - DDY(J) - ozplout(j,L,nc) = & - tx1*(TEM*ozplin(J1,L,nc,n1)+DDY(J)*ozplin(J2,L,nc,n1)) & - + tx2*(TEM*ozplin(J1,L,nc,n2)+DDY(J)*ozplin(J2,L,nc,n2)) - ENDDO - ENDDO - enddo -! - RETURN - END SUBROUTINE ozinterpol - -end module ozinterp diff --git a/physics/ozne_def.f b/physics/ozne_def.f deleted file mode 100644 index 8f3af6240..000000000 --- a/physics/ozne_def.f +++ /dev/null @@ -1,24 +0,0 @@ -!>\file ozne_def.f -!! This file contains the ozone array definition used in ozone physics. - -!>\ingroup mod_GFS_phys_time_vary -!! This module defines arrays in Ozone scheme. - module ozne_def - -!> \section arg_table_ozne_def -!! \htmlinclude ozne_def.html -!! - - use machine , only : kind_phys - implicit none - - integer, parameter :: kozpl=28, kozc=48 - - integer latsozp, levozp, timeoz, latsozc, levozc, timeozc - &, oz_coeff - real (kind=kind_phys) blatc, dphiozc - real (kind=kind_phys), allocatable :: oz_lat(:), oz_pres(:) - &, oz_time(:) - real (kind=kind_phys), allocatable :: ozplin(:,:,:,:) - - end module ozne_def diff --git a/physics/ozne_def.meta b/physics/ozne_def.meta deleted file mode 100644 index 3cad9c14d..000000000 --- a/physics/ozne_def.meta +++ /dev/null @@ -1,29 +0,0 @@ -[ccpp-table-properties] - name = ozne_def - type = module - dependencies = machine.F - -[ccpp-arg-table] - name = ozne_def - type = module - -[levozp] - standard_name = vertical_dimension_of_ozone_forcing_data - long_name = number of vertical layers in ozone forcing data - units = count - dimensions = () - type = integer -[oz_coeff] - standard_name = number_of_coefficients_in_ozone_forcing_data - long_name = number of coefficients in ozone forcing data - units = index - dimensions = () - type = integer -[oz_pres] - standard_name = natural_log_of_ozone_forcing_data_pressure_levels - long_name = natural log of ozone forcing data pressure levels in Pa - units = 1 - dimensions = (vertical_dimension_of_ozone_forcing_data) - type = real - kind = kind_phys - active = (index_of_ozone_mixing_ratio_in_tracer_concentration_array>0) diff --git a/physics/ozphys.f b/physics/ozphys.f deleted file mode 100644 index 18a9ae46f..000000000 --- a/physics/ozphys.f +++ /dev/null @@ -1,211 +0,0 @@ -!> \file ozphys.f -!! This file is ozone sources and sinks (previous version). - - -!> This module contains the CCPP-compliant Ozone photochemistry scheme. - module ozphys - - contains - -! \brief Brief description of the subroutine -! -!> \section arg_table_ozphys_init Argument Table -!! \htmlinclude ozphys_init.html -!! - subroutine ozphys_init(oz_phys, errmsg, errflg) - - implicit none - logical, intent(in) :: oz_phys - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not.oz_phys) then - write (errmsg,'(*(a))') 'Logic error: oz_phys == .false.' - errflg = 1 - return - endif - - end subroutine ozphys_init - -!>\defgroup GFS_ozphys GFS ozphys Main -!! \brief The operational GFS currently parameterizes ozone production and -!! destruction based on monthly mean coefficients (\c global_o3prdlos.f77) provided by Naval -!! Research Laboratory through CHEM2D chemistry model -!! (McCormack et al. (2006) \cite mccormack_et_al_2006). -!! \section arg_table_ozphys_run Argument Table -!! \htmlinclude ozphys_run.html -!! -!> \section genal_ozphys GFS ozphys_run General Algorithm -!> @{ - subroutine ozphys_run ( & - & im, levs, ko3, dt, oz, tin, po3, & - & prsl, prdout, oz_coeff, delp, ldiag3d, & - & ntoz, dtend, dtidx, index_of_process_prod_loss, & - & index_of_process_ozmix, index_of_process_temp, & - & index_of_process_overhead_ozone, con_g, me, errmsg, errflg) -! -! this code assumes that both prsl and po3 are from bottom to top -! as are all other variables -! - use machine , only : kind_phys - implicit none -! - ! Interface variables - integer, intent(in) :: im, levs, ko3, oz_coeff, me - real(kind=kind_phys), intent(inout) :: oz(:,:) - real(kind=kind_phys), intent(inout) :: dtend(:,:,:) - integer, intent(in) :: dtidx(:,:), ntoz, & - & index_of_process_prod_loss, index_of_process_ozmix, & - & index_of_process_temp, index_of_process_overhead_ozone - real(kind=kind_phys), intent(in) :: & - & dt, po3(:), prdout(:,:,:), & - & prsl(:,:), tin(:,:), delp(:,:), & - & con_g - real :: gravi - logical, intent(in) :: ldiag3d - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! - ! Local variables - integer k,kmax,kmin,l,i,j, idtend(4) - logical flg(im) - real(kind=kind_phys) pmax, pmin, tem, temp - real(kind=kind_phys) wk1(im), wk2(im), wk3(im), prod(im,oz_coeff), - & ozib(im), colo3(im,levs+1), ozi(im,levs) -! - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -! -! save input oz in ozi - ozi = oz - gravi=1.0/con_g - - - if(ldiag3d) then - idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1 - idtend(2) = dtidx(100+ntoz,index_of_process_ozmix) ! was ozp2 - idtend(3) = dtidx(100+ntoz,index_of_process_temp) ! was ozp3 - idtend(4) = dtidx(100+ntoz,index_of_process_overhead_ozone) ! was ozp4 - else - idtend=0 - endif - -! -!> - Calculate vertical integrated column ozone values. - if (oz_coeff > 2) then - colo3(:,levs+1) = 0.0 - do l=levs,1,-1 - do i=1,im - colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l) * gravi - enddo - enddo - endif -! -!> - Apply vertically linear interpolation to the ozone coefficients. - do l=1,levs - pmin = 1.0e10 - pmax = -1.0e10 -! - do i=1,im - wk1(i) = log(prsl(i,l)) - pmin = min(wk1(i), pmin) - pmax = max(wk1(i), pmax) - prod(i,:) = 0.0 - enddo - kmax = 1 - kmin = 1 - do k=1,ko3-1 - if (pmin < po3(k)) kmax = k - if (pmax < po3(k)) kmin = k - enddo -! - do k=kmin,kmax - temp = 1.0 / (po3(k) - po3(k+1)) - do i=1,im - flg(i) = .false. - if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then - flg(i) = .true. - wk2(i) = (wk1(i) - po3(k+1)) * temp - wk3(i) = 1.0 - wk2(i) - endif - enddo - do j=1,oz_coeff - do i=1,im - if (flg(i)) then - prod(i,j) = wk2(i) * prdout(i,k,j) - & + wk3(i) * prdout(i,k+1,j) - endif - enddo - enddo - enddo -! - do j=1,oz_coeff - do i=1,im - if (wk1(i) < po3(ko3)) then - prod(i,j) = prdout(i,ko3,j) - endif - if (wk1(i) >= po3(1)) then - prod(i,j) = prdout(i,1,j) - endif - enddo - enddo - - if (oz_coeff == 2) then - do i=1,im - ozib(i) = ozi(i,l) ! no filling - oz(i,l) = (ozib(i) + prod(i,1)*dt) / (1.0 + prod(i,2)*dt) - enddo -! - if(idtend(1)>=1) then - dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1 - & prod(:,1)*dt - endif - if(idtend(2)>=1) then - dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2 - & (oz(:,l) - ozib(:)) - endif - endif -!> - Calculate the 4 terms of prognostic ozone change during time \a dt: -!! - ozp1(:,:) - Ozone production from production/loss ratio -!! - ozp2(:,:) - Ozone production from ozone mixing ratio -!! - ozp3(:,:) - Ozone production from temperature term at model layers -!! - ozp4(:,:) - Ozone production from column ozone term at model layers - if (oz_coeff == 4) then - do i=1,im - ozib(i) = ozi(i,l) ! no filling - tem = prod(i,1) + prod(i,3)*tin(i,l) - & + prod(i,4)*colo3(i,l+1) -! if (me .eq. 0) print *,'ozphys tem=',tem,' prod=',prod(i,:) -! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1) - oz(i,l) = (ozib(i) + tem*dt) / (1.0 + prod(i,2)*dt) - enddo - if(idtend(1)>=1) then - dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1 - & prod(:,1)*dt - endif - if(idtend(2)>=1) then - dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2 - & (oz(:,l)-ozib(:)) - endif - if(idtend(3)>=1) then - dtend(:,l,idtend(3)) = dtend(:,l,idtend(3)) + ! was ozp3 - & prod(:,3)*tin(:,l)*dt - endif - if(idtend(4)>=1) then - dtend(:,l,idtend(4)) = dtend(:,l,idtend(4)) + ! was ozp4 - & prod(:,4)*colo3(:,l+1)*dt - endif - endif - enddo ! vertical loop -! - return - end subroutine ozphys_run -!> @} - - end module ozphys diff --git a/physics/ozphys.meta b/physics/ozphys.meta deleted file mode 100644 index 485e2a491..000000000 --- a/physics/ozphys.meta +++ /dev/null @@ -1,208 +0,0 @@ -[ccpp-table-properties] - name = ozphys - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = ozphys_init - type = scheme -[oz_phys] - standard_name = flag_for_nrl_2006_ozone_scheme - long_name = flag for old (2006) ozone physics - units = flag - dimensions = () - type = logical - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = ozphys_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[ko3] - standard_name = vertical_dimension_of_ozone_forcing_data - long_name = number of vertical layers in ozone forcing data - units = count - dimensions = () - type = integer - intent = in -[dt] - standard_name = timestep_for_physics - long_name = physics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[oz] - standard_name = ozone_concentration_of_new_state - long_name = ozone concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[tin] - standard_name = air_temperature_of_new_state - long_name = updated air temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[po3] - standard_name = natural_log_of_ozone_forcing_data_pressure_levels - long_name = natural log of ozone forcing data pressure levels - units = 1 - dimensions = (vertical_dimension_of_ozone_forcing_data) - type = real - kind = kind_phys - intent = in -[prsl] - standard_name = air_pressure - long_name = mid-layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[prdout] - standard_name = ozone_forcing - long_name = ozone forcing coefficients - units = mixed - dimensions = (horizontal_loop_extent,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) - type = real - kind = kind_phys - intent = in -[oz_coeff] - standard_name = number_of_coefficients_in_ozone_forcing_data - long_name = number of coefficients in ozone forcing data - units = index - dimensions = () - type = integer - intent = in -[delp] - standard_name = air_pressure_difference_between_midlayers - long_name = difference between mid-layer pressures - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for calculating 3-D diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - active = (flag_for_diagnostics_3D) - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in -[index_of_process_prod_loss] - standard_name = index_of_production_and_loss_process_in_cumulative_change_index - long_name = index of production and loss effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_ozmix] - standard_name = index_of_ozone_mixing_ratio_process_in_cumulative_change_index - long_name = index of ozone mixing ratio effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_temp] - standard_name = index_of_temperature_process_in_cumulative_change_index - long_name = index of temperature effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_overhead_ozone] - standard_name = index_of_overhead_process_in_cumulative_change_index - long_name = index of overhead ozone effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[me] - standard_name = mpi_rank - long_name = rank of the current MPI task - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/ozphys_2015.f b/physics/ozphys_2015.f deleted file mode 100644 index 85c79f733..000000000 --- a/physics/ozphys_2015.f +++ /dev/null @@ -1,190 +0,0 @@ -!> \file ozphys_2015.f -!! This file is ozone sources and sinks. - - - module ozphys_2015 - - contains - -!>\defgroup GFS_ozphys_2015 GFS Ozone Photochemistry (2015) Module -!! This module contains the CCPP-compliant Ozone 2015 photochemistry scheme. -!> @{ -!> \section arg_table_ozphys_2015_init Argument Table -!! \htmlinclude ozphys_2015_init.html -!! - subroutine ozphys_2015_init(oz_phys_2015, errmsg, errflg) - - implicit none - logical, intent(in) :: oz_phys_2015 - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not.oz_phys_2015) then - write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.' - errflg = 1 - return - endif - - end subroutine ozphys_2015_init - -!> The operational GFS currently parameterizes ozone production and -!! destruction based on monthly mean coefficients ( -!! \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by Naval -!! Research Laboratory through CHEM2D chemistry model -!! (McCormack et al. (2006) \cite mccormack_et_al_2006). -!! \section arg_table_ozphys_2015_run Argument Table -!! \htmlinclude ozphys_2015_run.html -!! -!> \section genal_ozphys_2015 GFS ozphys_2015_run General Algorithm -!> - This code assumes that both prsl and po3 are from bottom to top -!! as are all other variables. -!> - This code is specifically for NRL parameterization and -!! climatological T and O3 are in location 5 and 6 of prdout array -!!\author June 2015 - Shrinivas Moorthi - subroutine ozphys_2015_run ( & - & im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_coeff, & - & delp, ldiag3d, dtend, dtidx, ntoz, index_of_process_prod_loss& - & , index_of_process_ozmix, index_of_process_temp, & - & index_of_process_overhead_ozone, con_g, me, errmsg, errflg) -! -! - use machine , only : kind_phys - implicit none -! - real(kind=kind_phys),intent(in) :: con_g - real :: gravi - integer, intent(in) :: im, levs, ko3, pl_coeff,me - real(kind=kind_phys), intent(in) :: po3(:), & - & prsl(:,:), tin(:,:), & - & delp(:,:), & - & prdout(:,:,:), dt - real(kind=kind_phys), intent(inout) :: dtend(:,:,:) - integer, intent(in) :: dtidx(:,:), ntoz, & - & index_of_process_prod_loss, index_of_process_ozmix, & - & index_of_process_temp, index_of_process_overhead_ozone - real(kind=kind_phys), intent(inout) :: oz(im,levs) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer k,kmax,kmin,l,i,j, idtend(4) - logical ldiag3d, flg(im), qdiag3d - real(kind=kind_phys) pmax, pmin, tem, temp - real(kind=kind_phys) wk1(im), wk2(im), wk3(im),prod(im,pl_coeff), & - & ozib(im), colo3(im,levs+1), coloz(im,levs+1),& - & ozi(im,levs) -! - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if(ldiag3d) then - idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1 - idtend(2) = dtidx(100+ntoz,index_of_process_ozmix) ! was ozp2 - idtend(3) = dtidx(100+ntoz,index_of_process_temp) ! was ozp3 - idtend(4) = dtidx(100+ntoz,index_of_process_overhead_ozone) ! was ozp4 - else - idtend=0 - endif - -!ccpp: save input oz in ozi - ozi = oz - gravi=1.0/con_g - - colo3(:,levs+1) = 0.0 - coloz(:,levs+1) = 0.0 -! - do l=levs,1,-1 - pmin = 1.0e10 - pmax = -1.0e10 -! - do i=1,im - wk1(i) = log(prsl(i,l)) - pmin = min(wk1(i), pmin) - pmax = max(wk1(i), pmax) - prod(i,:) = 0.0 - enddo - kmax = 1 - kmin = 1 - do k=1,ko3-1 - if (pmin < po3(k)) kmax = k - if (pmax < po3(k)) kmin = k - enddo -! - do k=kmin,kmax - temp = 1.0 / (po3(k) - po3(k+1)) - do i=1,im - flg(i) = .false. - if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then - flg(i) = .true. - wk2(i) = (wk1(i) - po3(k+1)) * temp - wk3(i) = 1.0 - wk2(i) - endif - enddo - do j=1,pl_coeff - do i=1,im - if (flg(i)) then - prod(i,j) = wk2(i) * prdout(i,k,j) - & + wk3(i) * prdout(i,k+1,j) - endif - enddo - enddo - enddo -! - do j=1,pl_coeff - do i=1,im - if (wk1(i) < po3(ko3)) then - prod(i,j) = prdout(i,ko3,j) - endif - if (wk1(i) >= po3(1)) then - prod(i,j) = prdout(i,1,j) - endif - enddo - enddo - do i=1,im - colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l)*gravi - coloz(i,l) = coloz(i,l+1) + prod(i,6) * delp(i,l)*gravi - prod(i,2) = min(prod(i,2), 0.0) - enddo -! write(1000+me,*) ' colo3=',colo3(1,l),' coloz=',coloz(1,l) -! &,' l=',l - do i=1,im - ozib(i) = ozi(i,l) ! no filling - tem = prod(i,1) - prod(i,2) * prod(i,6) - & + prod(i,3) * (tin(i,l) - prod(i,5)) - & + prod(i,4) * (colo3(i,l)-coloz(i,l)) - -! if (me .eq. 0) print *,'ozphys_2015 tem=',tem,' prod=',prod(i,:) -! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1) - -!ccpp ozo(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt) - oz(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt) - enddo - if(idtend(1)>=1) then - dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1 - & (prod(:,1)-prod(:,2)*prod(:,6))*dt - endif - if(idtend(2)>=1) then - dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2 - & (oz(:,l) - ozib(:)) - endif - if(idtend(3)>=1) then - dtend(:,l,idtend(3)) = dtend(:,l,idtend(3)) + ! was ozp3 - & prod(:,3)*(tin(:,l)-prod(:,5))*dt - endif - if(idtend(4)>=1) then - dtend(:,l,idtend(4)) = dtend(:,l,idtend(4)) + ! was ozp4 - & prod(:,4) * (colo3(:,l)-coloz(:,l))*dt - endif - enddo ! vertical loop -! - return - end subroutine ozphys_2015_run - -!> @} - - end module ozphys_2015 diff --git a/physics/h2o_def.f b/physics/photochem/h2o_def.f similarity index 100% rename from physics/h2o_def.f rename to physics/photochem/h2o_def.f diff --git a/physics/h2o_def.meta b/physics/photochem/h2o_def.meta similarity index 95% rename from physics/h2o_def.meta rename to physics/photochem/h2o_def.meta index 17f0f8779..92e1d61bd 100644 --- a/physics/h2o_def.meta +++ b/physics/photochem/h2o_def.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = h2o_def type = module - dependencies = machine.F + dependencies = ../hooks/machine.F [ccpp-arg-table] name = h2o_def diff --git a/physics/h2ointerp.f90 b/physics/photochem/h2ointerp.f90 similarity index 100% rename from physics/h2ointerp.f90 rename to physics/photochem/h2ointerp.f90 diff --git a/physics/h2ophys.f b/physics/photochem/h2ophys.f similarity index 100% rename from physics/h2ophys.f rename to physics/photochem/h2ophys.f diff --git a/physics/h2ophys.meta b/physics/photochem/h2ophys.meta similarity index 98% rename from physics/h2ophys.meta rename to physics/photochem/h2ophys.meta index afe50bda1..9e9b03647 100644 --- a/physics/h2ophys.meta +++ b/physics/photochem/h2ophys.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = h2ophys type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/photochem/module_ozphys.F90 b/physics/photochem/module_ozphys.F90 new file mode 100644 index 000000000..f824736b1 --- /dev/null +++ b/physics/photochem/module_ozphys.F90 @@ -0,0 +1,628 @@ +! ######################################################################################### +!> \section arg_table_module_ozphys Argument table +!! \htmlinclude module_ozphys.html +!! +! +!> The operational GFS currently parameterizes ozone production and destruction based on +!! monthly mean coefficients (\c global_o3prdlos.f77) provided by Naval Research Laboratory +!! through CHEM2D chemistry model (McCormack et al. (2006) \cite mccormack_et_al_2006). +!! +!! There are two implementations of this parameterization within this module. +!! run_o3prog_2006 - Relies on either two/four mean monthly coefficients. This is explained +!! in (https://doi.org/10.5194/acp-6-4943-2006. See Eq.(4)). +!! run_o3prog_2015 - Relies on six mean monthly coefficients, specifically for NRL +!! parameterization and climatological T and O3 are in location 5 and 6 of +!! the coefficient array. +!! +!! Both of these rely on the scheme being setup correctly by invoking the load(), setup(), +!! and update() procedures prior to calling the run() procedure. +!! +!! load_o3prog() - Read in data and load into type ty_ozphys (called once from host) +!! setup_o3prog() - Create spatial interpolation indices (called once, after model grid is known) +!! update_o3prog() - Update ozone concentration in time (call in physics loop, before run()) +!! *CAVEAT* Since the radiation is often run at a lower temporal resolution +!! than the rest of the physics, update_o3prog() needs to be +!! called before the radiation, which is called before the physics. +!! For example, within the physics loop: +!! update_o3prog() -> radiation() -> run_o3prog() -> physics.... +!! +!! Additionally, there is the functionality to not use interactive ozone, instead reverting +!! to ozone climatology. In this case, analagous to when using prognostic ozone, there are +!! update() and run() procedures that need to be called before the radiation. +!! For example, within the physics loop: +!! update_o3clim() -> run_o3clim() -> radiation() -> physics... +!! +!!\author June 2015 - Shrinivas Moorthi +!!\modified Sep 2023 - Dustin Swales +!! +! ######################################################################################### +module module_ozphys + use machine, only : kind_phys + use funcphys, only : fpkapx + implicit none + + public ty_ozphys + +! ######################################################################################### +!> \section arg_table_ty_ozphys Argument Table +!! \htmlinclude ty_ozphys.html +!! +!> Derived type containing data and procedures needed by ozone photochemistry parameterization +!! *Note* All data field are ordered from surface-to-toa. +!! +! ######################################################################################### + type ty_ozphys + ! Prognostic ozone. + integer :: nlat !< Number of latitudes. + integer :: nlev !< Number of vertical layers. + integer :: ntime !< Number of times. + integer :: ncf !< Number of coefficients. + real(kind_phys), allocatable :: lat(:) !< Latitude. + real(kind_phys), allocatable :: pres(:) !< Pressure levels. + real(kind_phys), allocatable :: po3(:) !< Natural log pressure of levels. + real(kind_phys), allocatable :: time(:) !< Time. + real(kind_phys), allocatable :: data(:,:,:,:) !< Ozone forcing data (raw) + ! Climotological ozone. + integer :: nlatc !< Number of latitudes. + integer :: nlevc !< Number of vertical layers. + integer :: ntimec !< Number of times. + real(kind_phys) :: blatc !< Parameter for ozone climotology + real(kind_phys) :: dphiozc !< Parameter for ozone climotology + real(kind_phys), allocatable :: pkstr(:) !< + real(kind_phys), allocatable :: pstr(:) !< + real(kind_phys), allocatable :: datac(:,:,:) !< Ozone climotological data + integer :: k1oz !< Lower interpolation index in datac(dim=3), time dim + integer :: k2oz !< Upper interpolation index in datac(dim=3), time dim + real(kind_phys) :: facoz !< Parameter for ozone climotology + contains + procedure, public :: load_o3prog + procedure, public :: setup_o3prog + procedure, public :: update_o3prog + procedure, public :: run_o3prog_2015 + procedure, public :: run_o3prog_2006 + ! + procedure, public :: load_o3clim + procedure, public :: update_o3clim + procedure, public :: run_o3clim + end type ty_ozphys + +contains + ! ######################################################################################### + ! Procedure (type-bound) for loading data for prognostic ozone. + ! ######################################################################################### + function load_o3prog(this, file, fileID) result (err_message) + class(ty_ozphys), intent(inout) :: this + integer, intent(in) :: fileID + character(len=*), intent(in) :: file + character(len=128) :: err_message + integer :: i1, i2, i3 + real(kind=4), dimension(:), allocatable :: lat4, pres4, time4, tempin + real(kind=4) :: blatc4 + + ! Get dimensions from data file + open(unit=fileID,file=trim(file), form='unformatted', convert='big_endian') + read (fileID) this%ncf, this%nlat, this%nlev, this%ntime + rewind(fileID) + + allocate (this%lat(this%nlat)) + allocate (this%pres(this%nlev)) + allocate (this%po3(this%nlev)) + allocate (this%time(this%ntime+1)) + allocate (this%data(this%nlat,this%nlev,this%ncf,this%ntime)) + + allocate(lat4(this%nlat), pres4(this%nlev), time4(this%ntime+1)) + read (fileID) this%ncf, this%nlat, this%nlev, this%ntime, lat4, pres4, time4 + + ! Store + this%pres(:) = pres4(:) + this%po3(:) = log(100.0*this%pres(:)) ! from mb to ln(Pa) + this%lat(:) = lat4(:) + this%time(:) = time4(:) + deallocate(lat4, pres4, time4) + + allocate(tempin(this%nlat)) + do i1=1,this%ntime + do i2=1,this%ncf + do i3=1,this%nlev + read(fileID) tempin + this%data(:,i3,i2,i1) = tempin(:) + enddo + enddo + enddo + deallocate(tempin) + close(fileID) + + end function load_o3prog + + ! ######################################################################################### + ! Procedure (type-bound) for setting up interpolation indices between data-grid and + ! model-grid. + ! Called once during initialization + ! ######################################################################################### + subroutine setup_o3prog(this, lat, idx1, idx2, idxh) + class(ty_ozphys), intent(in) :: this + real(kind_phys), intent(in) :: lat(:) + integer, intent(out) :: idx1(:), idx2(:) + real(kind_phys), intent(out) :: idxh(:) + integer :: i,j + + do j=1,size(lat) + idx2(j) = this%nlat + 1 + do i=1,this%nlat + if (lat(j) < this%lat(i)) then + idx2(j) = i + exit + endif + enddo + idx1(j) = max(idx2(j)-1,1) + idx2(j) = min(idx2(j),this%nlat) + if (idx2(j) .ne. idx1(j)) then + idxh(j) = (lat(j) - this%lat(idx1(j))) / (this%lat(idx2(j)) - this%lat(idx1(j))) + else + idxh(j) = 1.0 + endif + enddo + + end subroutine setup_o3prog + + ! ######################################################################################### + ! Procedure (type-bound) for updating data used in prognostic ozone scheme. + ! ######################################################################################### + subroutine update_o3prog(this, idx1, idx2, idxh, rjday, idxt1, idxt2, ozpl) + class(ty_ozphys), intent(in) :: this + integer, intent(in) :: idx1(:), idx2(:) + real(kind_phys), intent(in) :: idxh(:) + real(kind_phys), intent(in) :: rjday + integer, intent(in) :: idxt1, idxt2 + real(kind_phys), intent(out) :: ozpl(:,:,:) + integer :: nc, l, j, j1, j2 + real(kind_phys) :: tem, tx1, tx2 + + tx1 = (this%time(idxt2) - rjday) / (this%time(idxt2) - this%time(idxt1)) + tx2 = 1.0 - tx1 + + do nc=1,this%ncf + do l=1,this%nlev + do j=1,size(ozpl(:,1,1)) + j1 = idx1(j) + j2 = idx2(j) + tem = 1.0 - idxh(j) + ozpl(j,l,nc) = tx1*(tem*this%data(j1,l,nc,idxt1)+idxh(j)*this%data(j2,l,nc,idxt1)) & + + tx2*(tem*this%data(j1,l,nc,idxt2)+idxh(j)*this%data(j2,l,nc,idxt2)) + enddo + enddo + enddo + + end subroutine update_o3prog + + ! ######################################################################################### + ! Procedure (type-bound) for NRL prognostic ozone (2015). + ! ######################################################################################### + subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, & + do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) + class(ty_ozphys), intent(in) :: this + real(kind_phys), intent(in) :: & + con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2) + real(kind_phys), intent(in) :: & + dt ! Model timestep (sec) + real(kind_phys), intent(in), dimension(:,:) :: & + p, & ! Model Pressure (Pa) + t, & ! Model temperature (K) + dp ! Model layer thickness (Pa) + real(kind_phys), intent(in), dimension(:,:,:) :: & + ozpl ! Ozone forcing data + real(kind_phys), intent(inout), dimension(:,:) :: & + oz ! Ozone concentration updated by physics + real(kind_phys), intent(inout), dimension(:,:), pointer, optional :: & + do3_dt_prd, & ! Physics tendency: production and loss effect + do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect + do3_dt_temp, & ! Physics tendency: temperature effect + do3_dt_ohoz ! Physics tendency: overhead ozone effect + + integer :: k, kmax, kmin, iLev, iCol, nCol, nLev, iCf + logical, dimension(size(p,1)) :: flg + real(kind_phys) :: pmax, pmin, tem, temp + real(kind_phys), dimension(size(p,1)) :: wk1, wk2, wk3, ozib + real(kind_phys), dimension(size(p,1),this%ncf) :: prod + real(kind_phys), dimension(size(p,1),size(p,2)) :: ozi + real(kind_phys), dimension(size(p,1),size(p,2)+1) :: colo3, coloz + + ! Dimensions + nCol = size(p,1) + nLev = size(p,2) + + ! Temporaries + ozi = oz + + colo3(:,nLev+1) = 0.0 + coloz(:,nLev+1) = 0.0 + + do iLev=nLev,1,-1 + pmin = 1.0e10 + pmax = -1.0e10 + + do iCol=1,nCol + wk1(iCol) = log(p(iCol,iLev)) + pmin = min(wk1(iCol), pmin) + pmax = max(wk1(iCol), pmax) + prod(iCol,:) = 0._kind_phys + enddo + kmax = 1 + kmin = 1 + do k=1,this%nlev-1 + if (pmin < this%po3(k)) kmax = k + if (pmax < this%po3(k)) kmin = k + enddo + ! + do k=kmin,kmax + temp = 1.0 / (this%po3(k) - this%po3(k+1)) + do iCol=1,nCol + flg(iCol) = .false. + if (wk1(iCol) < this%po3(k) .and. wk1(iCol) >= this%po3(k+1)) then + flg(iCol) = .true. + wk2(iCol) = (wk1(iCol) - this%po3(k+1)) * temp + wk3(iCol) = 1.0 - wk2(iCol) + endif + enddo + do iCf=1,this%ncf + do iCol=1,nCol + if (flg(iCol)) then + prod(iCol,iCf) = wk2(iCol) * ozpl(iCol,k,iCf) + wk3(iCol) * ozpl(iCol,k+1,iCf) + endif + enddo + enddo + enddo + + do iCf=1,this%ncf + do iCol=1,nCol + if (wk1(iCol) < this%po3(this%nlev)) then + prod(iCol,iCf) = ozpl(iCol,this%nlev,iCf) + endif + if (wk1(iCol) >= this%po3(1)) then + prod(iCol,iCf) = ozpl(iCol,1,iCf) + endif + enddo + enddo + do iCol=1,nCol + colo3(iCol,iLev) = colo3(iCol,iLev+1) + ozi(iCol,iLev) * dp(iCol,iLev)*con_1ovg + coloz(iCol,iLev) = coloz(iCol,iLev+1) + prod(iCol,6) * dp(iCol,iLev)*con_1ovg + prod(iCol,2) = min(prod(iCol,2), 0.0) + enddo + do iCol=1,nCol + ozib(iCol) = ozi(iCol,iLev) + tem = prod(iCol,1) - prod(iCol,2) * prod(iCol,6) & + + prod(iCol,3) * (t(iCol,iLev) - prod(iCol,5)) & + + prod(iCol,4) * (colo3(iCol,iLev)-coloz(iCol,iLev)) + oz(iCol,iLev) = (ozib(iCol) + tem*dt) / (1.0 - prod(iCol,2)*dt) + enddo + + ! Diagnostics (optional) + if (associated(do3_dt_prd)) do3_dt_prd(:,iLev) = (prod(:,1)-prod(:,2)*prod(:,6))*dt + if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:)) + if (associated(do3_dt_temp)) do3_dt_temp(:,iLev) = prod(:,3)*(t(:,iLev)-prod(:,5))*dt + if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,iLev) = prod(:,4) * (colo3(:,iLev)-coloz(:,iLev))*dt + enddo + + return + end subroutine run_o3prog_2015 + + ! ######################################################################################### + ! Procedure (type-bound) for NRL prognostic ozone (2006). + ! ######################################################################################### + subroutine run_o3prog_2006(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, & + do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) + class(ty_ozphys), intent(in) :: this + real(kind_phys), intent(in) :: & + con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2) + real(kind_phys), intent(in) :: & + dt ! Model timestep (sec) + real(kind_phys), intent(in), dimension(:,:) :: & + p, & ! Model Pressure (Pa) + t, & ! Model temperature (K) + dp ! Model layer thickness (Pa) + real(kind_phys), intent(in), dimension(:,:,:) :: & + ozpl ! Ozone forcing data + real(kind_phys), intent(inout), dimension(:,:) :: & + oz ! Ozone concentration updated by physics + real(kind_phys), intent(inout), dimension(:,:), pointer, optional :: & + do3_dt_prd, & ! Physics tendency: production and loss effect + do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect + do3_dt_temp, & ! Physics tendency: temperature effect + do3_dt_ohoz ! Physics tendency: overhead ozone effect + + ! Locals + integer :: k, kmax, kmin, iLev, iCol, nCol, nLev, iCf + logical, dimension(size(p,1)) :: flg + real(kind_phys) :: pmax, pmin, tem, temp + real(kind_phys), dimension(size(p,1)) :: wk1, wk2, wk3, ozib + real(kind_phys), dimension(size(p,1),this%ncf) :: prod + real(kind_phys), dimension(size(p,1),size(p,2)) :: ozi + real(kind_phys), dimension(size(p,1),size(p,2)+1) :: colo3, coloz + + ! Dimensions + nCol = size(p,1) + nLev = size(p,2) + + ! Temporaries + ozi = oz + + !> - Calculate vertical integrated column ozone values. + if (this%ncf > 2) then + colo3(:,nLev+1) = 0.0 + do iLev=nLev,1,-1 + do iCol=1,nCol + colo3(iCol,iLev) = colo3(iCol,iLev+1) + ozi(iCol,iLev) * dp(iCol,iLev) * con_1ovg + enddo + enddo + endif + + !> - Apply vertically linear interpolation to the ozone coefficients. + do iLev=1,nLev + pmin = 1.0e10 + pmax = -1.0e10 + + do iCol=1,nCol + wk1(iCol) = log(p(iCol,iLev)) + pmin = min(wk1(iCol), pmin) + pmax = max(wk1(iCol), pmax) + prod(iCol,:) = 0._kind_phys + enddo + kmax = 1 + kmin = 1 + do k=1,this%nlev-1 + if (pmin < this%po3(k)) kmax = k + if (pmax < this%po3(k)) kmin = k + enddo + + do k=kmin,kmax + temp = 1.0 / (this%po3(k) - this%po3(k+1)) + do iCol=1,nCol + flg(iCol) = .false. + if (wk1(iCol) < this%po3(k) .and. wk1(iCol) >= this%po3(k+1)) then + flg(iCol) = .true. + wk2(iCol) = (wk1(iCol) - this%po3(k+1)) * temp + wk3(iCol) = 1.0 - wk2(iCol) + endif + enddo + do iCf=1,this%ncf + do iCol=1,nCol + if (flg(iCol)) then + prod(iCol,iCf) = wk2(iCol) * ozpl(iCol,k,iCf) + wk3(iCol) * ozpl(iCol,k+1,iCf) + endif + enddo + enddo + enddo + + do iCf=1,this%ncf + do iCol=1,nCol + if (wk1(iCol) < this%po3(this%nlev)) then + prod(iCol,iCf) = ozpl(iCol,this%nlev,iCf) + endif + if (wk1(iCol) >= this%po3(1)) then + prod(iCol,iCf) = ozpl(iCol,1,iCf) + endif + enddo + enddo + + if (this%ncf == 2) then + do iCol=1,nCol + ozib(iCol) = ozi(iCol,iLev) + oz(iCol,iLev) = (ozib(iCol) + prod(iCol,1)*dt) / (1.0 + prod(iCol,2)*dt) + enddo + endif + + if (this%ncf == 4) then + do iCol=1,nCol + ozib(iCol) = ozi(iCol,iLev) + tem = prod(iCol,1) + prod(iCol,3)*t(iCol,iLev) + prod(iCol,4)*colo3(iCol,iLev+1) + oz(iCol,iLev) = (ozib(iCol) + tem*dt) / (1.0 + prod(iCol,2)*dt) + enddo + endif + ! Diagnostics (optional) + if (associated(do3_dt_prd)) do3_dt_prd(:,iLev) = prod(:,1)*dt + if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:)) + if (associated(do3_dt_temp)) do3_dt_temp(:,iLev) = prod(:,3) * t(:,iLev) * dt + if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,iLev) = prod(:,4) * colo3(:,iLev) * dt + + enddo + + return + end subroutine run_o3prog_2006 + + ! ######################################################################################### + ! Procedure (type-bound) for NRL updating climotological ozone. + ! ######################################################################################### + subroutine run_o3clim(this, lat, prslk, con_pi, oz) + class(ty_ozphys), intent(in) :: this + real(kind_phys), intent(in) :: & + con_pi ! Physics constant: Pi + real(kind_phys), intent(in), dimension(:) :: & + lat ! Grid latitude + real(kind_phys), intent(in), dimension(:,:) :: & + prslk ! Exner function + real(kind_phys), intent(out), dimension(:,:) :: & + oz ! Ozone concentration updated by climotology + + integer :: nCol, iCol, nLev, iLev, j, j1, j2, l, ll + real(kind_phys) :: elte, deglat, tem, tem1, tem2, tem3, tem4, temp + real(kind_phys), allocatable :: o3i(:,:),wk1(:) + logical :: top_at_1 + + nCol = size(prslk(:,1)) + nLev = size(prslk(1,:)) + allocate(o3i(nCol, this%nlevc),wk1(nCol)) + + ! What is vertical ordering? + top_at_1 = (prslk(1,1) .lt. prslk(1, nLev)) + + elte = this%blatc + (this%nlatc-1)*this%dphiozc + + do iCol = 1, nCol + deglat = lat(iCol) * 180.0 / con_pi + if (deglat > this%blatc .and. deglat < elte) then + tem1 = (deglat - this%blatc) / this%dphiozc + 1 + j1 = tem1 + j2 = j1 + 1 + tem1 = tem1 - j1 + elseif (deglat <= this%blatc) then + j1 = 1 + j2 = 1 + tem1 = 1.0 + elseif (deglat >= elte) then + j1 = this%nlatc + j2 = this%nlatc + tem1 = 1.0 + endif + + tem2 = 1.0 - tem1 + do j = 1, this%nlevc + tem3 = tem2*this%datac(j1,j,this%k1oz) + tem1*this%datac(j2,j,this%k1oz) + tem4 = tem2*this%datac(j1,j,this%k2oz) + tem1*this%datac(j2,j,this%k2oz) + o3i(iCol,j) = tem4*this%facoz + tem3*(1.0 - this%facoz) + enddo + enddo + + do iLev = 1, nLev + ll = iLev + if (.not. top_at_1) ll = nLev - iLev + 1 + + do iCol = 1, nCol + wk1(iCol) = prslk(iCol,ll) + enddo + + do j = 1, this%nlevc-1 + temp = 1.0 / (this%pkstr(j+1) - this%pkstr(j)) + do iCol = 1, nCol + if (wk1(iCol) > this%pkstr(j) .and. wk1(iCol) <= this%pkstr(j+1)) then + tem = (this%pkstr(j+1) - wk1(iCol)) * temp + oz(iCol,ll) = tem * o3i(iCol,j) + (1.0 - tem) * o3i(iCol,j+1) + endif + enddo + enddo + + do iCol = 1, nCol + if (wk1(iCol) > this%pkstr(this%nlevc)) oz(iCol,ll) = o3i(iCol,this%nlevc) + if (wk1(iCol) < this%pkstr(1)) oz(iCol,ll) = o3i(iCol,1) + enddo + enddo + + return + end subroutine run_o3clim + + ! ######################################################################################### + ! Procedure (type-bound) for loading data for climotological ozone. + ! ######################################################################################### + function load_o3clim(this, file, fileID) result (err_message) + class(ty_ozphys), intent(inout) :: this + integer, intent(in) :: fileID + character(len=*), intent(in) :: file + character(len=128) :: err_message + + ! Locals + real(kind=4) :: blatc4 + integer :: iLev, iLat, imo + real(kind=4), allocatable :: o3clim4(:,:,:), pstr4(:) + integer, allocatable :: imond(:), ilatt(:,:) + + open(unit=fileID,file=trim(file), form='unformatted', convert='big_endian') + read (fileID,end=101) this%nlatc, this%nlevc, this%ntimec, blatc4 +101 if (this%nlevc < 10 .or. this%nlevc > 100) then + rewind (fileID) + this%nlevc = 17 + this%nlatc = 18 + this%blatc = -85.0 + else + this%blatc = blatc4 + endif + this%nlat = 2 + this%nlev = 1 + this%ntimec = 1 + this%ncf = 0 + this%dphiozc = -(this%blatc+this%blatc)/(this%nlatc-1) + + allocate (o3clim4(this%nlatc,this%nlevc,12), pstr4(this%nlevc), imond(12), ilatt(this%nlatc,12) ) + + allocate (this%pkstr(this%nlevc), this%pstr(this%nlevc), this%datac(this%nlatc,this%nlevc,12)) + if ( this%nlevc == 17 ) then ! For the operational ozone climatology + do iLev = 1, this%nlevc + read (fileID,15) pstr4(iLev) +15 format(f10.3) + enddo + + do imo = 1, 12 + do iLat = 1, this%nlatc + read (fileID,16) imond(imo), ilatt(iLat,imo), (o3clim4(iLat,iLev,imo),iLev=1,10) +16 format(i2,i4,10f6.2) + read (fileID,20) (o3clim4(iLat,iLev,imo),iLev=11,this%nlevc) +20 format(6x,10f6.2) + enddo + enddo + else ! For newer ozone climatology + read (fileID) + do iLev = 1, this%nlevc + read (fileID) pstr4(iLev) + enddo + + do imo = 1, 12 + do iLev = 1, this%nlevc + read (fileID) (o3clim4(iLat,iLev,imo),iLat=1,this%nlatc) + enddo + enddo + endif ! end if_this%nlevc_block + + do imo = 1, 12 + do iLev = 1, this%nlevc + do iLat = 1, this%nlatc + this%datac(iLat,iLev,imo) = o3clim4(iLat,iLev,imo) * 1.655e-6 + enddo + enddo + enddo + + do iLev = 1, this%nlevc + this%pstr(iLev) = pstr4(iLev) + this%pkstr(iLev) = fpkapx(this%pstr(iLev)*100.0) + enddo + + end function load_o3clim + + ! ######################################################################################### + ! Procedure (type-bound) for updating temporal interpolation index when using climotological + ! ozone + ! ######################################################################################### + subroutine update_o3clim(this, imon, iday, ihour, loz1st) + class(ty_ozphys), intent(inout) :: this + integer, intent(in) :: imon, iday, ihour + logical, intent(in) :: loz1st + + integer :: midmon=15, midm=15, midp=45, id + integer, parameter, dimension(13) :: mdays = (/31,28,31,30,31,30,31,31,30,31,30,31,30/) + logical :: change + + midmon = mdays(imon)/2 + 1 + change = loz1st .or. ( (iday==midmon) .and. (ihour==0) ) + + if ( change ) then + if ( iday < midmon ) then + this%k1oz = mod(imon+10, 12) + 1 + midm = mdays(this%k1oz)/2 + 1 + this%k2oz = imon + midp = mdays(this%k1oz) + midmon + else + this%k1oz = imon + midm = midmon + this%k2oz = mod(imon, 12) + 1 + midp = mdays(this%k2oz)/2 + 1 + mdays(this%k1oz) + endif + endif + + if (iday < midmon) then + id = iday + mdays(this%k1oz) + else + id = iday + endif + + this%facoz = float(id - midm) / float(midp - midm) + + end subroutine update_o3clim + + end module module_ozphys diff --git a/physics/photochem/module_ozphys.meta b/physics/photochem/module_ozphys.meta new file mode 100644 index 000000000..2922d16d7 --- /dev/null +++ b/physics/photochem/module_ozphys.meta @@ -0,0 +1,24 @@ +[ccpp-table-properties] + name = ty_ozphys + type = ddt + dependencies = + +[ccpp-arg-table] + name = ty_ozphys + type = ddt + +######################################################################## +[ccpp-table-properties] + name = module_ozphys + type = module + dependencies = machine.F,funcphys.f90 + +[ccpp-arg-table] + name = module_ozphys + type = module +[ty_ozphys] + standard_name = ty_ozphys + long_name = definition of type ty_ozphys + units = DDT + dimensions = () + type = ty_ozphys \ No newline at end of file diff --git a/physics/phys_tend.F90 b/physics/phys_tend.F90 deleted file mode 100644 index e63f44be5..000000000 --- a/physics/phys_tend.F90 +++ /dev/null @@ -1,96 +0,0 @@ -!>\file phys_tend.F90 -!! -module phys_tend - - use machine, only: kind_phys - - implicit none - - private - - public phys_tend_run - -contains - -!> \section arg_table_phys_tend_run Argument Table -!! \htmlinclude phys_tend_run.html -!! - subroutine phys_tend_run(ldiag3d, dtend, dtidx, ntracp100, & - index_of_process_physics, index_of_process_photochem, & - nprocess, nprocess_summed, is_photochem, ntoz, errmsg, errflg) - - ! Interface variables - logical, intent(in) :: ldiag3d, is_photochem(:) - real(kind=kind_phys), optional, intent(inout) :: dtend(:,:,:) - integer, intent(in) :: dtidx(:,:), index_of_process_physics, ntoz, & - ntracp100, nprocess, nprocess_summed, index_of_process_photochem - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: ichem, iphys, itrac - logical :: all_true(nprocess) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if(.not.ldiag3d) then - return - endif - - all_true = .true. - - ! Total photochemical tendencies - itrac=ntoz+100 - ichem = dtidx(itrac,index_of_process_photochem) - if(ichem>=1) then - call sum_it(ichem,itrac,is_photochem) - endif - - - do itrac=2,ntracp100 - ! Total physics tendencies - iphys = dtidx(itrac,index_of_process_physics) - if(iphys>=1) then - call sum_it(iphys,itrac,all_true) - endif - enddo - - contains - - subroutine sum_it(isum,itrac,sum_me) - implicit none - integer, intent(in) :: isum ! third index of dtend of summary process - integer, intent(in) :: itrac ! tracer or state variable being summed - logical, intent(in) :: sum_me(nprocess) ! false = skip this process - logical :: first - integer :: idtend, iprocess - - first=.true. - do iprocess=1,nprocess - if(iprocess>nprocess_summed) then - exit ! Don't sum up the sums. - else if(.not.sum_me(iprocess)) then - cycle ! We were asked to skip this one. - endif - idtend = dtidx(itrac,iprocess) - if(idtend>=1) then - ! This tendency was calculated for this tracer, so - ! accumulate it into the total tendency. - if(first) then - dtend(:,:,isum) = dtend(:,:,idtend) - first=.false. - else - dtend(:,:,isum) = dtend(:,:,isum) + dtend(:,:,idtend) - endif - endif - enddo - if(first) then - ! No tendencies were calculated, so sum is 0: - dtend(:,:,isum) = 0 - endif - end subroutine sum_it - - end subroutine phys_tend_run - -end module phys_tend diff --git a/physics/phys_tend.meta b/physics/phys_tend.meta deleted file mode 100644 index 0f78af20b..000000000 --- a/physics/phys_tend.meta +++ /dev/null @@ -1,95 +0,0 @@ -[ccpp-table-properties] - name = phys_tend - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = phys_tend_run - type = scheme -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[ntracp100] - standard_name = number_of_tracers_plus_one_hundred - long_name = number of tracers plus one hundred - units = count - dimensions = () - type = integer - intent = in -[index_of_process_physics] - standard_name = index_of_all_physics_process_in_cumulative_change_index - long_name = index of all physics transport process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_photochem] - standard_name = index_of_photochemistry_process_in_cumulative_change_index - long_name = index of photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[nprocess] - standard_name = number_of_cumulative_change_processes - long_name = number of processes that cause changes in state variables - units = count - dimensions = () - type = integer - intent = in -[nprocess_summed] - standard_name = number_of_physics_causes_of_tracer_changes - long_name = number of causes in dtidx per tracer summed for total physics tendency - units = count - dimensions = () - type = integer - intent = in -[is_photochem] - standard_name = flags_for_photochemistry_processes_to_sum - long_name = flags for photochemistry processes to sum as the total photochemistry process cumulative change - units = flag - dimensions = (number_of_cumulative_change_processes) - type = logical - intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmg_lw_pre.F90 b/physics/rrtmg_lw_pre.F90 deleted file mode 100644 index 2b63d98c5..000000000 --- a/physics/rrtmg_lw_pre.F90 +++ /dev/null @@ -1,26 +0,0 @@ -!>\file rrtmg_lw_pre.F90 -!! - module rrtmg_lw_pre - contains - -!>\defgroup rrtmg_lw_pre GFS RRTMG-LW scheme pre -!! This module contains RRTMG-LW pre module. -!> @{ -!> \section arg_table_rrtmg_lw_pre_run Argument Table -!! \htmlinclude rrtmg_lw_pre_run.html -!! - subroutine rrtmg_lw_pre_run (errmsg, errflg) - - implicit none - - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - end subroutine rrtmg_lw_pre_run - -!> @} - end module rrtmg_lw_pre diff --git a/physics/rrtmg_lw_pre.meta b/physics/rrtmg_lw_pre.meta deleted file mode 100644 index 9f6ec07c8..000000000 --- a/physics/rrtmg_lw_pre.meta +++ /dev/null @@ -1,24 +0,0 @@ -[ccpp-table-properties] - name = rrtmg_lw_pre - type = scheme - dependencies = - -######################################################################## -[ccpp-arg-table] - name = rrtmg_lw_pre_run - type = scheme -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp deleted file mode 160000 index 0dc54f5ec..000000000 --- a/physics/rte-rrtmgp +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 0dc54f5ecaeb1e1e342efd1e02d0bcd41737bde2 diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f deleted file mode 100644 index 2ca70666d..000000000 --- a/physics/sfc_nst.f +++ /dev/null @@ -1,696 +0,0 @@ -!>\file sfc_nst.f -!! This file contains the GFS NSST model. - -!> This module contains the CCPP-compliant GFS near-surface sea temperature scheme. - module sfc_nst - - contains - -!>\defgroup gfs_nst_main_mod GFS Near-Surface Sea Temperature Module -!! This module contains the CCPP-compliant GFS near-surface sea temperature scheme. -!> @{ -!! This subroutine calls the Thermal Skin-layer and Diurnal Thermocline models to update the NSST profile. -!! \section arg_table_sfc_nst_run Argument Table -!! \htmlinclude sfc_nst_run.html -!! -!> \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm - subroutine sfc_nst_run & - & ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs: - & pi, tgice, sbc, ps, u1, v1, t1, q1, tref, cm, ch, & - & lseaspray, fm, fm10, & - & prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, & - & sinlat, stress, & - & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & - & wind, flag_iter, flag_guess, nstf_name1, nstf_name4, & - & nstf_name5, lprnt, ipr, thsfc_loc, & - & tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & ! --- input/output: - & z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, & - & qsurf, gflux, cmm, chh, evap, hflx, ep, errmsg, errflg & ! --- outputs: - & ) -! -! ===================================================================== ! -! description: ! -! ! -! ! -! usage: ! -! ! -! call sfc_nst ! -! inputs: ! -! ( im, ps, u1, v1, t1, q1, tref, cm, ch, ! -! lseaspray, fm, fm10, ! -! prsl1, prslki, wet, use_lake_model, xlon, sinlat, stress, ! -! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! -! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, ! -! nstf_name5, lprnt, ipr, thsfc_loc, ! -! input/outputs: ! -! tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, ! -! z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, ! -! -- outputs: -! qsurf, gflux, cmm, chh, evap, hflx, ep ! -! ) -! ! -! ! -! subprogram/functions called: w3movdat, iw3jdn, fpvs, density, ! -! rhocoef, cool_skin, warm_layer, jacobi_temp. ! -! ! -! program history log: ! -! 2007 -- xu li createad original code ! -! 2008 -- s. moorthi adapted to the parallel version ! -! may 2009 -- y.-t. hou modified to include input lw surface ! -! emissivity from radiation. also replaced the ! -! often comfusing combined sw and lw suface ! -! flux with separate sfc net sw flux (defined ! -! as dn-up) and lw flux. added a program doc block. ! -! sep 2009 -- s. moorthi removed rcl and additional reformatting ! -! and optimization + made pa as input pressure unit.! -! 2009 -- xu li recreatead the code ! -! feb 2010 -- s. moorthi added some changes made to the previous ! -! version ! -! Jul 2016 -- X. Li, modify the diurnal warming event reset ! -! ! -! ! -! ==================== definition of variables ==================== ! -! ! -! inputs: size ! -! im - integer, horiz dimension 1 ! -! ps - real, surface pressure (pa) im ! -! u1, v1 - real, u/v component of surface layer wind (m/s) im ! -! t1 - real, surface layer mean temperature ( k ) im ! -! q1 - real, surface layer mean specific humidity im ! -! tref - real, reference/foundation temperature ( k ) im ! -! cm - real, surface exchange coeff for momentum (m/s) im ! -! ch - real, surface exchange coeff heat & moisture(m/s) im ! -! lseaspray- logical, .t. for parameterization for sea spray 1 ! -! fm - real, a stability profile function for momentum im ! -! fm10 - real, a stability profile function for momentum im ! -! at 10m ! -! prsl1 - real, surface layer mean pressure (pa) im ! -! prslki - real, im ! -! prsik1 - real, im ! -! prslk1 - real, im ! -! wet - logical, =T if any ocn/lake water (F otherwise) im ! -! use_lake_model- logical, =T if flake model is used for lake im ! -! icy - logical, =T if any ice im ! -! xlon - real, longitude (radians) im ! -! sinlat - real, sin of latitude im ! -! stress - real, wind stress (n/m**2) im ! -! sfcemis - real, sfc lw emissivity (fraction) im ! -! dlwflx - real, total sky sfc downward lw flux (w/m**2) im ! -! sfcnsw - real, total sky sfc netsw flx into ocean (w/m**2) im ! -! rain - real, rainfall rate (kg/m**2/s) im ! -! timestep - real, timestep interval (second) 1 ! -! kdt - integer, time step counter 1 ! -! solhr - real, fcst hour at the end of prev time step 1 ! -! xcosz - real, consine of solar zenith angle 1 ! -! wind - real, wind speed (m/s) im ! -! flag_iter- logical, execution or not im ! -! when iter = 1, flag_iter = .true. for all grids im ! -! when iter = 2, flag_iter = .true. when wind < 2 im ! -! for both land and ocean (when nstf_name1 > 0) im ! -! flag_guess-logical, .true.= guess step to get CD et al im ! -! when iter = 1, flag_guess = .true. when wind < 2 im ! -! when iter = 2, flag_guess = .false. for all grids im ! -! nstf_name - integers , NSST related flag parameters 1 ! -! nstf_name1 : 0 = NSSTM off 1 ! -! 1 = NSSTM on but uncoupled 1 ! -! 2 = NSSTM on and coupled 1 ! -! nstf_name4 : zsea1 in mm 1 ! -! nstf_name5 : zsea2 in mm 1 ! -! lprnt - logical, control flag for check print out 1 ! -! ipr - integer, grid index for check print out 1 ! -! thsfc_loc- logical, flag for reference pressure in theta 1 ! -! ! -! input/outputs: -! li added for oceanic components -! tskin - real, ocean surface skin temperature ( k ) im ! -! tsurf - real, the same as tskin ( k ) but for guess run im ! -! xt - real, heat content in dtl im ! -! xs - real, salinity content in dtl im ! -! xu - real, u-current content in dtl im ! -! xv - real, v-current content in dtl im ! -! xz - real, dtl thickness im ! -! zm - real, mxl thickness im ! -! xtts - real, d(xt)/d(ts) im ! -! xzts - real, d(xz)/d(ts) im ! -! dt_cool - real, sub-layer cooling amount im ! -! d_conv - real, thickness of free convection layer (fcl) im ! -! z_c - sub-layer cooling thickness im ! -! c_0 - coefficient1 to calculate d(tz)/d(ts) im ! -! c_d - coefficient2 to calculate d(tz)/d(ts) im ! -! w_0 - coefficient3 to calculate d(tz)/d(ts) im ! -! w_d - coefficient4 to calculate d(tz)/d(ts) im ! -! ifd - real, index to start dtlm run or not im ! -! qrain - real, sensible heat flux due to rainfall (watts) im ! - -! outputs: ! - -! qsurf - real, surface air saturation specific humidity im ! -! gflux - real, soil heat flux (w/m**2) im ! -! cmm - real, im ! -! chh - real, im ! -! evap - real, evaperation from latent heat flux im ! -! hflx - real, sensible heat flux im ! -! ep - real, potential evaporation im ! -! ! -! ===================================================================== ! - use machine , only : kind_phys - use funcphys, only : fpvs - use date_def, only : idate - use module_nst_water_prop, only: get_dtzm_point - use module_nst_parameters, only : t0k,cp_w,omg_m,omg_sh, & - & sigma_r,solar_time_6am,ri_c,z_w_max,delz,wd_max, & - & rad2deg,const_rot,tau_min,tw_max,sst_max - use module_nst_water_prop, only: solar_time_from_julian, & - & density,rhocoef,compjd,grv & - &, sw_ps_9b - use nst_module, only : cool_skin,dtm_1p,cal_w,cal_ttop, & - & convdepth,dtm_1p_fca,dtm_1p_tla, & - & dtm_1p_mwa,dtm_1p_mda,dtm_1p_mta, & - & dtl_reset -! - implicit none - - integer, parameter :: kp = kind_phys -! -! --- constant parameters: - real (kind=kind_phys), parameter :: f24 = 24.0_kp ! hours/day - real (kind=kind_phys), parameter :: f1440 = 1440.0_kp ! minutes/day - real (kind=kind_phys), parameter :: czmin = 0.0001_kp ! cos(89.994) - real (kind=kind_phys), parameter :: zero = 0.0_kp, one = 1.0_kp - - -! --- inputs: - integer, intent(in) :: im, kdt, ipr, nstf_name1, nstf_name4, & - & nstf_name5 - real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, & - & epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice - real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & - & t1, q1, tref, cm, ch, fm, fm10, & - & prsl1, prslki, prsik1, prslk1, xlon, xcosz, & - & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind - real (kind=kind_phys), intent(in) :: timestep - real (kind=kind_phys), intent(in) :: solhr - -! For sea spray effect - logical, intent(in) :: lseaspray -! - logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet - integer, dimension(:), intent(in) :: use_lake_model -! &, icy - logical, intent(in) :: lprnt - logical, intent(in) :: thsfc_loc - -! --- input/outputs: -! control variables of dtl system (5+2) and sl (2) and coefficients for d(tz)/d(ts) calculation - real (kind=kind_phys), dimension(:), intent(inout) :: tskin, & - & tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & - & z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain - -! --- outputs: - real (kind=kind_phys), dimension(:), intent(inout) :: & - & qsurf, gflux, cmm, chh, evap, hflx, ep - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! -! locals -! - integer :: k,i -! - real (kind=kind_phys), dimension(im) :: q0, qss, rch, - & rho_a, theta1, tv1, wndmag - - real(kind=kind_phys) elocp,tem,cpinv,hvapi -! -! nstm related prognostic fields -! - logical flag(im) - real (kind=kind_phys), dimension(im) :: - & xt_old, xs_old, xu_old, xv_old, xz_old,zm_old,xtts_old, - & xzts_old, ifd_old, tref_old, tskin_old, dt_cool_old,z_c_old - - real(kind=kind_phys) ulwflx(im), nswsfc(im) -! real(kind=kind_phys) rig(im), -! & ulwflx(im),dlwflx(im), -! & slrad(im),nswsfc(im) - real(kind=kind_phys) alpha,beta,rho_w,f_nsol,sss,sep, - & cosa,sina,taux,tauy,grav,dz,t0,ttop0,ttop - - real(kind=kind_phys) le,fc,dwat,dtmp,wetc,alfac,ustar_a,rich - real(kind=kind_phys) rnl_ts,hs_ts,hl_ts,rf_ts,q_ts - real(kind=kind_phys) fw,q_warm - real(kind=kind_phys) t12,alon,tsea,sstc,dta,dtz - real(kind=kind_phys) zsea1,zsea2,soltim - logical do_nst - -! external functions called: iw3jdn - integer :: iw3jdn -! -! parameters for sea spray effect -! - real (kind=kind_phys) :: f10m, u10m, v10m, ws10, ru10, qss1, - & bb1, hflxs, evaps, ptem -! -! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.1, -! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.0, -! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2, - real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, - & ws10cr=30., conlf=7.2e-9, consf=6.4e-8 -! -!====================================================================================================== -cc - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (nstf_name1 == 0) return ! No NSST model used - - cpinv = one/cp - hvapi = one/hvap - elocp = hvap/cp - - sss = 34.0_kp ! temporarily, when sea surface salinity data is not ready -! -! flag for open water and where the iteration is on -! - do_nst = .false. - do i = 1, im -! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i) - flag(i) = wet(i) .and. flag_iter(i) .and. use_lake_model(i)/=1 - do_nst = do_nst .or. flag(i) - enddo - if (.not. do_nst) return -! -! save nst-related prognostic fields for guess run -! - do i=1, im -! if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then - if(wet(i) .and. flag_guess(i) .and. use_lake_model(i)/=1) then - xt_old(i) = xt(i) - xs_old(i) = xs(i) - xu_old(i) = xu(i) - xv_old(i) = xv(i) - xz_old(i) = xz(i) - zm_old(i) = zm(i) - xtts_old(i) = xtts(i) - xzts_old(i) = xzts(i) - ifd_old(i) = ifd(i) - tskin_old(i) = tskin(i) - dt_cool_old(i) = dt_cool(i) - z_c_old(i) = z_c(i) - endif - enddo - - -! --- ... initialize variables. all units are m.k.s. unless specified. -! ps is in pascals, wind is wind speed, theta1 is surface air -! estimated from level 1 temperature, rho_a is air density and -! qss is saturation specific humidity at the water surface -!! - do i = 1, im - if ( flag(i) ) then - - nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward) - wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) - - q0(i) = max(q1(i), 1.0e-8_kp) - - if(thsfc_loc) then ! Use local potential temperature - theta1(i) = t1(i) * prslki(i) - else ! Use potential temperature referenced to 1000 hPa - theta1(i) = t1(i) / prslk1(i) ! potential temperature at the middle of lowest model layer - endif - - tv1(i) = t1(i) * (one + rvrdm1*q0(i)) - rho_a(i) = prsl1(i) / (rd*tv1(i)) - qss(i) = fpvs(tsurf(i)) ! pa - qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) ! pa -! - evap(i) = zero - hflx(i) = zero - gflux(i) = zero - ep(i) = zero - -! --- ... rcp = rho cp ch v - - rch(i) = rho_a(i) * cp * ch(i) * wind(i) - cmm(i) = cm (i) * wind(i) - chh(i) = rho_a(i) * ch(i) * wind(i) - -!> - Calculate latent and sensible heat flux over open water with tskin. -! at previous time step - evap(i) = elocp * rch(i) * (qss(i) - q0(i)) - qsurf(i) = qss(i) - - if(thsfc_loc) then ! Use local potential temperature - hflx(i) = rch(i) * (tsurf(i) - theta1(i)) - else ! Use potential temperature referenced to 1000 hPa - hflx(i) = rch(i) * (tsurf(i)/prsik1(i) - theta1(i)) - endif - -! if (lprnt .and. i == ipr) print *,' tskin=',tskin(i),' theta1=', -! & theta1(i),' hflx=',hflx(i),' t1=',t1(i),'prslki=',prslki(i) -! &,' tsurf=',tsurf(i) - endif - enddo - -! run nst model: dtm + slm -! - zsea1 = 0.001_kp*real(nstf_name4) - zsea2 = 0.001_kp*real(nstf_name5) - -!> - Call module_nst_water_prop::density() to compute sea water density. -!> - Call module_nst_water_prop::rhocoef() to compute thermal expansion -!! coefficient (\a alpha) and saline contraction coefficient (\a beta). - do i = 1, im - if ( flag(i) ) then - tsea = tsurf(i) - t12 = tsea*tsea - ulwflx(i) = sfcemis(i) * sbc * t12 * t12 - alon = xlon(i)*rad2deg - grav = grv(sinlat(i)) - soltim = mod(alon/15.0_kp + solhr, 24.0_kp)*3600.0_kp - call density(tsea,sss,rho_w) ! sea water density - call rhocoef(tsea,sss,rho_w,alpha,beta) ! alpha & beta -! -!> - Calculate sensible heat flux (\a qrain) due to rainfall. -! - le = (2.501_kp-0.00237_kp*tsea)*1e6_kp - dwat = 2.11e-5_kp*(t1(i)/t0k)**1.94_kp ! water vapor diffusivity - dtmp = (one+3.309e-3_kp*(t1(i)-t0k)-1.44e-6_kp*(t1(i)-t0k) - & * (t1(i)-t0k))*0.02411_kp/(rho_a(i)*cp) ! heat diffusivity - wetc = 622.0_kp*le*qss(i)/(rd*t1(i)*t1(i)) - alfac = one / (one + (wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor - tem = (1.0e3_kp * rain(i) / rho_w) * alfac * cp_w - qrain(i) = tem * (tsea-t1(i)+1.0e3_kp*(qss(i)-q0(i))*le/cp) - -!> - Calculate input non solar heat flux as upward = positive to models here - - f_nsol = hflx(i) + evap(i) + ulwflx(i) - dlwflx(i) - & + omg_sh*qrain(i) - -! if (lprnt .and. i == ipr) print *,' f_nsol=',f_nsol,' hflx=', -! &hflx(i),' evap=',evap(i),' ulwflx=',ulwflx(i),' dlwflx=',dlwflx(i) -! &,' omg_sh=',omg_sh,' qrain=',qrain(i) - - sep = sss*(evap(i)/le-rain(i))/rho_w - ustar_a = sqrt(stress(i)/rho_a(i)) ! air friction velocity -! -! sensitivities of heat flux components to ts -! - rnl_ts = 4.0_kp*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts) - hs_ts = rch(i) - hl_ts = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12) - rf_ts = tem * (one+rch(i)*hl_ts) - q_ts = rnl_ts + hs_ts + hl_ts + omg_sh*rf_ts -! -!> - Call cool_skin(), which is the sub-layer cooling parameterization -!! (Fairfall et al. (1996) \cite fairall_et_al_1996). -! & calculate c_0, c_d -! - call cool_skin(ustar_a,f_nsol,nswsfc(i),evap(i),sss,alpha,beta - &, rho_w,rho_a(i),tsea,q_ts,hl_ts,grav,le - &, dt_cool(i),z_c(i),c_0(i),c_d(i)) - - tem = one / wndmag(i) - cosa = u1(i)*tem - sina = v1(i)*tem - taux = max(stress(i),tau_min)*cosa - tauy = max(stress(i),tau_min)*sina - fc = const_rot*sinlat(i) -! -! Run DTM-1p system. -! - if ( (soltim > solar_time_6am .and. ifd(i) == zero) ) then - else - ifd(i) = one -! -! calculate fcl thickness with current forcing and previous time's profile -! -! if (lprnt .and. i == ipr) print *,' beg xz=',xz(i) - -!> - Call convdepth() to calculate depth for convective adjustments. - if ( f_nsol > zero .and. xt(i) > zero ) then - call convdepth(kdt,timestep,nswsfc(i),f_nsol,sss,sep,rho_w - &, alpha,beta,xt(i),xs(i),xz(i),d_conv(i)) - else - d_conv(i) = zero - endif - -! if (lprnt .and. i == ipr) print *,' beg xz1=',xz(i) -! -! determine rich: wind speed dependent (right now) -! -! if ( wind(i) < 1.0 ) then -! rich = 0.25 + 0.03*wind(i) -! elseif ( wind(i) >= 1.0 .and. wind(i) < 1.5 ) then -! rich = 0.25 + 0.1*wind(i) -! elseif ( wind(i) >= 1.5 .and. wind(i) < 6.0 ) then -! rich = 0.25 + 0.6*wind(i) -! elseif ( wind(i) >= 6.0 ) then -! rich = 0.25 + min(0.8*wind(i),0.50) -! endif - - rich = ri_c - -!> - Call the diurnal thermocline layer model dtm_1p(). - call dtm_1p(kdt,timestep,rich,taux,tauy,nswsfc(i), - & f_nsol,sss,sep,q_ts,hl_ts,rho_w,alpha,beta,alon, - & sinlat(i),soltim,grav,le,d_conv(i), - & xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - -! if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i) - -! apply mda - if ( xt(i) > zero ) then -!> - If \a dtl heat content \a xt > 0.0, call dtm_1p_mda() to apply -!! minimum depth adjustment (mda). - call dtm_1p_mda(xt(i),xtts(i),xz(i),xzts(i)) - if ( xz(i) >= z_w_max ) then -!> - If \a dtl thickness >= module_nst_parameters::z_w_max, call dtl_reset() -!! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max. - call dtl_reset(xt(i),xs(i),xu(i),xv(i),xz(i),xtts(i), - & xzts(i)) - -! if (lprnt .and. i == ipr) print *,' beg xz3=',xz(i),' z_w_max=' -! &,z_w_max - endif - -! apply fca - if ( d_conv(i) > zero ) then -!> - If thickness of free convection layer > 0.0, call dtm_1p_fca() -!! to apply free convection adjustment. -!> - If \a dtl thickness >= module_nst_parameters::z_w_max(), call dtl_reset() -!! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max(). - call dtm_1p_fca(d_conv(i),xt(i),xtts(i),xz(i),xzts(i)) - if ( xz(i) >= z_w_max ) then - call dtl_reset - & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - endif - endif - -! if (lprnt .and. i == ipr) print *,' beg xz4=',xz(i) - -! apply tla - dz = min(xz(i),max(d_conv(i),delz)) -! -!> - Call sw_ps_9b() to compute the fraction of the solar radiation -!! absorbed by the depth \a delz (Paulson and Simpson (1981) \cite paulson_and_simpson_1981). -!! And calculate the total heat absorbed in warm layer. - call sw_ps_9b(delz,fw) - q_warm = fw*nswsfc(i)-f_nsol !total heat absorbed in warm layer - -!> - Call cal_ttop() to calculate the diurnal warming amount at the top layer with -!! thickness of \a dz. - if ( q_warm > zero ) then - call cal_ttop(kdt,timestep,q_warm,rho_w,dz, - & xt(i),xz(i),ttop0) - -! if (lprnt .and. i == ipr) print *,' d_conv=',d_conv(i),' delz=', -! &delz,' kdt=',kdt,' timestep=',timestep,' nswsfc=',nswsfc(i), -! &' f_nsol=',f_nsol,' rho_w=',rho_w,' dz=',dz,' xt=',xt(i), -! &' xz=',xz(i),' qrain=',qrain(i) - - ttop = ((xt(i)+xt(i))/xz(i))*(one-dz/((xz(i)+xz(i)))) - -! if (lprnt .and. i == ipr) print *,' beg xz4a=',xz(i) -! &,' ttop=',ttop,' ttop0=',ttop0,' xt=',xt(i),' dz=',dz -! &,' xznew=',(xt(i)+sqrt(xt(i)*(xt(i)-dz*ttop0)))/ttop0 - -!> - Call dtm_1p_tla() to apply top layer adjustment. - if ( ttop > ttop0 ) then - call dtm_1p_tla(dz,ttop0,xt(i),xtts(i),xz(i),xzts(i)) - -! if (lprnt .and. i == ipr) print *,' beg xz4b=',xz(i),'z_w_max=', -! &z_w_max - if ( xz(i) >= z_w_max ) then - call dtl_reset - & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - endif - endif - endif ! if ( q_warm > 0.0 ) then - -! if (lprnt .and. i == ipr) print *,' beg xz5=',xz(i) - -! apply mwa -!> - Call dt_1p_mwa() to apply maximum warming adjustment. - t0 = (xt(i)+xt(i))/xz(i) - if ( t0 > tw_max ) then - call dtm_1p_mwa(xt(i),xtts(i),xz(i),xzts(i)) - if ( xz(i) >= z_w_max ) then - call dtl_reset - & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - endif - endif - -! if (lprnt .and. i == ipr) print *,' beg xz6=',xz(i) - -! apply mta -!> - Call dtm_1p_mta() to apply maximum temperature adjustment. - sstc = tref(i) + (xt(i)+xt(i))/xz(i) - dt_cool(i) - - if ( sstc > sst_max ) then - dta = sstc - sst_max - call dtm_1p_mta(dta,xt(i),xtts(i),xz(i),xzts(i)) -! write(*,'(a,f3.0,7f8.3)') 'mta, sstc,dta :',islimsk(i), -! & sstc,dta,tref(i),xt(i),xz(i),2.0*xt(i)/xz(i),dt_cool(i) - if ( xz(i) >= z_w_max ) then - call dtl_reset - & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - endif - endif -! - endif ! if ( xt(i) > 0.0 ) then -! reset dtl at midnight and when solar zenith angle > 89.994 degree - if ( abs(soltim) < 2.0_kp*timestep ) then - call dtl_reset - & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - endif - - endif ! if (solar_time > solar_time_6am .and. ifd(i) == 0.0 ) then: too late to start the first day - -! if (lprnt .and. i == ipr) print *,' beg xz7=',xz(i) - -! update tsurf (when flag(i) .eqv. .true. ) -!> - Call get_dtzm_point() to computes \a dtz and \a tsurf. - call get_dtzm_point(xt(i),xz(i),dt_cool(i),z_c(i), - & zsea1,zsea2,dtz) - tsurf(i) = max(tgice, tref(i) + dtz ) - -! if (lprnt .and. i == ipr) print *,' tsurf=',tsurf(i),' tref=', -! &tref(i),' xz=',xz(i),' dt_cool=',dt_cool(i) - -!> - Call cal_w() to calculate \a w_0 and \a w_d. - if ( xt(i) > zero ) then - call cal_w(kdt,xz(i),xt(i),xzts(i),xtts(i),w_0(i),w_d(i)) - else - w_0(i) = zero - w_d(i) = zero - endif - -! if ( xt(i) > 0.0 ) then -! rig(i) = grav*xz(i)*xz(i)*(alpha*xt(i)-beta*xs(i)) -! & /(2.0*(xu(i)*xu(i)+xv(i)*xv(i))) -! else -! rig(i) = 0.25 -! endif - -! qrain(i) = rig(i) - zm(i) = wind(i) - - endif - enddo - -! restore nst-related prognostic fields for guess run - do i=1, im -! if (wet(i) .and. .not.icy(i)) then - if (wet(i) .and. use_lake_model(i)/=1) then - if (flag_guess(i)) then ! when it is guess of - xt(i) = xt_old(i) - xs(i) = xs_old(i) - xu(i) = xu_old(i) - xv(i) = xv_old(i) - xz(i) = xz_old(i) - zm(i) = zm_old(i) - xtts(i) = xtts_old(i) - xzts(i) = xzts_old(i) - ifd(i) = ifd_old(i) - tskin(i) = tskin_old(i) - dt_cool(i) = dt_cool_old(i) - z_c(i) = z_c_old(i) - else -! -! update tskin when coupled and not guess run -! (all other NSST variables have been updated in this case) -! - if ( nstf_name1 > 1 ) then - tskin(i) = tsurf(i) - endif ! if nstf_name1 > 1 then - endif ! if flag_guess(i) then - endif ! if wet(i) .and. .not.icy(i) then - enddo - -! if (lprnt .and. i == ipr) print *,' beg xz8=',xz(i) - - if ( nstf_name1 > 1 ) then -!> - Calculate latent and sensible heat flux over open water with updated tskin -!! for the grids of open water and the iteration is on. - do i = 1, im - if ( flag(i) ) then - qss(i) = fpvs( tskin(i) ) - qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) - qsurf(i) = qss(i) - evap(i) = elocp*rch(i) * (qss(i) - q0(i)) - - if(thsfc_loc) then ! Use local potential temperature - hflx(i) = rch(i) * (tskin(i) - theta1(i)) - else ! Use potential temperature referenced to 1000 hPa - hflx(i) = rch(i) * (tskin(i)/prsik1(i) - theta1(i)) - endif - - endif - enddo - endif ! if ( nstf_name1 > 1 ) then -! -!> - Include sea spray effects -! - do i=1,im - if(lseaspray .and. flag(i)) then - f10m = fm10(i) / fm(i) - u10m = f10m * u1(i) - v10m = f10m * v1(i) - ws10 = sqrt(u10m*u10m + v10m*v10m) - ws10 = max(ws10,1.) - ws10 = min(ws10,ws10cr) - tem = .015 * ws10 * ws10 - ru10 = 1. - .087 * log(10./tem) - qss1 = fpvs(t1(i)) - qss1 = eps * qss1 / (prsl1(i) + epsm1 * qss1) - tem = rd * cp * t1(i) * t1(i) - tem = 1. + eps * hvap * hvap * qss1 / tem - bb1 = 1. / tem - evaps = conlf * (ws10**5.4) * ru10 * bb1 - evaps = evaps * rho_a(i) * hvap * (qss1 - q0(i)) - evap(i) = evap(i) + alps * evaps - hflxs = consf * (ws10**3.4) * ru10 - hflxs = hflxs * rho_a(i) * cp * (tskin(i) - t1(i)) - ptem = alps - gams - hflx(i) = hflx(i) + bets * hflxs - ptem * evaps - endif - enddo -! - do i=1,im - if ( flag(i) ) then - tem = one / rho_a(i) - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi - endif - enddo -! -! if (lprnt) print *,' tskin=',tskin(ipr) - - return - end subroutine sfc_nst_run -!> @} - end module sfc_nst diff --git a/physics/sfc_nst_post.f b/physics/sfc_nst_post.f deleted file mode 100644 index 83bc2f273..000000000 --- a/physics/sfc_nst_post.f +++ /dev/null @@ -1,93 +0,0 @@ -!> \file sfc_nst_post.f -!! This file contains code to be executed after the GFS NSST model. - - module sfc_nst_post - - contains - -! \defgroup GFS_NSST_POST GFS Near-Surface Sea Temperature Post - -!> \section arg_table_sfc_nst_post_run Argument Table -!! \htmlinclude sfc_nst_post_run.html -!! -! \section NSST_general_post_algorithm General Algorithm -! -! \section NSST_detailed_post_algorithm Detailed Algorithm -! @{ - subroutine sfc_nst_post_run & - & ( im, kdt, rlapse, tgice, wet, use_lake_model, icy, oro, & - & oro_uf, nstf_name1, & - & nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, & - & tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg & - & ) - - use machine , only : kind_phys - use module_nst_water_prop, only: get_dtzm_2d - - implicit none - - integer, parameter :: kp = kind_phys - -! --- inputs: - integer, intent(in) :: im, kdt, nthreads - logical, dimension(:), intent(in) :: wet, icy - integer, dimension(:), intent(in) :: use_lake_model - real (kind=kind_phys), intent(in) :: rlapse, tgice - real (kind=kind_phys), dimension(:), intent(in) :: oro, oro_uf - integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5 - real (kind=kind_phys), dimension(:), intent(in) :: xt, xz, & - & dt_cool, z_c, tref, xlon - -! --- input/outputs: - real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, & - & tsfc_wat - -! --- outputs: - real (kind=kind_phys), dimension(:), intent(out) :: dtzm - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - integer :: i - real(kind=kind_phys) :: zsea1, zsea2 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), -! & ' kdt=',kdt - -! do i = 1, im -! if (wet(i) .and. .not. icy(i)) then -! tsurf_wat(i) = tsurf_wat(i) - (oro(i)-oro_uf(i)) * rlapse -! endif -! enddo - -! --- ... run nsst model ... --- - - if (nstf_name1 > 1) then - zsea1 = 0.001_kp*real(nstf_name4) - zsea2 = 0.001_kp*real(nstf_name5) - call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, & - & im, 1, nthreads, dtzm) - do i = 1, im -! if (wet(i) .and. .not.icy(i)) then -! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then - if (wet(i) .and. use_lake_model(i) /=1) then - tsfc_wat(i) = max(tgice, tref(i) + dtzm(i)) -! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - & -! (oro(i)-oro_uf(i))*rlapse - endif - enddo - endif - -! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt - - return - end subroutine sfc_nst_post_run - - end module sfc_nst_post diff --git a/physics/sfc_nst_pre.f b/physics/sfc_nst_pre.f deleted file mode 100644 index 77ff61f00..000000000 --- a/physics/sfc_nst_pre.f +++ /dev/null @@ -1,96 +0,0 @@ -!> \file sfc_nst_pre.f -!! This file contains preparation for the GFS NSST model. - - module sfc_nst_pre - - contains - -!> \defgroup GFS_NSST_PRE GFS Near-Surface Sea Temperature Pre -!! -!! The NSST scheme is one of the three schemes used to represent the -!! surface in the GFS physics suite. The other two are the Noah land -!! surface model and the sice simplified ice model. -!! -!! \section arg_table_sfc_nst_pre_run Argument Table -!! \htmlinclude sfc_nst_pre_run.html -!! -!> \section NSST_general_pre_algorithm General Algorithm - subroutine sfc_nst_pre_run - & (im, wet, tgice, tsfco, tsurf_wat, - & tseal, xt, xz, dt_cool, z_c, tref, cplflx, - & oceanfrac, nthreads, errmsg, errflg) - - use machine , only : kind_phys - use module_nst_water_prop, only: get_dtzm_2d - - implicit none - - integer, parameter :: kp = kind_phys - -! --- inputs: - integer, intent(in) :: im, nthreads - logical, dimension(:), intent(in) :: wet - real (kind=kind_phys), intent(in) :: tgice - real (kind=kind_phys), dimension(:), intent(in) :: - & tsfco, xt, xz, dt_cool, z_c, oceanfrac - logical, intent(in) :: cplflx - -! --- input/outputs: - real (kind=kind_phys), dimension(:), intent(inout) :: - & tsurf_wat, tseal, tref - -! --- outputs: - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - integer :: i - real(kind=kind_phys), parameter :: zero = 0.0_kp, - & one = 1.0_kp, - & half = 0.5_kp, - & omz1 = 2.0_kp - real(kind=kind_phys) :: tem1, tem2, dnsst - real(kind=kind_phys), dimension(im) :: dtzm, z_c_0 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i=1,im - if (wet(i) .and. oceanfrac(i) > 0.0) then -! tem = (oro(i)-oro_uf(i)) * rlapse - ! DH* 20190927 simplyfing this code because tem is zero - !tem = zero - !tseal(i) = tsfco(i) + tem - tseal(i) = tsfco(i) - !tsurf_wat(i) = tsurf_wat(i) + tem - ! *DH - endif - enddo -! -! update tsfc & tref with T1 from OGCM & NSST Profile if coupled -! - if (cplflx) then - z_c_0 = zero - call get_dtzm_2d (xt, xz, dt_cool, & - & z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm) - do i=1,im - if (wet(i) .and. oceanfrac(i) > zero ) then -! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf - tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile -! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update -! tseal(i) = tsfc_wat(i) - if (abs(xz(i)) > zero) then - tem2 = one / xz(i) - else - tem2 = zero - endif - tseal(i) = tref(i) + (xt(i)+xt(i)) * tem2 - dt_cool(i) - tsurf_wat(i) = tseal(i) - endif - enddo - endif - - return - end subroutine sfc_nst_pre_run - end module sfc_nst_pre diff --git a/physics/smoke_dust/coarsepm_settling_mod.F90 b/physics/smoke_dust/coarsepm_settling_mod.F90 index 9061840c3..b044edb67 100755 --- a/physics/smoke_dust/coarsepm_settling_mod.F90 +++ b/physics/smoke_dust/coarsepm_settling_mod.F90 @@ -8,7 +8,7 @@ module coarsepm_settling_mod CONTAINS -SUBROUTINE coarsepm_settling_driver(dt,t_phy,rel_hum, & +SUBROUTINE coarsepm_settling_driver(dt,t_phy, & chem,rho_phy,dz8w,p8w,p_phy,sedim, & area,g,num_chem, & ids,ide, jds,jde, kds,kde, & @@ -24,7 +24,7 @@ SUBROUTINE coarsepm_settling_driver(dt,t_phy,rel_hum, & its,ite, jts,jte, kts,kte REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),INTENT(INOUT ) :: chem REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: t_phy,p_phy,dz8w,p8w,rho_phy,rel_hum + INTENT(IN ) :: t_phy,p_phy,dz8w,p8w,rho_phy REAL(kind_phys), DIMENSION( ims:ime , jms:jme ),INTENT(IN ) :: area REAL(kind_phys), INTENT(IN ) :: dt,g @@ -64,7 +64,6 @@ SUBROUTINE coarsepm_settling_driver(dt,t_phy,rel_hum, & airmas(1,1,kk)=-(p8w(i,k+1,j)-p8w(i,k,j))*area(i,j)/g airden(1,1,kk)=rho_phy(i,k,j) tmp(1,1,kk)=t_phy(i,k,j) - rh(1,1,kk) = rel_hum(i,k,j) ! hli do nv = 1, num_chem chem_before(i,j,k,nv) = chem(i,k,j,nv) enddo @@ -82,7 +81,7 @@ SUBROUTINE coarsepm_settling_driver(dt,t_phy,rel_hum, & call settling(1, 1, lmx, 1,g,dyn_visc, & dust, tmp, p_mid, delz, airmas, & - den_dust, reff_dust, dt, bstl_dust, rh, idust, airden) + den_dust, reff_dust, dt, bstl_dust, idust, airden) kk = 0 do k = kts,kte @@ -111,7 +110,7 @@ END SUBROUTINE coarsepm_settling_driver subroutine settling(imx,jmx, lmx, nmx,g0,dyn_visc, & tc, tmp, p_mid, delz, airmas, & - den, reff, dt, bstl, rh, idust, airden) + den, reff, dt, bstl, idust, airden) ! **************************************************************************** ! * * ! * Calculate the loss by settling, using an implicit method * @@ -131,7 +130,7 @@ subroutine settling(imx,jmx, lmx, nmx,g0,dyn_visc, & INTEGER :: ntdt REAL(kind_phys), INTENT(IN) :: dt,g0,dyn_visc REAL(kind_phys), INTENT(IN) :: tmp(imx,jmx,lmx), delz(imx,jmx,lmx), & - airmas(imx,jmx,lmx), rh(imx,jmx,lmx), & + airmas(imx,jmx,lmx), & den(nmx), reff(nmx),p_mid(imx,jmx,lmx),& airden(imx,jmx,lmx) REAL(kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) diff --git a/physics/smoke_dust/dep_data_mod.F90 b/physics/smoke_dust/dep_data_mod.F90 new file mode 100755 index 000000000..bf9ae7f0c --- /dev/null +++ b/physics/smoke_dust/dep_data_mod.F90 @@ -0,0 +1,193 @@ +!>\file dep_data_mod.F90 +!! This file contains data for the dry deposition modules. +module dep_data_mod + + use machine , only : kind_phys + + integer, parameter :: nvegtype = 25 + real(kind_phys), dimension(nvegtype), parameter :: & + kpart = (/500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500. /) + real(kind_phys), parameter :: max_dep_vel = 0.005 ! m/s (may need to set per species) + real(kind_phys), parameter :: dep_ref_hgt = 2.0 ! Meters + real(kind_phys), parameter :: pi = 3.1415926536 +! 3*PI + REAL(kind_phys), PARAMETER :: threepi=3.0*pi + real(kind_phys), parameter :: gravity = 9.81 +! mean gravitational acceleration [ m/sec**2 ] + REAL(kind_phys), PARAMETER :: grav=9.80622 + real(kind_phys), parameter :: boltzmann = 1.3807e-16 +! universal gas constant [ J/mol-K ] + REAL(kind_phys), PARAMETER :: rgasuniv=8.314510 +! Avogadro's Constant [ 1/mol ] + REAL, PARAMETER :: avo=6.0221367E23 + ! Boltzmann's Constant [ J / K ]i\ + REAL(kind_phys), PARAMETER :: boltz=rgasuniv/avo + real(kind_phys), parameter :: Cb = 2., Cim = 0.4, alpha = 0.8, Cin = 2.5, vv = 0.8 + real(kind_phys), parameter :: A_for = 0.1 ! forest + real(kind_phys), parameter :: A_grs = 0.2 ! grass + real(kind_phys), parameter :: A_wat = 100. ! water + real(kind_phys), parameter :: eps0_for = 0.8*0.01 ! forest + real(kind_phys), parameter :: eps0_grs = 0.4*0.01 ! grass + real(kind_phys), parameter :: eps0_wat = 0.6*0.01 ! water + + REAL(kind_phys), PARAMETER :: one3=1.0/3.0 + REAL(kind_phys), PARAMETER :: two3=2.0/3.0 +! SQRT( 2 ) + REAL(kind_phys), PARAMETER :: sqrt2=1.4142135623731 +! SQRT( PI ) + REAL(kind_phys), PARAMETER :: sqrtpi=1.7724539 + REAL(kind_phys) :: karman = 0.4 ! von Karman constant + REAL(kind_phys), PARAMETER :: conmin= 1.E-16 + REAL(kind_phys), PARAMETER :: pirs=3.14159265358979324 + REAL(kind_phys), PARAMETER :: f6dpi=6.0/pirs + REAL(kind_phys), PARAMETER :: f6dpim9=1.0E-9*f6dpi + REAL(kind_phys), PARAMETER :: rhosmoke = 1.4E3 + REAL(kind_phys), PARAMETER :: rhodust = 2.6E3 + REAL(kind_phys), PARAMETER :: smokefac=f6dpim9/rhosmoke + REAL(kind_phys), PARAMETER :: dustfac=f6dpim9/rhodust +! starting standard surface temperature [ K ] + REAL(kind_phys), PARAMETER :: tss0=288.15 + REAL(kind_phys), PARAMETER :: sigma1 = 1.8 + REAL(kind_phys), PARAMETER :: mean_diameter1 = 4.e-8 + REAL(kind_phys), PARAMETER :: fact_wfa = 1.e-9*6.0/pirs*exp(4.5*log(sigma1)**2)/mean_diameter1**3 + REAL(kind_phys), PARAMETER :: sginia=2.00 +! initial sigma-G for nucleimode + REAL(kind_phys), PARAMETER :: sginin=1.70 +! initial sigma-G for coarse mode + REAL(kind_phys), PARAMETER :: sginic=2.5 +! starting standard surface pressure [ Pa ] + REAL(kind_phys), PARAMETER :: pss0=101325.0 +! lowest particle diameter ( m ) + REAL(kind_phys), PARAMETER :: dgmin=1.0E-09 +! lowest particle density ( Kg/m**3 ) + REAL(kind_phys), PARAMETER :: densmin=1.0E03 +! index for Aitken mode number + INTEGER, PARAMETER :: vdnnuc=1 +! index for accumulation mode number + INTEGER, PARAMETER :: vdnacc=2 +! index for coarse mode number + INTEGER, PARAMETER :: vdncor=3 +! index for Aitken mode mass + INTEGER, PARAMETER :: vdmnuc=4 +! index for accumulation mode + INTEGER, PARAMETER :: vdmacc=5 +! index for fine mode mass (Aitken + accumulation) + INTEGER, PARAMETER :: vdmfine=6 +! index for coarse mode mass + INTEGER, PARAMETER :: vdmcor=7 +! index for Aitken mode number + INTEGER, PARAMETER :: vsnnuc=1 +! index for Accumulation mode number + INTEGER, PARAMETER :: vsnacc=2 +! index for coarse mode number + INTEGER, PARAMETER :: vsncor=3 +! index for Aitken mode mass + INTEGER, PARAMETER :: vsmnuc=4 +! index for accumulation mode mass + INTEGER, PARAMETER :: vsmacc=5 +! index for coarse mass + INTEGER, PARAMETER :: vsmcor=6 +! coarse mode exp( log^2( sigmag )/8 ) +! nuclei **4 + REAL(kind_phys) :: esn04 +! accumulation + REAL(kind_phys) :: esa04 + REAL(kind_phys) :: esc04 +! coarse +! nuclei **5 + REAL(kind_phys) :: esn05 + REAL(kind_phys) :: esa05 +! accumulation +! nuclei **8 + REAL(kind_phys) :: esn08 +! accumulation + REAL(kind_phys) :: esa08 + REAL(kind_phys) :: esc08 +! coarse +! nuclei **9 + REAL(kind_phys) :: esn09 + REAL(kind_phys) :: esa09 +! accumulation +! nuclei **12 + REAL(kind_phys) :: esn12 +! accumulation + REAL(kind_phys) :: esa12 + REAL(kind_phys) :: esc12 +! coarse mode +! nuclei **16 + REAL(kind_phys) :: esn16 +! accumulation + REAL(kind_phys) :: esa16 + REAL(kind_phys) :: esc16 +! coarse +! nuclei **20 + REAL(kind_phys) :: esn20 +! accumulation + REAL(kind_phys) :: esa20 + REAL(kind_phys) :: esc20 +! coarse +! nuclei **25 + REAL(kind_phys) :: esn25 + REAL(kind_phys) :: esa25 +! accumulation +! nuclei **24 + REAL(kind_phys) :: esn24 +! accumulation + REAL(kind_phys) :: esa24 + REAL(kind_phys) :: esc24 +! coarse +! nuclei **28 + REAL(kind_phys) :: esn28 +! accumulation + REAL(kind_phys) :: esa28 + REAL(kind_phys) :: esc28 +! coarse +! nuclei **32 + REAL(kind_phys) :: esn32 +! accumulation + REAL(kind_phys) :: esa32 + REAL(kind_phys) :: esc32 +! coarese +! nuclei **36 + REAL(kind_phys) :: esn36 +! accumulation + REAL(kind_phys) :: esa36 + REAL(kind_phys) :: esc36 +! coarse +! nuclei **49 + REAL(kind_phys) :: esn49 + REAL(kind_phys) :: esa49 +! accumulation +! nuclei **52 + REAL(kind_phys) :: esn52 + REAL(kind_phys) :: esa52 +! accumulation +! nuclei **64 + REAL(kind_phys) :: esn64 +! accumulation + REAL(kind_phys) :: esa64 + REAL(kind_phys) :: esc64 +! coarse + REAL(kind_phys) :: esn100 +! nuclei **100 +! nuclei **(-20) + REAL(kind_phys) :: esnm20 +! accumulation + REAL(kind_phys) :: esam20 + REAL(kind_phys) :: escm20 +! coarse +! nuclei **(-32) + REAL(kind_phys) :: esnm32 +! accumulation + REAL(kind_phys) :: esam32 + REAL(kind_phys) :: escm32 +!SAM 10/08 Gaussian quadrature constants for SOA_VBS deposition numerical +!integration + INTEGER, PARAMETER :: NGAUSdv= 7 ! Number of Gaussian Quadrature Points + REAL(kind_phys) :: xxlsgn, xxlsga, xxlsgc + REAL(kind_phys) :: Y_GQ(NGAUSdv), WGAUS(NGAUSdv) +end module dep_data_mod diff --git a/physics/smoke_dust/dep_dry_mod_emerson.F90 b/physics/smoke_dust/dep_dry_mod_emerson.F90 new file mode 100755 index 000000000..76fdc2411 --- /dev/null +++ b/physics/smoke_dust/dep_dry_mod_emerson.F90 @@ -0,0 +1,361 @@ +!>\file dep_dry_mod.F90 +!! This file is for the dry depostion driver. +!-------------REVISION HISTORY---------------! +! XX/XX/XXXX : original implementation (Ravan Ahmadov) +! 08/17/2023 : modified to follow Emerson et al., (2020) (Jordan Schnell) +! 08/17/2023 : gravitational settling folowing the coarse pm settling driver (Jordan Schnell) + +module dep_dry_emerson_mod + + use machine , only : kind_phys + use dep_data_mod ! JLS + use rrfs_smoke_config, only : num_chem, p_smoke, p_dust_1, p_coarse_pm + + implicit none + + private + + public :: dry_dep_driver_emerson + +contains + subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & + chem,delz,snowh,t_phy,p_phy,rho_phy,ivgtyp,g0,dt, & + settling_flag,drydep_flux,settling_flux,dbg_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +! compute dry deposition velocity for aerosol particles +! Based on Emerson et al. (2020), PNAS, +! www.pnas.org/cgi/doi/10.1073/pnas.2014761117 +! Code adapted from Hee-Ryu and Min, (2022): +! https://agupubs.onlinelibrary.wiley.com/doi/epdf/10.1029/2021MS002792 +!---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: settling_flag,ndvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN) :: ustar, rmol, znt, snowh + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: t_phy, rho_phy, p_phy, delz + INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: ivgtyp + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL(kind_phys), INTENT(IN) :: g0,dt + LOGICAL, INTENT(IN) :: dbg_opt + ! + ! Output arrays + REAL(kind_phys), DIMENSION( ims:ime, jms:jme, ndvel ), INTENT(INOUT) :: ddvel + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, ndvel), & + INTENT(OUT) :: vgrav + REAL(kind_phys), DIMENSION( ims:ime, jms:jme, ndvel ), INTENT(OUT) :: settling_flux, drydep_flux + ! Local + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) :: aer_res + REAL(kind_phys), DIMENSION( ndvel ) :: cblk + ! Modpar variables, mass, density, diameter, knudsen number, mean free path + REAL(kind_phys) :: pmasssn,pmassa,pmassc,pdensn,pdensa,pdensc, & + dgnuc,dgacc,dgcor,knnuc,knacc,kncor,xlm + real(kind_phys) :: Cc ! Cunningham/slip correction factor [-] + real(kind_phys) :: DDp, Eb ! Brownian diffusion [] + real(kind_phys) :: Eim ! Impaction [] + real(kind_phys) :: Ein ! Interception [] + real(kind_phys) :: Sc ! Schmit number [] + real(kind_phys) :: St ! Stokes number [] + real(kind_phys) :: vg ! gravitational settling [cm/s] + real(kind_phys) :: A, eps0, dumalnsg ! land surface params [-] + real(kind_phys) :: amu, amu_corrected ! dynamic viscosity [g/s] + real(kind_phys) :: airkinvisc ! Air kinetic viscosity [cm2/s] + real(kind_phys) :: freepath ! Air molecular freepath [cm] + real(kind_phys) :: dp ! aerosol diameter [cm] + real(kind_phys) :: aerodens ! aerosol density [g/cm3] + real(kind_phys) :: Rs ! Surface resistance + real(kind_phys) :: vgpart + real(kind_phys) :: growth_fac,vsettl,dtmax,conver,converi,dzmin + real(kind_phys) :: rmol_local + real(kind_phys), dimension( kts:kte) :: rho_col, delz_col + real(kind_phys), dimension(ndvel) :: dt_settl, chem_before, chem_after + real(kind_phys), dimension( kts:kte, ndvel ) :: cblk_col, vg_col + integer, dimension(ndvel) :: ndt_settl + integer :: i, j, k, ntdt, nv + ! chem pointers (p_*) are not sequentially numbered, need to define so nv loops work + integer, dimension(ndvel) :: chem_pointers +!> -- Gas constant + real(kind_phys), parameter :: RSI = 8.314510 + chem_pointers(1) = p_smoke + chem_pointers(2) = p_dust_1 + chem_pointers(3) = p_coarse_pm + + growth_fac = 1.0 + conver=1.e-9 + converi=1.e9 + + do j = jts, jte + do i = its, ite + aer_res(i,j) = 0.0 + rmol_local = rmol(i,j) + do k = kts, kte + delz_col(k) = delz(i,k,j) + rho_col(k) = rho_phy(i,k,j) + do nv = 1, ndvel + cblk(nv) = chem(i,k,j,chem_pointers(nv)) + if ( k == kts ) then + ddvel(i,j,nv) = 0.0 + dt_settl(nv) = 0.0 + endif ! k==kts + end do ! nv + ! *** U.S. Standard Atmosphere 1962 page 14 expression + ! for dynamic viscosity = beta * T * sqrt(T) / ( T + S) + ! where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ]. + amu = 1.458E-6 * t_phy(i,k,j) * sqrt(t_phy(i,k,j)) / ( t_phy(i,k,j) + 110.4 ) + ! Aerodynamic resistance + call depvel( rmol_local, dep_ref_hgt, znt(i,j), ustar(i,j), vgpart, aer_res(i,j) ) + ! depvel uses meters, need to convert to s/cm + aer_res(i,j) = max(aer_res(i,j)/100._kind_phys,0._kind_phys) + ! Air kinematic viscosity (cm^2/s) + airkinvisc = ( 1.8325e-4 * ( 416.16 / ( t_phy(i,k,j) + 120.0 ) ) * & + ( ( t_phy(i,k,j) / 296.16 )**1.5 ) ) / ( rho_phy(i,k,j) / 28.966e3 ) ! Convert density to mol/cm^3 + ! Air molecular freepath (cm) ! Check against XLM from above + freepath = 7.39758e-4 * airkinvisc / sqrt( t_phy(i,k,j) ) + do nv = 1, ndvel + if ( chem_pointers(nv) == p_smoke ) then + dp = 4.E-8 !dgacc + aerodens = 1.4e+3 !pdensa + elseif ( chem_pointers(nv) == p_dust_1) then + dp = 1.E-6 !dgacc + aerodens = 2.6e+3 !pdensa + elseif ( chem_pointers(nv) == p_coarse_pm ) then + dp = 4.5E-6 !dgcor + aerodens = 2.6e+3 !pdensc + else + continue + endif + ! Convert diameter to cm and aerodens to g/cm3 + aerodens = aerodens / 1000. + dp = dp * 1e+2 + ! Cunningham correction factor + Cc = 1. + 2. * freepath / dp * ( 1.257 + 0.4*exp( -0.55 * dp / freepath ) ) + ! Corrected dynamic viscosity (used for settling) + amu_corrected = amu / Cc + ! Gravitational Settling + vg = aerodens * dp * dp * gravity * 100. * Cc / & ! Convert gravity to cm/s^2 + ( 18. * airkinvisc * ( rho_phy(i,k,j) / 28.966e3 ) ) ! Convert density to mol/cm^3 + ! -- Rest of loop for the surface when deposition velocity needs to be cacluated + if ( k == kts ) then + ! Brownian Diffusion + DDp = ( boltzmann * t_phy(i,k,j) ) * Cc / (3. * pi * airkinvisc * ( rho_phy(i,k,j) / 28.966e3 ) * dp) ! Convert density to mol/cm^3 + ! Schmit number + Sc = airkinvisc / DDp + ! Brownian Diffusion + Eb = Cb * Sc**(-0.666666667) + ! Stokes number + St = ( 100. * ustar(i,j) ) * ( 100.* ustar(i,j) ) * vg / airkinvisc / ( gravity * 100.) ! Convert ustar to cm/s, gravity to cm/s^2 + ! Impaction + Eim = Cim * ( St / ( alpha + St ) )**1.7 + ! MODIS type lu, large roughness lengths (e.g., urban or forest) + ! ----------------------------------------------------------------------- + ! *** TO DO -- set A and eps0 for all land surface types *** !!! + ! ----------------------------------------------------------------------- + if ( ivgtyp(i,j) .eq. 13 .or. ivgtyp(i,j) .le. 5 ) then ! Forest + A = A_for + eps0 = eps0_for + else if ( ivgtyp(i,j) .eq. 17 ) then ! water + A = A_wat + eps0 = eps0_wat + else ! otherwise + A = A_grs + eps0 = eps0_grs + end if + ! Set if snow greater than 1 cm +! if ( snowh(i,j) .gt. 0.01 ) then ! snow +! A = A_wat +! eps0 = eps0_wat +! endif + ! Interception + Ein = Cin * ( dp / A )**vv + ! Surface resistance + Rs = 1. / ( ( ustar(i,j) * 100.) * ( Eb + Eim + Ein) * eps0 ) ! Convert ustar to cm/s + ! Compute final ddvel = aer_res + RS, set max at max_dep_vel in dep_data_mod.F[ m/s] + ! The /100. term converts from cm/s to m/s, required for MYNN. + ddvel(i,j,nv) = min( (1. / (aer_res(i,j) + Rs ))/100., max_dep_vel) + if ( dbg_opt ) then + WRITE(6,*) 'dry_dep_mod_emerson: i,j,nv',i,j,nv + WRITE(6,*) 'dry_dep_mod_emerson: deposition velocity (m/s) ',ddvel(i,j,nv) + endif + drydep_flux(i,j,nv) = chem(i,kts,j,chem_pointers(nv))*p_phy(i,kts,j) / & + (RSI*t_phy(i,kts,j))*ddvel(i,j,nv)*dt*1.E-6 + endif ! k == kts + vgrav(i,k,j,nv) = vg + ! Fill column variables + cblk_col(k,nv) = cblk(nv) + vg_col(k,nv) = vg + enddo ! nv + enddo ! k + ! -- Get necessary info for settling + ! -- Determine the maximum time-step satisying the CFL condition: + dzmin = minval(delz_col) + ntdt=INT(dt) + do nv = 1, ndvel + ! -- NOTE, diameters and densities are NOT converted to cm and g/cm3 like above + ! -- dt_settl calculations (from original coarsepm_settling) + if ( chem_pointers(nv) == p_smoke ) then + dp = 4.E-8 !dgacc + aerodens = 1.4e+3 !pdensa + elseif ( chem_pointers(nv) == p_dust_1) then + dp = 1.E-6 !dgacc + aerodens = 2.6e+3 !pdensa + elseif ( chem_pointers(nv) == p_coarse_pm ) then + dp = 4.5E-6 !dgcor + aerodens = 2.6e+3 !pdensc + else + continue + endif + ! 1.5E-5 = dyn_visc --> dust_data_mod.F90 + vsettl = 2.0 / 9.0 * g0 * aerodens * ( growth_fac * ( 0.5 * dp ))**2.0 / ( 0.5 * 1.5E-5 ) + dtmax = dzmin / vsettl + ndt_settl(nv) = MAX( 1, INT( ntdt /dtmax) ) + ! Limit maximum number of iterations + IF (ndt_settl(nv) > 12) ndt_settl(nv) = 12 + dt_settl(nv) = REAL(ntdt,kind=kind_phys) /REAL(ndt_settl(nv),kind=kind_phys) + enddo + do nv = 1, ndvel + chem_before(nv) = 0._kind_phys + do k = kts, kte + chem_before(nv) = chem_before(nv) + (cblk_col(k,nv) * rho_phy(i,k,j) * delz(i,k,j) ) ! ug/m2 + enddo + enddo + ! Perform gravitational settling if desired + if ( settling_flag == 1 ) then + call particle_settling(cblk_col,rho_col,delz_col,vg_col,dt_settl,ndt_settl,ndvel,kts,kte) + endif + ! Put cblk back into chem array + do nv= 1, ndvel + chem_after(nv) = 0._kind_phys + settling_flux(i,j,nv) = 0._kind_phys + do k = kts, kte + chem(i,k,j,chem_pointers(nv)) = cblk_col(k,nv) + chem_after(nv) = chem_after(nv) + (cblk_col(k,nv) * rho_phy(i,k,j) * delz(i,k,j) ) ! ug/m2 + enddo ! k + settling_flux(i,j,nv) = settling_flux(i,j,nv) + (chem_before(nv) - chem_after(nv)) ! ug/m2 + enddo ! nv + end do ! j + end do ! i +end subroutine dry_dep_driver_emerson +! +!-------------------------------------------------------------------------------- +! +subroutine depvel( rmol, zr, z0, ustar, vgpart, aer_res ) +!-------------------------------------------------- +! THIS FUNCTION HAS BEEN DESIGNED TO EVALUATE AN UPPER LIMIT +! FOR THE POLLUTANT DEPOSITION VELOCITY AS A FUNCTION OF THE +! SURFACE ROUGHNESS AND METEOROLOGICAL CONDITIONS. +! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) +! Modified by Darrell A. Winner (Feb. 1991) +! by Winfried Seidl (Aug. 1997) +!.....PROGRAM VARIABLES... +! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH +! ZR - REFERENCE HEIGHT +! Z0 - SURFACE ROUGHNESS HEIGHT +! USTAR - FRICTION VELOCITY U* +! AER_RES - AERODYNAMIC RESISTANCE +!.....REFERENCES... +! MCRAE, G.J. ET AL. (1983) MATHEMATICAL MODELING OF PHOTOCHEMICAL +! AIR POLLUTION, ENVIRONMENTAL QUALITY LABORATORY REPORT 18, +! CALIFORNIA INSTITUTE OF TECHNOLOGY, PASADENA, CALIFORNIA. +!.....RESTRICTIONS... +! 1. THE MODEL EDDY DIFFUSIVITIES ARE BASED ON MONIN-OBUKHOV +! SIMILARITY THEORY AND SO ARE ONLY APPLICABLE IN THE +! SURFACE LAYER, A HEIGHT OF O(30M). +! 2. ALL INPUT UNITS MUST BE CONSISTENT +! 3. THE PHI FUNCTIONS USED TO CALCULATE THE FRICTION +! VELOCITY U* AND THE POLLUTANT INTEGRALS ARE BASED +! ON THE WORK OF BUSINGER ET AL.(1971). +! 4. THE MOMENTUM AND POLLUTANT DIFFUSIVITIES ARE NOT +! THE SAME FOR THE CASES L<0 AND L>0. +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + REAL(kind_phys), intent(in) :: ustar, z0, zr + REAL(kind_phys), intent(out) :: vgpart, aer_res + REAL(kind_phys), intent(inout) :: rmol +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: l + REAL(kind_phys) :: ao, ar, polint, vk +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC alog +!-------------------------------------------------- +! Set the von Karman constant +!-------------------------------------------------- + vk = karman +!-------------------------------------------------- +! DETERMINE THE STABILITY BASED ON THE CONDITIONS +! 1/L < 0 UNSTABLE +! 1/L = 0 NEUTRAL +! 1/L > 0 STABLE +!-------------------------------------------------- + if(abs(rmol) < 1.E-6 ) rmol = 0. + IF (rmol<0) THEN + ar = ((1.0-9.0*zr*rmol)**(0.25)+0.001)**2 + ao = ((1.0-9.0*z0*rmol)**(0.25)+0.001)**2 + polint = 0.74*(alog((ar-1.0)/(ar+1.0))-alog((ao-1.0)/(ao+1.0))) + ELSE IF (rmol==0.) THEN + polint = 0.74*alog(zr/z0) + ELSE + polint = 0.74_kind_phys*alog(zr/z0) + 4.7_kind_phys*rmol*(zr-z0) + END IF + vgpart = ustar*vk/polint + aer_res = polint/(karman*max(ustar,1.0e-4)) +end subroutine depvel +! +!-------------------------------------------------------------------------------- +! +! +!-------------------------------------------------------------------------------- +! +subroutine particle_settling(cblk,rho_phy,delz,vg,dt_settl,ndt_settl,ndvel,kts,kte) + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: kts, kte, ndvel + REAL(kind_phys), DIMENSION(kts:kte), INTENT (IN) :: rho_phy, delz + REAL(kind_phys), DIMENSION(kts:kte,ndvel), INTENT(IN) :: vg + REAL(kind_phys), DIMENSION(kts:kte,ndvel), INTENT(INOUT) :: cblk + REAL(kind_phys), DIMENSION(ndvel), INTENT(IN) :: dt_settl + INTEGER, DIMENSION(ndvel), INTENT(IN) :: ndt_settl +! +!--- Local------ + INTEGER :: k,nv,n,l2 + REAL(kind_phys) :: temp_tc, transfer_to_below_level, vd_wrk1 + REAL(kind_phys), DIMENSION(kts:kte) :: delz_flip + + do k = kts,kte + delz_flip(k) = delz(kte-k+kts) + enddo + + do nv = 1, ndvel + do n = 1,ndt_settl(nv) + transfer_to_below_level = 0.0 + do k = kte,kts,-1 + l2 = kte - k + 1 + + temp_tc = cblk(k,nv) + + vd_wrk1 = dt_settl(nv) * vg(k,nv)/100. / delz_flip(l2) ! convert vg to m/s + + cblk(k,nv)= cblk(k,nv) * (1. - vd_wrk1) + transfer_to_below_level + if (k.gt.kts) then + transfer_to_below_level =(temp_tc*vd_wrk1)*((delz_flip(l2) & + *rho_phy(k))/(delz_flip(l2+1)*rho_phy(k-1))) ! [ug/kg] + endif + enddo ! k + enddo ! n + enddo ! nv +end subroutine particle_settling + +! +end module dep_dry_emerson_mod diff --git a/physics/smoke_dust/dep_dry_mod.F90 b/physics/smoke_dust/dep_dry_simple_mod.F90 similarity index 77% rename from physics/smoke_dust/dep_dry_mod.F90 rename to physics/smoke_dust/dep_dry_simple_mod.F90 index ea7dd9963..e47d3d974 100755 --- a/physics/smoke_dust/dep_dry_mod.F90 +++ b/physics/smoke_dust/dep_dry_simple_mod.F90 @@ -1,7 +1,7 @@ -!>\file dep_dry_mod.F90 +!>\file dep_dry_simple_mod.F90 !! This file is for the dry depostion driver. -module dep_dry_mod +module dep_dry_simple_mod use machine , only : kind_phys @@ -9,11 +9,11 @@ module dep_dry_mod private - public :: dry_dep_driver + public :: dry_dep_driver_simple contains - subroutine dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & + subroutine dry_dep_driver_simple(rmol,ust,ndvel,ddvel, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -26,8 +26,6 @@ subroutine dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & its,ite, jts,jte, kts,kte REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & INTENT(INOUT) :: ust, rmol - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: rel_hum REAL(kind_phys), PARAMETER :: kpart=500. REAL(kind_phys) :: dvpart @@ -56,14 +54,11 @@ subroutine dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & dvpart = dvpart*(1.+(-300.*rmol(i,j))**0.66667) ENDIF - IF (rel_hum(i,1,j)>0.8) THEN ! HIGH RELATIVE HUMIDITY CORRECTION - dvpart = dvpart*(1.+0.37*exp((rel_hum(i,1,j)-0.8)/0.2)) - END IF ddvel(i,j,nv) = MIN(0.50,dvpart) ! m/s enddo enddo enddo -end subroutine dry_dep_driver +end subroutine dry_dep_driver_simple -end module dep_dry_mod +end module dep_dry_simple_mod diff --git a/physics/smoke_dust/dust_data_mod.F90 b/physics/smoke_dust/dust_data_mod.F90 index a710701f1..eb809378d 100755 --- a/physics/smoke_dust/dust_data_mod.F90 +++ b/physics/smoke_dust/dust_data_mod.F90 @@ -44,24 +44,10 @@ module dust_data_mod ! Never used: ! real(kind_phys), parameter :: fengsha_alpha = 0.3 ! real(kind_phys), parameter :: fengsha_gamma = 1.3 + ! -- FENGSHA threshold velocities based on Dale A. Gillette's data integer, parameter :: fengsha_maxstypes = 13 -! real(kind_phys), dimension(fengsha_maxstypes) :: dust_uthres = & -! (/ 0.065, & ! Sand - 1 -! 0.20, & ! Loamy Sand - 2 -! 0.52, & ! Sandy Loam - 3 -! 0.50, & ! Silt Loam - 4 -! 0.50, & ! Silt - 5 -! 0.60, & ! Loam - 6 -! 0.73, & ! Sandy Clay Loam - 7 -! 0.73, & ! Silty Clay Loam - 8 -! 0.80, & ! Clay Loam - 9 -! 0.95, & ! Sandy Clay - 10 -! 0.95, & ! Silty Clay - 11 -! 1.00, & ! Clay - 12 -! 9.999 /) ! Other - 13 -! dust_uthres = 0.065, 0.18, 0.27, 0.30, 0.35, 0.38, 0.35, 0.41, 0.41, -! 0.45,0.50,0.45,9999.0 + real(kind_phys), dimension(fengsha_maxstypes), parameter :: dust_uthres = & (/ 0.065, & ! Sand - 1 0.18, & ! Loamy Sand - 2 @@ -76,12 +62,16 @@ module dust_data_mod 0.50, & ! Silty Clay - 11 0.45, & ! Clay - 12 9999.0 /) ! Other - 13 - ! -- FENGSHA uses precalculated drag partition from ASCAT. See: Prigent et al. (2012,2015) - integer, parameter :: dust_calcdrag = 1 - real(kind_phys) :: dust_alpha = 2.2 + ! -- FENGSHA uses precalculated drag partition + integer, parameter :: dust_calcdrag = 1 + ! -- FENGSHA dust moisture parameterization 1:fecan - 2:shao + integer :: dust_moist_opt = 1 + + real(kind_phys) :: dust_alpha = 1.0 real(kind_phys) :: dust_gamma = 1.0 - + real(kind_phys) :: dust_moist_correction = 1.0 + real(kind_phys) :: dust_drylimit_factor = 1.0 ! -- sea salt parameters integer, dimension(nsalt), parameter :: spoint = (/ 1, 2, 2, 2, 2, 2, 3, 3, 3 /) ! 1 Clay, 2 Silt, 3 Sand @@ -93,7 +83,7 @@ module dust_data_mod (/ 1., 0.2, 0.2, 0.2, 0.2, 0.2, 0.333, 0.333, 0.333 /) - ! -- soil vagatation parameters + ! -- soil vegatation parameters integer, parameter :: max_soiltyp = 30 real(kind_phys), dimension(max_soiltyp), parameter :: & maxsmc = (/ 0.421, 0.464, 0.468, 0.434, 0.406, 0.465, & diff --git a/physics/smoke_dust/dust_fengsha_mod.F90 b/physics/smoke_dust/dust_fengsha_mod.F90 index 54a64239d..54e66712d 100755 --- a/physics/smoke_dust/dust_fengsha_mod.F90 +++ b/physics/smoke_dust/dust_fengsha_mod.F90 @@ -22,7 +22,7 @@ module dust_fengsha_mod subroutine gocart_dust_fengsha_driver(dt, & chem,rho_phy,smois,p8w,ssm, & - isltyp,vegfra,snowh,xland,area,g,emis_dust, & + isltyp,snowh,xland,area,g,emis_dust, & ust,znt,clay,sand,rdrag,uthr, & num_emis_dust,num_chem,num_soil_layers, & ids,ide, jds,jde, kds,kde, & @@ -37,7 +37,6 @@ subroutine gocart_dust_fengsha_driver(dt, & ! 2d input variables REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ssm ! Sediment supply map - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: vegfra ! vegetative fraction (-) REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: snowh ! snow height (m) REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: xland ! dominant land use type REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: area ! area of grid cell @@ -61,6 +60,8 @@ subroutine gocart_dust_fengsha_driver(dt, & REAL(kind_phys), INTENT(IN) :: dt ! time step REAL(kind_phys), INTENT(IN) :: g ! gravity (m/s**2) + + ! Local variables integer :: nmx,i,j,k,imx,jmx,lmx integer :: ilwi @@ -75,6 +76,7 @@ subroutine gocart_dust_fengsha_driver(dt, & real(kind_phys), DIMENSION (num_emis_dust) :: distribution real(kind_phys), dimension (3) :: massfrac real(kind_phys) :: erodtot + real(kind_phys) :: moist_volumetric ! conversion values conver=1.e-9 @@ -138,9 +140,6 @@ subroutine gocart_dust_fengsha_driver(dt, & endif ! limit where there is lots of vegetation - if (vegfra(i,j) .gt. .17) then - ilwi = 0 - endif ! limit where there is snow on the ground if (snowh(i,j) .gt. 0) then @@ -174,10 +173,13 @@ subroutine gocart_dust_fengsha_driver(dt, & endif endif + ! soil moisture correction factor + moist_volumetric = dust_moist_correction * smois(i,2,j) + ! Call dust emission routine. call source_dust(imx,jmx, lmx, nmx, dt, tc, ustar, massfrac, & - erodtot, dxy, smois(i,1,j), airden, airmas, bems, g, dust_alpha, dust_gamma, & + erodtot, dxy, moist_volumetric, airden, airmas, bems, g, dust_alpha, dust_gamma, & R, uthr(i,j)) ! convert back to concentration @@ -457,10 +459,16 @@ subroutine DustEmissionFENGSHA(slc, clay, sand, silt, & ! Now compute size-dependent total emission flux ! ---------------------------------------------- - ! Fecan moisture correction - ! ------------------------- - h = moistureCorrectionFecan(slc, sand, clay, rhop) - + + if (dust_moist_opt .eq. 1) then + + ! Fecan moisture correction + ! ------------------------- + h = moistureCorrectionFecan(slc, sand, clay) + else + ! shao soil moisture correction + h = moistureCorrectionShao(slc) + end if ! Adjust threshold ! ---------------- u_thresh = uthrs * h @@ -478,7 +486,7 @@ subroutine DustEmissionFENGSHA(slc, clay, sand, silt, & end subroutine DustEmissionFENGSHA !----------------------------------------------------------------- - real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop) + real function soilMoistureConvertVol2Grav(vsoil, sandfrac) ! !USES: implicit NONE @@ -486,7 +494,6 @@ real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop) ! !INPUT PARAMETERS: REAL(kind_phys), intent(in) :: vsoil ! volumetric soil moisture fraction [1] REAL(kind_phys), intent(in) :: sandfrac ! fractional sand content [1] - REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3] ! !DESCRIPTION: Convert soil moisture fraction from volumetric to gravimetric. ! @@ -500,20 +507,21 @@ real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop) ! !CONSTANTS: REAL(kind_phys), parameter :: rhow = 1000. ! density of water [kg m-3] - + REAL(kind_phys), parameter :: rhop = 1700. ! density of dry soil !EOP !------------------------------------------------------------------------- ! Begin... ! Saturated volumetric water content (sand-dependent) ! [m3 m-3] - vsat = 0.489 - 0.00126 * ( 100. * sandfrac ) + vsat = 0.489 - 0.126 * sandfrac + ! Gravimetric soil content - soilMoistureConvertVol2Grav = vsoil * rhow / (rhop * (1. - vsat)) + soilMoistureConvertVol2Grav = 100.0 * (vsoil * rhow / rhop / ( 1. - vsat)) end function soilMoistureConvertVol2Grav !---------------------------------------------------------------- - real function moistureCorrectionFecan(slc, sand, clay, rhop) + real function moistureCorrectionFecan(slc, sand, clay) ! !USES: implicit NONE @@ -522,7 +530,6 @@ real function moistureCorrectionFecan(slc, sand, clay, rhop) REAL(kind_phys), intent(in) :: slc ! liquid water content of top soil layer, volumetric fraction [1] REAL(kind_phys), intent(in) :: sand ! fractional sand content [1] REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] - REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3] ! !DESCRIPTION: Compute correction factor to account for Fecal soil moisture ! @@ -540,15 +547,46 @@ real function moistureCorrectionFecan(slc, sand, clay, rhop) ! Begin... ! Convert soil moisture from volumetric to gravimetric - grvsoilm = soilMoistureConvertVol2Grav(slc, sand, 2650.) + grvsoilm = soilMoistureConvertVol2Grav(slc, sand) ! Compute fecan dry limit - drylimit = clay * (14.0 * clay + 17.0) + drylimit = dust_drylimit_factor * clay * (14.0 * clay + 17.0) ! Compute soil moisture correction moistureCorrectionFecan = sqrt(1.0 + 1.21 * max(0., grvsoilm - drylimit)**0.68) end function moistureCorrectionFecan +!---------------------------------------------------------------- + real function moistureCorrectionShao(slc) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: slc ! liquid water content of top soil layer, volumetric fraction [1] + +! !DESCRIPTION: Compute correction factor to account for Fecal soil moisture +! +! !REVISION HISTORY: +! +! 02Apr2020, B.Baker/NOAA - Original implementation +! 01Apr2020, R.Montuoro/NOAA - Adapted for GOCART process library + +! !Local Variables + real :: grvsoilm + real :: drylimit + +!EOP +!--------------------------------------------------------------- +! Begin... + + if (slc < 0.03) then + moistureCorrectionShao = exp(22.7 * slc) + else + moistureCorrectionShao = exp(95.3 * slc - 2.029) + end if + + end function moistureCorrectionShao !--------------------------------------------------------------- real function DustFluxV2HRatioMB95(clay, kvhmax) diff --git a/physics/smoke_dust/module_add_emiss_burn.F90 b/physics/smoke_dust/module_add_emiss_burn.F90 index 6cdd2e071..95005b973 100755 --- a/physics/smoke_dust/module_add_emiss_burn.F90 +++ b/physics/smoke_dust/module_add_emiss_burn.F90 @@ -6,217 +6,156 @@ module module_add_emiss_burn use machine , only : kind_phys use rrfs_smoke_config CONTAINS - subroutine add_emis_burn(dtstep,dz8w,rho_phy,rel_hum, & - chem,julday,gmt,xlat,xlong, & - !luf_igbp,lu_fire1, & - vegtype,vfrac,peak_hr, & - time_int,ebu, & ! RAR - r_q,fhist,ext3d_smoke,ext3d_dust, & - ! nwfa,nifa, & - rainc,rainnc, swdown,smoke_forecast, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - -! USE module_configure, only: grid_config_rec_type -! USE module_state_description - IMPLICIT NONE + subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & + chem,julday,gmt,xlat,xlong, & + fire_end_hr, peak_hr,time_int, & + coef_bb_dc, fhist, hwp, hwp_prevd, & + swdown,ebb_dcycle, ebu_in, ebu,fire_type,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + IMPLICIT NONE - INTEGER, INTENT(IN ) :: julday, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + INTEGER, INTENT(IN ) :: julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem + INTENT(INOUT ) :: chem ! shall we set num_chem=1 here? real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN) :: ebu - - real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong, rainc,rainnc,swdown, peak_hr, vfrac - real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: r_q ! RAR: - real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fhist ! RAR: - real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(OUT) :: ext3d_smoke, ext3d_dust ! RAR: - integer, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: vegtype - - real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: dz8w,rho_phy,rel_hum -! real(kind_phys), DIMENSION(ims:ime,1:nlcat,jms:jme), INTENT(IN) :: luf_igbp - -! real(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & -! OPTIONAL, INTENT(INOUT ) :: nwfa,nifa ! RAR: - - real(kind_phys), INTENT(IN) :: dtstep, gmt - real(kind_phys), INTENT(IN) :: time_int ! RAR: time in seconds since start of simulation - integer, INTENT(IN) :: smoke_forecast - - integer :: i,j,k,n,m - real(kind_phys) :: conv_rho, conv, ext2, dm_smoke, daero_num_wfa, daero_num_ifa !, lu_sum1_5, lu_sum12_14 - !real(kind_phys) :: ebumax -! CHARACTER (LEN=80) :: message - - INTEGER, PARAMETER :: kfire_max=51 ! max vertical level for BB plume rise - ! Diameters and standard deviations for emissions - ! the diameters are the volume (mass) geometric mean diameters, following MADE_SORGAM - real(kind_phys), PARAMETER :: dgvem_i= 0.08E-6 !0.03E-6 ! [ m ] - real(kind_phys), PARAMETER :: sgem_i = 1.8 !1.7 - - ! *** Accumulation mode: - real(kind_phys), PARAMETER :: dgvem_j= 0.3E-6 ! [ m ] - real(kind_phys), PARAMETER :: sgem_j = 2.0 - - ! *** Coarse mode - real(kind_phys), PARAMETER :: dgvem_c= 6.0E-6 ! [ m ] - real(kind_phys), PARAMETER :: sgem_c= 2.2 - real(kind_phys), PARAMETER :: pic= 3.14159 - - ! RAR: factors for getting number emissions rate from mass emissions rate following made_sorgam - real(kind_phys), PARAMETER :: fact_numn= 1.e-9*6.0/pic*exp(4.5*log(sgem_i)**2)/dgvem_i**3 ! Aitken mode - real(kind_phys), PARAMETER :: fact_numa= 1.e-9*6.0/pic*exp(4.5*log(sgem_j)**2)/dgvem_j**3 ! accumulation mode - real(kind_phys), PARAMETER :: fact_numc= 1.e-9*6.0/pic*exp(4.5*log(sgem_c)**2)/dgvem_c**3 ! coarse mode - - real(kind_phys), PARAMETER :: dens_oc_aer=1.4e3, dens_ec_aer=1.7e3 ! kg/m3 -! real(kind_phys), PARAMETER :: rinti=2.1813936e-8, cx=2.184936* 3600, timeq_max=3600.*24. ! constants for the diurnal cycle calculations - real(kind_phys), PARAMETER :: ax1=531., cx1=7800. ! For cropland, urban and small fires -! real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3200., const2=100., coef2=10.6712963e-4, cx=2.184936* 3600, timeq_max=3600.*24. - real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3400., const2=130., coef2=10.6712963e-4, cx2=7200., timeq_max=3600.*24. ! New parameters - real(kind_phys), PARAMETER :: sc_me= 4.0, ab_me=0.5 ! m2/g, scattering and absorption efficiency for smoke - -! Parameters used for the wfa and ifa in mp physics per Trude E. (NCAR) -! Water friendly: radius: 0.04 micron, standard deviation: 1.8, kappa (for hygroscopic growth): 0.2, real index of refraction: 1.53, imaginary index of refraction: 1e-7 -! Ice friendly: radius: 0.4 micron, standard deviation: 1.8, kappa : 0.04, real index of refraction: 1.56, imaginary index of refraction: 3e-3 + INTENT(INOUT ) :: ebu + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong, swdown + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: hwp, peak_hr, fire_end_hr, ebu_in !, vfrac + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: coef_bb_dc ! RAR: + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: hwp_prevd + + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: dz8w,rho_phy !,rel_hum + real(kind_phys), INTENT(IN) :: dtstep, gmt + real(kind_phys), INTENT(IN) :: time_int,pi ! RAR: time in seconds since start of simulation + INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: fire_type + integer, INTENT(IN) :: ebb_dcycle ! RAR: this is going to be namelist dependent, ebb_dcycle=means + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fhist +!>--local + integer :: i,j,k,n,m + real(kind_phys) :: conv_rho, conv, dm_smoke, dc_hwp, dc_gp, dc_fn !daero_num_wfa, daero_num_ifa !, lu_sum1_5, lu_sum12_14 + + INTEGER, PARAMETER :: kfire_max=51 ! max vertical level for BB plume rise + ! real, parameter :: cx = 2.184936 * 3600., rinti = 2.1813936e-8 , ax = 2000.6038 ! bx_bburn = 20.041288 * 3600., RAR: this depends on the vegetation class, location (local time) etc. - real(kind_phys) :: timeq, dt1,dt2,dtm ! For BB emis. diurnal cycle calculation - - timeq= gmt*3600. + real(time_int,4) + real(kind_phys) :: timeq, fire_age, age_hr, dt1,dt2,dtm ! For BB emis. diurnal cycle calculation + ! For Gaussian diurnal cycle + real(kind_phys), PARAMETER :: sc_factor=1. ! to scale up the wildfire emissions, TBD later + real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3400., const2=130., & + coef2=10.6712963e-4, cx2=7200., timeq_max=3600.*24. +!>-- Fire parameters + real(kind_phys), dimension(1:5), parameter :: avg_fire_dur = (/8.9, 4.2, 3.3, 3.0, 1.4/) + real(kind_phys), dimension(1:5), parameter :: sigma_fire_dur = (/8.7, 6.0, 5.5, 5.2, 2.4/) + + timeq= gmt*3600._kind_phys + real(time_int,4) timeq= mod(timeq,timeq_max) -! Main loops to add BB emissions - do j=jts,jte - do i=its,ite - !if( luf_igbp(i,17,j)>0.99 .OR. ebu(i,1,j,p_ebu_smoke) < 1.e-6) cycle ! no BB emissions or water pixels - if( (1.-vfrac (i,j))>0.99 .OR. ebu(i,1,j) < 1.e-6) cycle ! no BB emissions or water pixels - - ! RAR: the decrease in the BB emissions after >18 hrs of forecast, the decrease occurs at night. The decrease occurs at night. - IF (time_int>64800. .AND. swdown(i,j)<.1 .AND. fhist(i,j)>.75 ) THEN - fhist(i,j)= 0.75 - ENDIF - IF (time_int>129600. .AND. swdown(i,j)<.1 .AND. fhist(i,j)>.5 ) THEN ! After 36 hr forecast - fhist(i,j)= 0.5 - ENDIF - - IF ( (rainc(i,j) + rainnc(i,j))>=10. .AND. fhist(i,j)>.3 ) THEN ! If it rains more than 1cm, then the BB emissions are reduced - fhist(i,j)= 0.3 - ENDIF - -! RAR: Grasslands (29% of ther western HRRR CONUS domain) probably also need to be added below, check this later -! RAR: In the HRRR CONUS domain (western part) crop 11%, 2% cropland/natural vegetation and 0.4% urban of pixels -!.OR. lu_index(i,j)==14) then ! Croplands(12), Urban and Built-Up(13), cropland/natural vegetation (14) mosaic in MODI-RUC vegetation classes +! RAR: Grasslands (29% of ther western HRRR CONUS domain) probably also need to +! be added below, check this later +! RAR: In the HRRR CONUS domain (western part) crop 11%, 2% cropland/natural +! vegetation and 0.4% urban of pixels +!.OR. lu_index(i,j)==14) then ! Croplands(12), Urban and Built-Up(13), +!cropland/natural vegetation (14) mosaic in MODI-RUC vegetation classes ! Peak hours for the fire activity depending on the latitude -! if (xlong(i,j)<-130.) then max_ti= 24.041288* 3600. ! peak at 24 UTC, fires in Alaska -! elseif (xlong(i,j)<-100.) then max_ti= 22.041288* 3600. ! peak at 22 UTC, fires in the western US -! elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US, max_ti= 20.041288* 3600. +! if (xlong(i,j)<-130.) then max_ti= 24.041288* 3600. ! +! peak at 24 UTC, fires in Alaska +! elseif (xlong(i,j)<-100.) then max_ti= 22.041288* 3600. +! ! peak at 22 UTC, fires in the western US +! elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in +! the eastern US, max_ti= 20.041288* 3600. ! else max_ti= 18.041288* 3600. ! endif +! RAR: for option #1 ebb and frp are ingested for 24 hours. No modification is +! applied! + if (ebb_dcycle==1) then + do k=kts,kte + do i=its,ite + ebu(i,k,1)=ebu_in(i,1) ! RAR: + enddo + enddo + endif + + if (ebb_dcycle==2) then + + ! Constants for the fire diurnal cycle calculation + do j=jts,jte + do i=its,ite + fire_age= time_int + (fire_end_hr(i,j))*3600. + + SELECT CASE ( fire_type(i,j) ) !Ag, urban fires, bare land etc. + CASE (1) + ! these fires will have exponentially decreasing diurnal cycle, + ! We assume 1hr latency in ingesting the sat. data + coef_bb_dc(i,j) = 1._kind_phys/((2*pi)**0.5_kind_phys * sigma_fire_dur(1) *fire_age) * & + exp(- ( log(fire_age) - avg_fire_dur(1))**2 /(2*sigma_fire_dur(1)**2 )) + CASE (3) + age_hr= fire_age/3600._kind_phys + + IF (swdown(i,j)<.1 .AND. age_hr> 12. .AND. fhist(i,j)>0.75) THEN + fhist(i,j)= 0.75_kind_phys + ENDIF + IF (swdown(i,j)<.1 .AND. age_hr> 24. .AND. fhist(i,j)>0.5) THEN + fhist(i,j)= 0.5_kind_phys + ENDIF + IF (swdown(i,j)<.1 .AND. age_hr> 48. .AND. fhist(i,j)>0.25) THEN + fhist(i,j)= 0.25_kind_phys + ENDIF + + ! this is based on hwp, hourly or instantenous TBD + dc_hwp= ebu_in(i,j)* hwp(i,j)/ MAX(1._kind_phys,hwp_prevd(i,j)) + dc_hwp= MAX(0._kind_phys,dc_hwp) + + !coef_bb_dc(i,j)= sc_factor* fhist(i,j)* rate_ebb2(i,j)* (1. + log( + !hwp_(i,j)/ hwp_day_avg(i,j))) + + ! RAR: Gaussian profile for wildfires + dt1= abs(timeq - peak_hr(i,j)) + dt2= timeq_max - peak_hr(i,j) + timeq ! peak hour is always <86400. + dtm= MIN(dt1,dt2) + dc_gp = rinti*( ax2 * exp(- dtm**2/(2._kind_phys*cx2**2) ) + const2 - coef2*timeq ) + dc_gp = MAX(0._kind_phys,dc_gp) + + dc_fn = MAX(dc_hwp/dc_gp,3._kind_phys) + coef_bb_dc(i,j) = fhist(i,j)* dc_fn + CASE DEFAULT + END SELECT + enddo + enddo + endif + + do j=jts,jte + do i=its,ite + do k=kts,kfire_max + if (ebb_dcycle==1) then + conv= dtstep/(rho_phy(i,k,j)* dz8w(i,k,j)) + elseif (ebb_dcycle==2) then + conv= sc_factor*coef_bb_dc(i,j)*dtstep/(rho_phy(i,k,j)* dz8w(i,k,j)) + endif + dm_smoke= conv*ebu(i,k,j) + chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke) + dm_smoke + chem(i,k,j,p_smoke) = MIN(chem(i,k,j,p_smoke),5.e+3) + + if ( dbg_opt .and. (k==kts .OR. k==kfire_max) ) then + WRITE(6,*) 'add_emiss_burn: i,j,k ',i,j,k + WRITE(6,*) 'add_emiss_burn: rho_phy(i,k,j),dz8w(i,k,j),conv',rho_phy(i,k,j),dz8w(i,k,j),conv + WRITE(6,*) 'add_emiss_burn: ebu(i,k,j),dm_smoke ', ebu(i,k,j),dm_smoke + endif + enddo + enddo + enddo - !IF ( lu_fire1(i,j)>0.9 ) then !Ag, urban fires, bare land etc. - IF ( vegtype(i,j)==12 .or. vegtype(i,j)==13 ) then !Ag, urban fires, bare land etc. - ! these fires will have exponentially decreasing diurnal cycle, these fires decrease 55% in 2 hours, end in 5 hours - r_q(i,j) = rinti* ax1 * exp(- (time_int**2)/(cx1**2) ) - ELSE - ! RAR: Gaussian profile for wildfires - dt1= abs(timeq - peak_hr(i,j)) - dt2= timeq_max - peak_hr(i,j) + timeq ! peak hour is always <86400. - dtm= MIN(dt1,dt2) - r_q(i,j) = rinti*( ax2 * exp(- dtm**2/(2.*cx2**2) ) + const2 - coef2*timeq ) - ENDIF - - r_q(i,j) = fhist(i,j)* max(0.,r_q(i,j)*timeq_max) - - !IF (swdown(i,j)<.1) THEN - ! r_q(i,j)= MIN(0.5,r_q(i,j)) ! lower BB emissions at night - !ENDIF - - !IF (.NOT. config_flags%bb_dcycle) THEN - !IF (.NOT. bb_dcycle) THEN - ! r_q(i,j)= fhist(i,j) ! no diurnal cycle - !END IF - - !IF (smoke_forecast == 0) THEN - r_q(i,j)= 1. - !END IF - - do k=kts,kfire_max - conv= r_q(i,j)*dtstep/(rho_phy(i,k,j)* dz8w(i,k,j)) - - ! RAR: in this case tracer_1 is fire emitted CO - ! conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - ! chem(i,k,j,p_tracer_1) = chem(i,k,j,p_tracer_1) + ebu(i,k,j,p_ebu_co)*conv_rho - -! dm_oc_bb = conv* ebu(i,k,j,p_ebu_oc) ! Assume that BB primary PM25 is mostly OC, 1.25 is OM/OC ratio -! dm_p25_bb= conv* ebu(i,k,j,p_ebu_pm25) -! dm_ec_bb = conv* ebu(i,k,j,p_ebu_bc) -! dm_smk = conv* ebu(i,k,j,p_ebu_smoke) - !IF (k==kts) THEN ! Partition takes place here to avoid double counting of smold. and flam. BB emiss. - ! C11= (1.-flam_frac(i,j))*r_q(i,j) - !ELSE - ! C11= flam_frac(i,j)*r_q(i,j) - !ENDIF - dm_smoke= conv*ebu(i,k,j) -! print*,'hli dm_smoke',dm_smoke,conv,ebu(i,k,j,p_ebu_smoke) - - chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke) + dm_smoke - chem(i,k,j,p_smoke) = MIN(chem(i,k,j,p_smoke),5.e+3) - - ! if ( k==kts ) then - ! WRITE(6,*) 'add_emiss_burn: gmt,dtstep,time_int ',gmt,dtstep,time_int - ! WRITE(*,*) 'add_emiss_burn: i,j,xlat(i,j),xlong(i,j) ',i,j,xlat(i,j),xlong(i,j) - !WRITE(*,*) 'add_emiss_burn: luf_igbp(i,:,j) ',luf_igbp(i,:,j) - !WRITE(*,*) 'add_emiss_burn: lu_fire1(i,j) ',lu_fire1(i,j) - ! WRITE(6,*) 'add_emiss_burn: timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) ',timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) - ! WRITE(*,*) 'add_emiss_burn: rainc(i,j),rainnc(i,j) ', rainc(i,j),rainnc(i,j) - ! endif - if ( dbg_opt .and. (k==kts .OR. k==kfire_max) ) then - WRITE(6,*) 'add_emiss_burn: i,j,k ',i,j,k - WRITE(6,*) 'add_emiss_burn: rho_phy(i,k,j),dz8w(i,k,j),conv ',rho_phy(i,k,j),dz8w(i,k,j),conv - WRITE(6,*) 'add_emiss_burn: ebu(i,k,j),dm_smoke ', ebu(i,k,j),dm_smoke - endif - - enddo - enddo - enddo - - ext2= sc_me + ab_me - do j=jts,jte - do k=kts,kte - do i=its,ite - - ! Check for NaNs, negative and too large numbers - IF (.NOT. (chem(i,k,j,p_smoke)>=0. .AND. chem(i,k,j,p_smoke)<1.1e+4)) THEN - chem(i,k,j,p_smoke)=1.e-16 - END IF - - ext3d_smoke(i,k,j)= 1.e-6* ext2* chem(i,k,j,p_smoke )*rho_phy(i,k,j)*dz8w(i,k,j) - ext3d_dust (i,k,j)= 1.e-6* ext2* chem(i,k,j,p_dust_1)*rho_phy(i,k,j)*dz8w(i,k,j) - enddo - enddo - enddo - - IF ( dbg_opt ) then - WRITE(*,*) 'add_emis_burn: i,j,k,ext2 ',i,j,k,ext2 - WRITE(*,*) 'add_emis_burn: rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) ',rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) - WRITE(*,*) 'add_emis_burn: ext3d_smoke(its,kts,jts),ext3d_smoke(ite,kfire_max,jte) ',ext3d_smoke(its,kts,jts),ext3d_smoke(ite,kfire_max,jte) - WRITE(*,*) 'add_emis_burn: ext3d_dust(its,kts,jts),ext3d_dust(ite,kfire_max,jte) ',ext3d_dust(its,kts,jts),ext3d_dust(ite,kfire_max,jte) - END IF - -! CASE DEFAULT -! call wrf_debug(15,'nothing done with burn emissions for chem array') -! END SELECT emiss_select END subroutine add_emis_burn END module module_add_emiss_burn + diff --git a/physics/smoke_dust/module_plumerise.F90 b/physics/smoke_dust/module_plumerise.F90 new file mode 100755 index 000000000..8a1d6ab25 --- /dev/null +++ b/physics/smoke_dust/module_plumerise.F90 @@ -0,0 +1,172 @@ +!>\file module_plumerise.F90 +!! This file is the fire plume rise driver. + + module module_plumerise + + use machine , only : kind_phys +! real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) +!- Implementing the fire radiative power (FRP) methodology for biomass burning +!- emissions and convective energy estimation. +!- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) +!- Ravan Ahmadov, Georg Grell (NOAA, USA) +!- The flag "plumerise_flag" defines the method: +!- =1 => original method +!- =2 => FRP based + +CONTAINS +subroutine ebu_driver ( flam_frac,ebu_in,ebu, & + theta_phy,q_vap, & ! RAR: moist is replaced with q_vap, SRB: t_phy is repalced by theta_phy + rho_phy,vvel,u_phy,v_phy,pi_phy, & ! SRB: p_phy is replaced by pi_phy + wind_phy, & ! SRB: added wind_phy + z_at_w,z,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags + frp_inst, k_min, k_max, & ! RAR: + wind_eff_opt, & + kpbl_thetav, & ! SRB: added kpbl_thetav + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, errmsg, errflg) + + use rrfs_smoke_config + use plume_data_mod + USE module_zero_plumegen_coms + USE module_smoke_plumerise + IMPLICIT NONE + + REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to distribute smoke in PBL + + REAL(kind_phys), PARAMETER :: zpbl_threshold = 2000. ! SRB: Minimum PBL depth to have plume rise + REAL(kind_phys), PARAMETER :: uspd_threshold = 5. ! SRB: Wind speed averaged across PBL depth to control smoke release levels + REAL(kind_phys), PARAMETER :: frp_threshold500 = 500.e+6 ! SRB: Minimum FRP (Watts) to have plume rise + + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: frp_inst ! RAR: FRP array + + real(kind_phys), DIMENSION(ims:ime, jms:jme), INTENT(IN) :: kpbl_thetav ! SRB + + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: wind_eff_opt + real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT ) :: ebu + real(kind=kind_phys), INTENT(IN ) :: g, con_cp, con_rd + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebu_in + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac + real(kind=kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: z,z_at_w,vvel,u_phy,v_phy,rho_phy,pi_phy,q_vap,theta_phy,wind_phy ! RAR, SRB + +! Local variables... + INTEGER :: nv, i, j, k, kp1, kp2 + INTEGER, DIMENSION(ims:ime, jms:jme), INTENT (OUT) :: k_min, k_max ! Min and max ver. levels for BB injection spread + real(kind_phys), dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in, rho_phyin ,qv_in ,zmid, z_lev, uspd ! SRB + real(kind=kind_phys) :: dz_plume, cpor, con_rocp, uspdavg ! SRB + + cpor =con_cp/con_rd + con_rocp=con_rd/con_cp + + IF ( dbg_opt ) then + WRITE(*,*) 'module_plumerise: its,ite,jts,jte ', its,ite,jts,jte + WRITE(*,*) 'module_plumerise: ims,ime,jms,jme ', ims,ime,jms,jme + WRITE(*,*) 'module_plumerise: maxval(ebu(:,kts,:)) ', maxval(ebu(:,kts,:)) + END IF + +! RAR: setting to zero the ebu emissions at the levels k>1, this is necessary when the plumerise is called, so the emissions at k>1 are updated + !do nv=1,num_ebu + do j=jts,jte + do k=kts+1,kte + do i=its,ite + ebu(i,k,j)=0. + enddo + enddo + enddo + !enddo + +! For now the flammable fraction is constant, based on the namelist. The next +! step to use LU index and meteorology to parameterize it + do j=jts,jte + do i=its,ite + flam_frac(i,j)= 0. + if (frp_inst(i,j) > frp_threshold) then + flam_frac(i,j)= 0.9 + end if + enddo + enddo + + +! RAR: new FRP based approach +! Haiqin: do_plumerise is added to the namelist options +check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise + do j=jts,jte + do i=its,ite + + do k=kts,kte + u_in(k)= u_phy(i,k,j) + v_in(k)= v_phy(i,k,j) + w_in(k)= vvel(i,k,j) + qv_in(k)= q_vap(i,k,j) + pi_in(k)= pi_phy(i,k,j) + zmid(k)= z(i,k,j)-z_at_w(i,kts,j) + z_lev(k)= z_at_w(i,k,j)-z_at_w(i,kts,j) + rho_phyin(k)= rho_phy(i,k,j) + theta_in(k)= theta_phy(i,k,j) + uspd(k)= wind_phy(i,k,j) ! SRB + enddo + + IF (dbg_opt) then + WRITE(*,*) 'module_plumerise: i,j ',i,j + WRITE(*,*) 'module_plumerise: frp_inst(i,j) ',frp_inst(i,j) + WRITE(*,*) 'module_plumerise: ebu(i,kts,j) ',ebu(i,kts,j) + WRITE(*,*) 'module_plumerise: u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) ',u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) + WRITE(*,*) 'module_plumerise: zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) ',zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) + END IF + +! RAR: the plume rise calculation step: + CALL plumerise(kte,1,1,1,1,1,1, & + u_in, v_in, w_in, theta_in ,pi_in, & + rho_phyin, qv_in, zmid, z_lev, & + wind_eff_opt, & + frp_inst(i,j), k_min(i,j), & + k_max(i,j), dbg_opt, g, con_cp, & + con_rd, cpor, errmsg, errflg ) + if(errflg/=0) return + + kp1= k_min(i,j) + kp2= k_max(i,j) + dz_plume= z_at_w(i,kp2,j) - z_at_w(i,kp1,j) + +! SRB: Adding condition for overwriting plumerise levels + uspdavg=SUM(uspd(kts:kpbl_thetav(i,j)))/kpbl_thetav(i,j) !Average wind speed within the boundary layer + + IF ((frp_inst(i,j) .gt. frp_threshold) .AND. (frp_inst(i,j) .le. frp_threshold500) .AND. & + (z_at_w(i,kpbl_thetav(i,j),j) .gt. zpbl_threshold) .AND. (wind_eff_opt .eq. 1)) THEN + kp1=1 + IF (uspdavg .ge. uspd_threshold) THEN ! Too windy + kp2=kpbl_thetav(i,j)/3 + ELSE + kp2=kpbl_thetav(i,j) + END IF + dz_plume= z_at_w(i,kp2,j) - z_at_w(i,kp1,j) + do k=kp1,kp2-1 + ebu(i,k,j)= ebu_in(i,j)* (z_at_w(i,k+1,j)-z_at_w(i,k,j))/dz_plume + enddo + ELSE + do k=kp1,kp2-1 + ebu(i,k,j)= flam_frac(i,j)* ebu_in(i,j)* (z_at_w(i,k+1,j)-z_at_w(i,k,j))/dz_plume + enddo + ebu(i,kts,j)= (1.-flam_frac(i,j))* ebu_in(i,j) + END IF +! SRB: End modification + + IF ( dbg_opt ) then + WRITE(*,*) 'module_plumerise: i,j ',i,j + WRITE(*,*) 'module_plumerise: k_min(i,j), k_max(i,j) ',kp1, kp2 ! SRB: replaced k_min, k_max with kp1, kp2 + END IF +! endif check_frp + enddo + enddo + + ENDIF check_pl + +end subroutine ebu_driver + +END module module_plumerise diff --git a/physics/smoke_dust/module_plumerise1.F90 b/physics/smoke_dust/module_plumerise1.F90 deleted file mode 100755 index 3c23faa6a..000000000 --- a/physics/smoke_dust/module_plumerise1.F90 +++ /dev/null @@ -1,214 +0,0 @@ -!>\file module_plumerise1.F90 -!! This file is the fire plume rise driver. - - module module_plumerise1 - - use machine , only : kind_phys - real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) -!- Implementing the fire radiative power (FRP) methodology for biomass burning -!- emissions and convective energy estimation. -!- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) -!- Ravan Ahmadov, Georg Grell (NOAA, USA) -!- The flag "plumerise_flag" defines the method: -!- =1 => original method -!- =2 => FRP based -!------------------------------------------------------------------------- -! -! use module_zero_plumegen_coms -! integer, parameter :: nveg_agreg = 4 -! integer, parameter :: tropical_forest = 1 -! integer, parameter :: boreal_forest = 2 -! integer, parameter :: savannah = 3 - -! integer, parameter :: grassland = 4 -! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct -! character(len=20), parameter :: veg_name(nveg_agreg) = (/ & -! 'Tropical-Forest', & -! 'Boreal-Forest ', & -! 'Savanna ', & -! 'Grassland ' /) -! character(len=20), parameter :: spc_suf(nveg_agreg) = (/ & -! 'agtf' , & ! trop forest -! 'agef' , & ! extratrop forest -! 'agsv' , & ! savanna -! 'aggr' /) ! grassland - -CONTAINS -subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & - t_phy,q_vap, & ! RAR: moist is replaced with q_vap - rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,z,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags - plume_frp, k_min, k_max, & ! RAR: - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, errmsg, errflg) - - use rrfs_smoke_config - use plume_data_mod - USE module_zero_plumegen_coms - USE module_smoke_plumerise - IMPLICIT NONE - - REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to have plume rise - - real(kind=kind_phys), DIMENSION( ims:ime, jms:jme, 2 ), INTENT(IN ) :: plume_frp ! RAR: FRP etc. array - -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - character(*), intent(inout) :: errmsg - integer, intent(inout) :: errflg - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte -! real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & -! INTENT(IN ) :: moist - real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT ) :: ebu - - real(kind=kind_phys), INTENT(IN ) :: g, con_cp, con_rd - real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebb_smoke - real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac - -! real(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme ), & -! INTENT(IN ) :: ebu_in -! real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), & -! INTENT(IN ) :: & -! mean_fct_agtf,mean_fct_agef,& -! mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef, & -! firesize_agsv,firesize_aggr - - real(kind=kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: t_phy,z,z_at_w,vvel,u_phy,v_phy,rho_phy,p_phy,q_vap ! RAR - ! real(kind=kind_phys), INTENT(IN ) :: dtstep - -! Local variables... - INTEGER :: nv, i, j, k, kp1, kp2 - INTEGER, DIMENSION(ims:ime, jms:jme), INTENT (OUT) :: k_min, k_max ! Min and max ver. levels for BB injection spread - !real(kind_phys), dimension (num_ebu) :: eburn_in - !real(kind_phys), dimension (kte,num_ebu) :: eburn_out - real(kind_phys), dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in, rho_phyin ,qv_in ,zmid, z_lev - real(kind=kind_phys) :: dz_plume, cpor, con_rocp - - !INTEGER, PARAMETER :: kfire_max=30 -! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct -! real(kind_phys) :: sum, ffirs, ratio -! real(kind_phys),save,dimension(its:ite,jts:jte) :: ffirs -! nspecies=num_ebu -! write(0,*)'plumerise' - -! RAR: -! do j=jts,jte: -! do i=its,ite -! ebu(i,kts,j,p_ebu_smoke)= ebb_smoke(i,j) -! ebu(i,kts,j,p_ebu_no) = ebu_in(i,1,j,p_ebu_in_no) -! ebu(i,kts,j,p_ebu_co) = ebu_in(i,1,j,p_ebu_in_co) -! ebu(i,kts,j,p_ebu_so2) = ebu_in(i,1,j,p_ebu_in_so2) -! ebu(i,kts,j,p_ebu_dms) = ebu_in(i,1,j,p_ebu_in_dms) -! ebu(i,kts,j,p_ebu_oc) = ebu_in(i,1,j,p_ebu_in_oc) -! ebu(i,kts,j,p_ebu_bc) = ebu_in(i,1,j,p_ebu_in_bc) -! ebu(i,kts,j,p_ebu_pm25) = ebu_in(i,1,j,p_ebu_in_pm25) -! ebu(i,kts,j,p_ebu_pm10) = ebu_in(i,1,j,p_ebu_in_pm10) -! enddo -! enddo - cpor =con_cp/con_rd - con_rocp=con_rd/con_cp - - IF ( dbg_opt ) then - WRITE(*,*) 'module_plumerise1: its,ite,jts,jte ', its,ite,jts,jte - WRITE(*,*) 'module_plumerise1: ims,ime,jms,jme ', ims,ime,jms,jme - !WRITE(*,*) 'module_plumerise1: p_ebu_smoke,num_ebu: ', p_ebu_smoke,num_ebu - WRITE(*,*) 'module_plumerise1: maxval(ebu(:,kts,:)) ', maxval(ebu(:,kts,:)) - END IF - !endif - -! RAR: setting to zero the ebu emissions at the levels k>1, this is necessary when the plumerise is called, so the emissions at k>1 are updated - !do nv=1,num_ebu - do j=jts,jte - do k=kts+1,kte - do i=its,ite - ebu(i,k,j)=0. - enddo - enddo - enddo - !enddo - -! For now the flammable fraction is constant, based on the namelist. The next -! step to use LU index and meteorology to parameterize it - do j=jts,jte - do i=its,ite - flam_frac(i,j)= 0. - if (plume_frp(i,j,1) > frp_threshold) then - flam_frac(i,j)= 0.9 - end if - enddo - enddo - - -! RAR: new FRP based approach -!check_pl: IF (config_flags%plumerise_flag == 2 ) THEN ! if the namelist option is set for plumerise -! Haiqin: plumerise_flag is added to the namelist options -check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise - do j=jts,jte - do i=its,ite - ! k_min(i,j)=0 - ! k_max(i,j)=0 - -! check_frp: if (.NOT.do_plumerise) then ! namelist option -! ebu(i,kts,j)= ebb_smoke(i,j) -! else - - do k=kts,kte - u_in(k)= u_phy(i,k,j) - v_in(k)= v_phy(i,k,j) - w_in(k)= vvel(i,k,j) - qv_in(k)= q_vap(i,k,j) ! RAR: moist(i,k,j,p_qv) - !pi_in(k)= cp*(p_phy(i,k,j)/p1000mb)**rcp - pi_in(k)= con_cp*(p_phy(i,k,j)/p1000mb)**con_rocp - zmid(k)= z(i,k,j)-z_at_w(i,kts,j) - z_lev(k)= z_at_w(i,k,j)-z_at_w(i,kts,j) - rho_phyin(k)= rho_phy(i,k,j) - theta_in(k)= t_phy(i,k,j)/pi_in(k)*con_cp - !theta_in(k)= t_phy(i,k,j)/pi_in(k)*cp - enddo - - IF (dbg_opt) then - WRITE(*,*) 'module_plumerise1: i,j ',i,j - WRITE(*,*) 'module_plumerise1: plume_frp(i,j,:) ',plume_frp(i,j,:) - WRITE(*,*) 'module_plumerise1: ebu(i,kts,j) ',ebu(i,kts,j) - WRITE(*,*) 'module_plumerise1: u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) ',u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) - WRITE(*,*) 'module_plumerise1: zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) ',zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) - WRITE(*,*) 'module_plumerise1: t_phy(i,kte,j),pi_in(kte)',t_phy(i,kte,j),pi_in(kte) - END IF - -! RAR: the plume rise calculation step: - CALL plumerise(kte,1,1,1,1,1,1, & - !firesize,mean_fct, & - !num_ebu, eburn_in, eburn_out, & - u_in, v_in, w_in, theta_in ,pi_in, & - rho_phyin, qv_in, zmid, z_lev, & - plume_frp(i,j,1), k_min(i,j), & - k_max(i,j), dbg_opt, g, con_cp, & - con_rd, cpor, errmsg, errflg ) - !k_max(i,j), config_flags%debug_chem ) - if(errflg/=0) return - - kp1= k_min(i,j) - kp2= k_max(i,j) - dz_plume= z_at_w(i,kp2,j) - z_at_w(i,kp1,j) - - do k=kp1,kp2-1 - ebu(i,k,j)= flam_frac(i,j)* ebb_smoke(i,j)* (z_at_w(i,k+1,j)-z_at_w(i,k,j))/dz_plume - enddo - ebu(i,kts,j)= (1.-flam_frac(i,j))* ebb_smoke(i,j) - - IF ( dbg_opt ) then - WRITE(*,*) 'module_plumerise1: i,j ',i,j - WRITE(*,*) 'module_plumerise1: k_min(i,j), k_max(i,j) ',k_min(i,j), k_max(i,j) - END IF -! endif check_frp - enddo - enddo - - ENDIF check_pl - -end subroutine ebu_driver - -END module module_plumerise1 diff --git a/physics/smoke_dust/module_smoke_plumerise.F90 b/physics/smoke_dust/module_smoke_plumerise.F90 index 61be06181..0fca91de4 100755 --- a/physics/smoke_dust/module_smoke_plumerise.F90 +++ b/physics/smoke_dust/module_smoke_plumerise.F90 @@ -14,9 +14,9 @@ module module_smoke_plumerise use machine , only : kind_phys - use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std, & + use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std !tropical_forest, boreal_forest, savannah, grassland, & - wind_eff + ! wind_eff USE module_zero_plumegen_coms !real(kind=kind_phys),parameter :: rgas=r_d @@ -24,16 +24,16 @@ module module_smoke_plumerise CONTAINS ! RAR: - subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & -! firesize,mean_fct, & - ! nspecies,eburn_in,eburn_out, & + subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & + wind_eff_opt, & frp_inst,k1,k2, dbg_opt, g, cp, rgas, & cpor, errmsg, errflg ) implicit none LOGICAL, INTENT (IN) :: dbg_opt + INTEGER, INTENT (IN) :: wind_eff_opt ! INTEGER, PARAMETER :: ihr_frp=1, istd_frp=2!, imean_fsize=3, istd_fsize=4 ! RAR: @@ -43,6 +43,7 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,imm,ixx,ispc !,nspecies + INTEGER, INTENT (OUT) :: k1,k2 character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -68,10 +69,13 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! integer, parameter :: grassland = 4 ! real(kind=kind_phys), dimension(nveg_agreg) :: firesize,mean_fct - INTEGER, PARAMETER :: wind_eff = 1 + INTEGER :: wind_eff type(plumegen_coms), pointer :: coms +! Set wind effect from namelist + wind_eff = wind_eff_opt + ! integer:: iloop !REAL(kind=kind_phys), INTENT (IN) :: convert_smold_to_flam diff --git a/physics/smoke_dust/module_wetdep_ls.F90 b/physics/smoke_dust/module_wetdep_ls.F90 index 87212920b..8ba8f67d9 100755 --- a/physics/smoke_dust/module_wetdep_ls.F90 +++ b/physics/smoke_dust/module_wetdep_ls.F90 @@ -3,17 +3,18 @@ module module_wetdep_ls use machine , only : kind_phys - use rrfs_smoke_config, only : p_qc, alpha => wetdep_ls_alpha + use rrfs_smoke_config, only : p_smoke, p_dust_1, p_coarse_pm, p_qc, alpha => wetdep_ls_alpha contains subroutine wetdep_ls(dt,var,rain,moist, & - rho,nchem,num_moist,dz8w,vvel, & + rho,nchem,num_moist,ndvel,dz8w,vvel, & + wetdpr_smoke, wetdpr_dust, wetdpr_coarsepm, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) implicit none - integer, intent(in) :: nchem, num_moist, & + integer, intent(in) :: nchem, num_moist, ndvel, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -21,6 +22,8 @@ subroutine wetdep_ls(dt,var,rain,moist, real(kind_phys), dimension( ims:ime, kms:kme, jms:jme, num_moist),intent(in) :: moist real(kind_phys), dimension( ims:ime, kms:kme, jms:jme),intent(in) :: rho,dz8w,vvel real(kind_phys), dimension( ims:ime, kms:kme, jms:jme,1:nchem),intent(inout) :: var + real(kind_phys), dimension( ims:ime, jms:jme ), intent(out) :: & + wetdpr_smoke, wetdpr_dust, wetdpr_coarsepm real(kind_phys), dimension( ims:ime, jms:jme),intent(in) :: rain real(kind_phys), dimension( its:ite, jts:jte) :: var_sum,var_rmv real(kind_phys), dimension( its:ite, kts:kte, jts:jte) :: var_rmvl @@ -29,6 +32,9 @@ subroutine wetdep_ls(dt,var,rain,moist, integer :: nv,i,j,k,km,kb,kbeg !real(kind_phys), parameter :: alpha = .5 ! scavenging factor + wetdpr_smoke =0. + wetdpr_dust =0. + wetdpr_coarsepm=0. do nv=1,nchem do i=its,ite @@ -68,6 +74,14 @@ subroutine wetdep_ls(dt,var,rain,moist, if(var(i,k,j,nv).gt.1.e-16 .and. moist(i,k,j,p_qc).gt.0.)then factor = max(0.,frc(i,j)*rho(i,k,j)*dz8w(i,k,j)*vvel(i,k,j)) dvar=alpha*factor/(1+factor)*var(i,k,j,nv) +! Accumulate diags + if (nv .eq. p_smoke ) then + wetdpr_smoke(i,j) = wetdpr_smoke(i,j) + dvar * rho(i,k,j) * dt * 1.E-6 + elseif (nv .eq. p_dust_1 ) then + wetdpr_dust(i,j) = wetdpr_dust(i,j) + dvar * rho(i,k,j) * dt * 1.E-6 + elseif (nv .eq. p_coarse_pm ) then + wetdpr_coarsepm(i,j) = wetdpr_coarsepm(i,j) + dvar * rho(i,k,j) * dt * 1.E-6 + endif var(i,k,j,nv)=max(1.e-16,var(i,k,j,nv)-dvar) endif enddo diff --git a/physics/smoke_dust/plume_data_mod.F90 b/physics/smoke_dust/plume_data_mod.F90 index 3d4b21c37..3f0bcdecd 100755 --- a/physics/smoke_dust/plume_data_mod.F90 +++ b/physics/smoke_dust/plume_data_mod.F90 @@ -45,7 +45,6 @@ module plume_data_mod integer, parameter :: savannah = 3 integer, parameter :: grassland = 4 integer, parameter :: nveg_agreg = 4 - integer, parameter :: wind_eff = 1 public diff --git a/physics/smoke_dust/rrfs_smoke_config.F90 b/physics/smoke_dust/rrfs_smoke_config.F90 index 58d4c5846..d7478986b 100755 --- a/physics/smoke_dust/rrfs_smoke_config.F90 +++ b/physics/smoke_dust/rrfs_smoke_config.F90 @@ -15,30 +15,31 @@ module rrfs_smoke_config !-- constant paramters real(kind=kind_phys), parameter :: epsilc = 1.e-12 - !-- aerosol module configurations - integer :: chem_opt = 1 + integer :: chem_opt = 1 integer :: kemit = 1 integer :: dust_opt = 5 - integer :: seas_opt = 2 + integer :: seas_opt = 0 ! turn off by default logical :: do_plumerise = .true. integer :: addsmoke_flag = 1 + integer :: smoke_forecast = 1 integer :: plumerisefire_frq=60 integer :: wetdep_ls_opt = 1 integer :: drydep_opt = 1 - integer :: coarsepm_settling = 1 - logical :: bb_dcycle = .false. - logical :: aero_ind_fdb = .false. + integer :: pm_settling = 1 + integer :: nfire_types = 5 + integer :: ebb_dcycle = 2 ! 1: read in ebb_smoke(i,24), 2: daily logical :: dbg_opt = .true. - integer :: smoke_forecast = 0 ! 0 read in ebb_smoke(i,24) + logical :: aero_ind_fdb = .false. + logical :: add_fire_heat_flux= .false. + logical :: do_rrfs_sd = .true. +! integer :: wind_eff_opt = 1 + logical :: extended_sd_diags = .false. real(kind_phys) :: wetdep_ls_alpha = .5 ! scavenging factor ! -- integer, parameter :: CHEM_OPT_GOCART= 1 - integer, parameter :: call_chemistry = 1 - integer, parameter :: num_moist=3, num_chem=20, num_emis_seas=5, num_emis_dust=5 - - integer, parameter :: DUST_OPT_FENGSHA = 5 + integer, parameter :: num_moist=2, num_chem=20, num_emis_seas=5, num_emis_dust=5 ! -- hydrometeors integer, parameter :: p_qv=1 @@ -52,41 +53,19 @@ module rrfs_smoke_config integer :: numgas = 0 !-- tracers - integer, parameter :: p_so2=1 - integer, parameter :: p_sulf=2 - integer, parameter :: p_dms=3 - integer, parameter :: p_msa=4 - integer, parameter :: p_p25=5, p_smoke=5 - integer, parameter :: p_bc1=6 - integer, parameter :: p_bc2=7 - integer, parameter :: p_oc1=8 - integer, parameter :: p_oc2=9 - integer, parameter :: p_dust_1=10 - integer, parameter :: p_dust_2=11 - integer, parameter :: p_dust_3=12 - integer, parameter :: p_dust_4=13 - integer, parameter :: p_dust_5=14, p_coarse_pm=14 - integer, parameter :: p_seas_1=15 - integer, parameter :: p_seas_2=16 - integer, parameter :: p_seas_3=17 - integer, parameter :: p_seas_4=18 - integer, parameter :: p_seas_5=19 - integer, parameter :: p_p10 =20 - - integer, parameter :: p_edust1=1,p_edust2=2,p_edust3=3,p_edust4=4,p_edust5=5 - integer, parameter :: p_eseas1=1,p_eseas2=2,p_eseas3=3,p_eseas4=4,p_eseas5=5 - - integer :: p_ho=0,p_h2o2=0,p_no3=0 + integer, parameter :: p_smoke=5 + integer, parameter :: p_dust_1=10 + integer, parameter :: p_dust_2=11 + integer, parameter :: p_dust_3=12 + integer, parameter :: p_dust_4=13 + integer, parameter :: p_dust_5=14, p_coarse_pm=14 + integer, parameter :: p_seas_1=15 + integer, parameter :: p_seas_2=16 + integer, parameter :: p_seas_3=17 + integer, parameter :: p_seas_4=18 + integer, parameter :: p_seas_5=19 - ! constants - real(kind=kind_phys), PARAMETER :: airmw = 28.97 - real(kind=kind_phys), PARAMETER :: mw_so2_aer = 64.066 - real(kind=kind_phys), PARAMETER :: mw_so4_aer = 96.066 - real(kind=kind_phys), parameter :: smw = 32.00 - real(kind=kind_phys), parameter :: mwdry = 28. -! d is the molecular weight of dry air (28.966), w/d = 0.62197, and -! (d - w)/d = 0.37803 -! http://atmos.nmsu.edu/education_and_outreach/encyclopedia/humidity.htm + integer, parameter :: p_edust1=1,p_edust2=2,p_edust3=3,p_edust4=4,p_edust5=5 ! -- fire options ! integer, parameter :: num_plume_data = 1 diff --git a/physics/smoke_dust/rrfs_smoke_postpbl.meta b/physics/smoke_dust/rrfs_smoke_postpbl.meta index 50f7afae7..50fbb4e03 100755 --- a/physics/smoke_dust/rrfs_smoke_postpbl.meta +++ b/physics/smoke_dust/rrfs_smoke_postpbl.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrfs_smoke_postpbl type = scheme - dependencies = dep_dry_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + dependencies = ../hooks/machine.F,dep_dry_simple_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90,dep_dry_mod_emerson.F90,dep_data_mod.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90 index d892d19ef..203de1cb0 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.F90 +++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90 @@ -7,18 +7,20 @@ module rrfs_smoke_wrapper use machine , only : kind_phys use rrfs_smoke_config, only : kemit, dust_opt, seas_opt, do_plumerise, & addsmoke_flag, plumerisefire_frq, wetdep_ls_opt, & - drydep_opt, coarsepm_settling, aero_ind_fdb, & - dbg_opt, smoke_forecast, wetdep_ls_alpha, & + drydep_opt, pm_settling, aero_ind_fdb, ebb_dcycle, & + dbg_opt,smoke_forecast,wetdep_ls_alpha,do_rrfs_sd, & + ebb_dcycle, extended_sd_diags,add_fire_heat_flux, & num_moist, num_chem, num_emis_seas, num_emis_dust, & - DUST_OPT_FENGSHA, p_qv, p_atm_shum, p_atm_cldq, & + p_qv, p_atm_shum, p_atm_cldq, & p_smoke, p_dust_1, p_coarse_pm, epsilc - use dust_data_mod, only : dust_alpha, dust_gamma - use plume_data_mod, only : p_frp_std, p_frp_hr, num_frp_plume + use dust_data_mod, only : dust_alpha, dust_gamma, dust_moist_opt, & + dust_moist_correction, dust_drylimit_factor use seas_mod, only : gocart_seasalt_driver use dust_fengsha_mod, only : gocart_dust_fengsha_driver - use dep_dry_mod, only : dry_dep_driver + use dep_dry_simple_mod, only : dry_dep_driver_simple + use dep_dry_emerson_mod, only : dry_dep_driver_emerson use module_wetdep_ls, only : wetdep_ls - use module_plumerise1, only : ebu_driver + use module_plumerise, only : ebu_driver use module_add_emiss_burn, only : add_emis_burn use coarsepm_settling_mod, only : coarsepm_settling_driver @@ -26,13 +28,81 @@ module rrfs_smoke_wrapper private - public :: rrfs_smoke_wrapper_run + public :: rrfs_smoke_wrapper_run, rrfs_smoke_wrapper_init + + integer :: plume_wind_eff contains !>\defgroup rrfs_smoke_wrapper rrfs-sd emission driver Module !> \ingroup gsd_chem_group !! This is the rrfs-sd emission driver Module + +!> \section arg_table_rrfs_smoke_wrapper_init Argument Table +!! \htmlinclude rrfs_smoke_wrapper_init.html +!! + subroutine rrfs_smoke_wrapper_init( seas_opt_in, & ! sea salt namelist + drydep_opt_in, pm_settling_in, & ! Dry Dep namelist + wetdep_ls_opt_in,wetdep_ls_alpha_in, & ! Wet dep namelist + rrfs_sd, do_plumerise_in, plumerisefire_frq_in, & ! smoke namelist + plume_wind_eff_in,add_fire_heat_flux_in, & ! smoke namelist + addsmoke_flag_in, ebb_dcycle_in, smoke_forecast_in, & ! Smoke namelist + dust_opt_in, dust_alpha_in, dust_gamma_in, & ! Dust namelist + dust_moist_opt_in, & ! Dust namelist + dust_moist_correction_in, dust_drylimit_factor_in, & ! Dust namelist + aero_ind_fdb_in, & ! Feedback namelist + extended_sd_diags_in,dbg_opt_in, & ! Other namelist + errmsg, errflg ) + + +!>-- Namelist + real(kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in + real(kind_phys), intent(in) :: dust_moist_correction_in + real(kind_phys), intent(in) :: dust_drylimit_factor_in + integer, intent(in) :: dust_opt_in,dust_moist_opt_in, wetdep_ls_opt_in, pm_settling_in, seas_opt_in + integer, intent(in) :: drydep_opt_in + logical, intent(in) :: aero_ind_fdb_in,dbg_opt_in, extended_sd_diags_in, add_fire_heat_flux_in + integer, intent(in) :: smoke_forecast_in, plume_wind_eff_in, plumerisefire_frq_in + integer, intent(in) :: addsmoke_flag_in, ebb_dcycle_in + logical, intent(in) :: do_plumerise_in, rrfs_sd + character(len=*),intent(out):: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + +!>-- Assign namelist values + !>-Dust + dust_alpha = dust_alpha_in + dust_gamma = dust_gamma_in + dust_moist_opt = dust_moist_opt_in + dust_moist_correction = dust_moist_correction_in + dust_drylimit_factor = dust_drylimit_factor_in + dust_opt = dust_opt_in + !>-Sea Salt + seas_opt = seas_opt_in + !>-Dry and wet deposition + drydep_opt = drydep_opt_in + pm_settling = pm_settling_in + wetdep_ls_opt = wetdep_ls_opt_in + wetdep_ls_alpha = wetdep_ls_alpha_in + !>-Smoke + do_rrfs_sd = rrfs_sd + ebb_dcycle = ebb_dcycle_in + do_plumerise = do_plumerise_in + plumerisefire_frq = plumerisefire_frq_in + addsmoke_flag = addsmoke_flag_in + smoke_forecast = smoke_forecast_in + plume_wind_eff = plume_wind_eff_in + add_fire_heat_flux = add_fire_heat_flux_in + !>-Feedback + aero_ind_fdb = aero_ind_fdb_in + !>-Other + extended_sd_diags = extended_sd_diags_in + dbg_opt = dbg_opt_in + + end subroutine rrfs_smoke_wrapper_init + !! \section arg_table_rrfs_smoke_wrapper_run Argument Table !! \htmlinclude rrfs_smoke_wrapper_run.html !! @@ -41,121 +111,113 @@ module rrfs_smoke_wrapper subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, dt, garea, land, jdate, & u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & - nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl, snow, julian, & - idat, rain_cpl, rainc_cpl, exch, hf2d, g, pi, con_cp, con_rd, con_fv, & - dust12m_in, emi_in, smoke_RRFS, ntrac, qgrs, gq0, chem3d, tile_num, & - ntfsmoke, ntsmoke, ntdust, ntcoarsepm, & - imp_physics, imp_physics_thompson,nwfa, nifa, emanoc, emdust, emseas, & - ebb_smoke_hr, frp_hr, frp_std_hr, & - coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, wetness, & - smoke_ext, dust_ext, ndvel, ddvel_inout,rrfs_sd,cpl_fire, & - smoke_fire, & - dust_alpha_in, dust_gamma_in, fire_in, & - seas_opt_in, dust_opt_in, drydep_opt_in, coarsepm_settling_in, & - do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & - wetdep_ls_opt_in,wetdep_ls_alpha_in, & - smoke_forecast_in, aero_ind_fdb_in,dbg_opt_in,errmsg,errflg) - + nsoil, smc, vegtype_dom, vegtype_frac, soiltyp, nlcat, & + dswsfc, zorl, snow, julian,recmol, & + idat, rain_cpl, rainc_cpl, hf2d, g, pi, con_cp, con_rd, con_fv, & + dust12m_in, emi_ant_in, smoke_RRFS, smoke2d_RRFS, & + ntrac, qgrs, gq0, chem3d, tile_num, & + ntfsmoke, & + ntsmoke, ntdust, ntcoarsepm, imp_physics, imp_physics_thompson, & + nwfa, nifa, emanoc, emdust, emseas, drydep_flux_out, wetdpr, & + ebb_smoke_in, frp_output, coef_bb, ebu_smoke,fhist,min_fplume, & + max_fplume, hwp, hwp_ave, wetness, ndvel, ddvel_inout,fire_in, & + smoke_fire, cpl_fire, & + fire_heat_flux_out, frac_grid_burned_out, kpbl,oro, & + errmsg,errflg ) + implicit none integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) logical, intent(in) :: flag_init, flag_restart - integer, intent(in) :: ntrac, ntfsmoke, ntsmoke, ntdust, ntcoarsepm, ndvel + integer, intent(in) :: ntrac, ntsmoke, ntdust, ntcoarsepm, ndvel, nlcat + integer, intent(in) :: ntfsmoke real(kind_phys),intent(in) :: dt, julian, g, pi, con_cp, con_rd, con_fv - logical, intent(in) :: aero_ind_fdb_in,dbg_opt_in - integer, intent(in) :: smoke_forecast_in integer, parameter :: ids=1,jds=1,jde=1, kds=1 integer, parameter :: ims=1,jms=1,jme=1, kms=1 integer, parameter :: its=1,jts=1,jte=1, kts=1 - integer, dimension(:), intent(in) :: land, vegtype, soiltyp - real(kind_phys), dimension(:,:), intent(in) :: smc - real(kind_phys), dimension(:,:,:), intent(in) :: dust12m_in - real(kind_phys), dimension(:,:,:), intent(in) :: smoke_RRFS - real(kind_phys), dimension(:,:), intent(in) :: emi_in - real(kind_phys), dimension(:), intent(in) :: u10m, v10m, ustar, dswsfc, & - garea, rlat,rlon, tskin, pb2d, sigmaf, zorl, snow, & - rain_cpl, rainc_cpl, hf2d, t2m, dpt2m, smoke_fire - real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d - real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & - us3d, vs3d, spechum, exch, w + integer, dimension(:), intent(in) :: land, vegtype_dom, soiltyp + real(kind_phys), dimension(:,:), intent(in) :: smc + real(kind_phys), dimension(:,:,:), intent(in) :: dust12m_in + real(kind_phys), dimension(:,:,:), intent(in) :: smoke_RRFS + real(kind_phys), dimension(:,:), intent(in) :: smoke2d_RRFS + real(kind_phys), dimension(:,:), intent(in) :: emi_ant_in + real(kind_phys), dimension(:), intent(in) :: u10m, v10m, ustar, dswsfc, & + recmol, garea, rlat,rlon, tskin, pb2d, zorl, snow, & + rain_cpl, rainc_cpl, hf2d, t2m, dpt2m + real(kind_phys), dimension(:,:), intent(in) :: vegtype_frac + real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, us3d, vs3d, spechum, w real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs, gq0 real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d - real(kind_phys), dimension(:), intent(inout) :: emdust, emseas, emanoc - real(kind_phys), dimension(:), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr - real(kind_phys), dimension(:), intent(inout) :: coef_bb, fhist - real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke - real(kind_phys), dimension(:,:), intent(inout) :: fire_in - real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume - real(kind_phys), dimension(:), intent( out) :: hwp - real(kind_phys), dimension(:,:), intent(out) :: smoke_ext, dust_ext - real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa - real(kind_phys), dimension(:,:), intent(inout) :: ddvel_inout - real (kind=kind_phys), dimension(:), intent(in) :: wetness - integer, intent(in ) :: imp_physics, imp_physics_thompson - real (kind=kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in - integer, intent(in) :: seas_opt_in, dust_opt_in, drydep_opt_in, & - coarsepm_settling_in, plumerisefire_frq_in, & - addsmoke_flag_in, wetdep_ls_opt_in - logical, intent(in ) :: do_plumerise_in, rrfs_sd, cpl_fire - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - + real(kind_phys), dimension(:), intent(inout) :: emdust, emseas, emanoc + real(kind_phys), dimension(:), intent(inout) :: ebb_smoke_in,coef_bb, frp_output, fhist + real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke + real(kind_phys), dimension(:,:), intent(inout) :: fire_in + real(kind_phys), dimension(:), intent(in) :: smoke_fire + logical, intent(in) :: cpl_fire + real(kind_phys), dimension(:), intent(out) :: fire_heat_flux_out, frac_grid_burned_out + real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume + real(kind_phys), dimension(:), intent( out) :: hwp + real(kind_phys), dimension(:), intent(inout) :: hwp_ave + real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa + real(kind_phys), dimension(:,:), intent(inout) :: ddvel_inout + real(kind_phys), dimension(:,:), intent(inout) :: drydep_flux_out + real(kind_phys), dimension(:,:), intent(inout) :: wetdpr + real(kind_phys), dimension(:), intent(in) :: wetness + integer, intent(in) :: imp_physics, imp_physics_thompson + integer, dimension(:), intent(in) :: kpbl + real(kind_phys), dimension(:), intent(in) :: oro + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!>-- Local Variables real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: ebu real(kind_phys), dimension(1:im, 1:kme,jms:jme) :: rri, t_phy, u_phy, v_phy, & - p_phy, z_at_w, dz8w, p8w, t8w, rho_phy, vvel, zmid, exch_h - - real(kind_phys), dimension(ims:im, jms:jme) :: u10, v10, ust, tsk, & - xland, xlat, xlong, dxy, pbl, hfx, rcav, rnav - + p_phy,pi_phy,wind_phy,theta_phy,z_at_w, dz8w, p8w, t8w, & + rho_phy, vvel, zmid + real(kind_phys), dimension(ims:im, jms:jme) :: frp_inst, u10, v10, ust, tsk, & + xland, xlat, xlong, dxy, pbl, hfx, rnav, hwp_local, & + wetdpr_smoke_local, wetdpr_dust_local, wetdpr_coarsepm_local !>- sea salt & chemistry variables real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem real(kind_phys), dimension(ims:im, 1, jms:jme, 1:num_emis_seas ) :: emis_seas real(kind_phys), dimension(ims:im, jms:jme) :: seashelp - +!>-- indexes, time integer :: ide, ime, ite, kde, julday - + real(kind_phys) :: gmt !>- dust & chemistry variables real(kind_phys), dimension(ims:im, jms:jme) :: ssm, rdrag, uthr, snowh ! fengsha dust - real(kind_phys), dimension(ims:im, jms:jme) :: vegfrac, rmol, swdown, znt, clayf, sandf + real(kind_phys), dimension(ims:im, jms:jme) :: rmol, swdown, znt, clayf, sandf + real(kind_phys), dimension(ims:im, nlcat, jms:jme) :: vegfrac real(kind_phys), dimension(ims:im, nsoil, jms:jme) :: smois real(kind_phys), dimension(ims:im, 1:1, jms:jme, 1:num_emis_dust) :: emis_dust integer, dimension(ims:im, jms:jme) :: isltyp, ivgtyp - !>- plume variables ! -- buffers - real(kind_phys), dimension(ims:im, jms:jme) :: ebu_in - real(kind_phys), dimension(ims:im, jms:jme, num_frp_plume ) :: plume_frp - real(kind_phys), dimension(ims:im, jms:jme ) :: coef_bb_dc, flam_frac, & - fire_hist, peak_hr - real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: ext3d_smoke, ext3d_dust - integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2 - logical :: call_fire + real(kind_phys), dimension(ims:im, jms:jme ) :: coef_bb_dc, flam_frac, frp_in, & + fire_hist, peak_hr, lu_nofire, lu_qfire, ebu_in, & + fire_end_hr, hwp_day_avg, kpbl_thetav + integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2, fire_type + logical :: call_plume, reset_hwp_ave !>- optical variables - real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: rel_hum - real(kind_phys), dimension(ims:im, jms:jme, ndvel) :: ddvel - + real(kind_phys), dimension(ims:im, jms:jme, ndvel) :: ddvel, settling_flux, drydep_flux_local + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, ndvel) :: vgrav !>-- anthropogentic variables real(kind_phys), dimension(ims:im) :: emis_anoc real(kind_phys), dimension(ims:im, jms:jme, 1) :: sedim - - real(kind_phys) :: gmt - !> -- parameter to caluclate wfa&ifa (m) real(kind_phys), parameter :: mean_diameter1= 4.E-8, sigma1=1.8 real(kind_phys), parameter :: mean_diameter2= 1.E-6, sigma2=1.8 - real(kind_phys), parameter :: kappa_oc = 0.2 - real(kind_phys), parameter :: kappa_dust = 0.04 real(kind_phys) :: fact_wfa, fact_ifa !> -- aerosol density (kg/m3) real(kind_phys), parameter :: density_dust= 2.6e+3, density_sulfate=1.8e+3 real(kind_phys), parameter :: density_oc = 1.4e+3, density_seasalt=2.2e+3 - real(kind_phys), dimension(im) :: daero_emis_wfa, daero_emis_ifa -!>-- local variables +!> -- other real(kind_phys), dimension(im) :: wdgust, snoweq integer :: current_month, current_hour, hour_int real(kind_phys) :: curr_secs @@ -175,25 +237,11 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d end do endif do i=1,im - qgrs(i,kts,ntfsmoke) = qgrs(i,kts,ntfsmoke) + smoke_fire(i) ! units wrong + qgrs(i,kts,ntfsmoke) = qgrs(i,kts,ntfsmoke) + smoke_fire(i) end do endif - if (.not. rrfs_sd) return - -!>-- options to turn on/off sea-salt, dust, plume-rising - seas_opt = seas_opt_in - dust_opt = dust_opt_in - drydep_opt = drydep_opt_in - do_plumerise = do_plumerise_in - plumerisefire_frq = plumerisefire_frq_in - addsmoke_flag = addsmoke_flag_in - smoke_forecast = smoke_forecast_in - aero_ind_fdb = aero_ind_fdb_in - dbg_opt = dbg_opt_in - wetdep_ls_opt = wetdep_ls_opt_in - wetdep_ls_alpha = wetdep_ls_alpha_in - coarsepm_settling = coarsepm_settling_in + if (.not. do_rrfs_sd) return ! -- set domain ide=im @@ -206,19 +254,19 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d emis_seas = 0. emis_dust = 0. peak_hr = 0. + fire_type = 0 + lu_qfire = 0. + lu_nofire = 0. flam_frac = 0. - ext3d_smoke = 0. - ext3d_dust = 0. daero_emis_wfa = 0. daero_emis_ifa = 0. - rcav = 0. rnav = 0. curr_secs = ktau * dt current_month=jdate(2) ! needed for the dust input data current_hour =jdate(5)+1 ! =1 at 00Z - hour_int=ktau*dt/3600. ! hours since the simulation start + hour_int=floor(ktau*dt/3600.) ! hours since the simulation start gmt = real(mod(idat(5)+hour_int,24)) julday = int(julian) @@ -230,70 +278,49 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d ! -- compute incremental convective and large-scale rainfall do i=its,ite - rcav(i,1)=max(rainc_cpl(i)*1000. , 0.) ! meter to mm rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm coef_bb_dc(i,1) = coef_bb(i) fire_hist (i,1) = fhist (i) enddo + ! Is this a reset timestep (00:00 + dt)? + reset_hwp_ave = mod(int(curr_secs-dt),3600) == 0 ! plumerise frequency in minutes set up by the namelist input - call_fire = (do_plumerise .and. (plumerisefire_frq > 0)) - if (call_fire) call_fire = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) .or. (ktau == 2) + call_plume = (do_plumerise .and. (plumerisefire_frq > 0)) + if (call_plume) call_plume = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) .or. (ktau == 2) !>- get ready for chemistry run call rrfs_smoke_prep( & - current_month, current_hour, gmt, con_rd, con_fv, & + ktau,current_month, current_hour, gmt, con_rd, con_fv, con_cp, & u10m,v10m,ustar,land,garea,rlat,rlon,tskin, & - pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & - nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & - snow,dust12m_in,emi_in,smoke_RRFS, & - hf2d, pb2d, g, pi, hour_int, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, & + nsoil,smc,vegtype_dom,soiltyp,nlcat,vegtype_frac,dswsfc,zorl, & + snow,dust12m_in,emi_ant_in,smoke_RRFS,smoke2d_RRFS,coef_bb_dc, & + hf2d, pb2d, g, pi, hour_int, peak_hr, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & - rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,exch_h, & + rri,t_phy,u_phy,v_phy,p_phy,pi_phy,wind_phy,theta_phy, & + rho_phy,dz8w,p8w,t8w,recmol, & z_at_w,vvel,zmid, & ntrac,gq0, & num_chem,num_moist, & ntsmoke, ntdust,ntcoarsepm, & - moist,chem,plume_frp,ebu_in, & - ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & - smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & - snowh,clayf,rdrag,sandf,ssm,uthr,rel_hum, & + moist,chem,ebu_in,kpbl_thetav,ebb_smoke_in, & + fhist,frp_in, hwp_day_avg, fire_end_hr, & + emis_anoc,smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & + snowh,clayf,rdrag,sandf,ssm,uthr,oro, hwp_local, & + t2m,dpt2m,wetness,kpbl, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - -! Make this global, calculate at 1st time step only -!>-- for plumerise -- - - do j=jts,jte - do i=its,ite - peak_hr(i,j)= fire_in(i,10) - enddo - enddo + its,ite, jts,jte, kts,kte ) - IF (ktau==1) THEN - do j=jts,jte - do i=its,ite - if (xlong(i,j)<230.) then - peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska - elseif(xlong(i,j)<245.) then - peak_hr(i,j)= 23.0* 3600. - elseif (xlong(i,j)<260.) then - peak_hr(i,j)= 22.0* 3600. ! peak at 22 UTC, fires in the western US - elseif (xlong(i,j)<275.) then - peak_hr(i,j)= 21.0* 3600. - elseif (xlong(i,j)<290.) then ! peak at 20 UTC, fires in the eastern US - peak_hr(i,j)= 20.0* 3600. - else - peak_hr(i,j)= 19.0* 3600. - endif - enddo - enddo - ENDIF + do j=jts,jte + do i=its,ite + peak_hr(i,j)= fire_in(i,1) + enddo + enddo - IF (ktau==1) THEN + IF (ktau==1) THEN ebu = 0. do j=jts,jte do i=its,ite @@ -303,18 +330,35 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d enddo enddo enddo - ELSE - do k=kts,kte - do i=its,ite - ebu(i,k,1)=ebu_smoke(i,k) - enddo - enddo - ENDIF + ENDIF +!RAR: change this to the fractional LU type; fire_type: 0- no fires, 1- Ag +! or urban fires, 2- prescribed fires in wooded area, 3- wildfires + if (ebb_dcycle==2) then + do j=jts,jte + do i=its,ite + if (ebu_in(i,j)<0.01) then + fire_type(i,j) = 0 + else + ! Permanent wetlands, snow/ice, water, barren tundra + lu_nofire(i,j) = vegfrac(i,11,j) + vegfrac(i,15,j) + vegfrac(i,17,j) + vegfrac(i,20,j) + ! cropland, urban, cropland/natural mosaic, barren and sparsely vegetated + lu_qfire(i,j) = vegfrac(i,12,j) + vegfrac(i,13,j) + vegfrac(i,14,j) + vegfrac(i,16,j) + if (lu_nofire(i,j)>0.95) then + fire_type(i,j) = 0 + else if (lu_qfire(i,j)>0.95) then + fire_type(i,j) = 1 + else + fire_type(i,j) = 3 ! RAR: need to add another criteria for fire_type=2, i.e. prescribed fires + end if + end if + end do + end do + endif !>- compute sea-salt - ! -- compute sea salt (opt=2) - if (seas_opt == 2) then + ! -- compute sea salt (opt=1) + if (seas_opt == 1) then call gocart_seasalt_driver(dt,rri,t_phy, & u_phy,v_phy,chem,rho_phy,dz8w,u10,v10,ust,p8w,tsk, & xland,xlat,xlong,dxy,g,emis_seas,pi, & @@ -325,12 +369,9 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d endif !-- compute dust (opt=5) - if (dust_opt==DUST_OPT_FENGSHA) then - ! Set at compile time in dust_data_mod: - dust_alpha = dust_alpha_in - dust_gamma = dust_gamma_in + if (dust_opt==5) then call gocart_dust_fengsha_driver(dt,chem,rho_phy,smois,p8w,ssm, & - isltyp,vegfrac,snowh,xland,dxy,g,emis_dust,ust,znt, & + isltyp,snowh,xland,dxy,g,emis_dust,ust,znt, & clayf,sandf,rdrag,uthr, & num_emis_dust,num_chem,nsoil, & ids,ide, jds,jde, kds,kde, & @@ -344,13 +385,34 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d !-- /scratch2/BMC/ap-fc/Ravan/rapid-refresh/WRFV3.9/smoke ! Every hour (per namelist) the ebu_driver is called to calculate ebu, but ! the plumerise is controlled by the namelist option of plumerise_flag - if (call_fire) then + if (add_fire_heat_flux) then + do i = its,ite + if ( coef_bb_dc(i,1)*frp_in(i,1) .ge. 1.E7 ) then + fire_heat_flux_out(i) = min(max(0.,0.88*coef_bb_dc(i,1)*frp_in(i,1) / & + 0.55/dxy(i,1)) ,5000.) ! JLS - W m-2 [0 - 10,000] + frac_grid_burned_out(i) = min(max(0., 1.3*0.0006*coef_bb_dc(i,1)*frp_in(i,1)/dxy(i,1) ),1.) + else + fire_heat_flux_out(i) = 0.0 + frac_grid_burned_out(i) = 0.0 + endif + enddo + endif + if (call_plume) then + ! Apply the diurnal cycle coefficient to frp_inst () + do j=jts,jte + do i=its,ite + frp_inst(i,j) = frp_in(i,j)*coef_bb_dc(i,j) + enddo + enddo + call ebu_driver ( & - flam_frac,ebu_in,ebu, & - t_phy,moist(:,:,:,p_qv), & - rho_phy,vvel,u_phy,v_phy,p_phy, & + flam_frac,ebu_in,ebu, & + theta_phy,moist(:,:,:,p_qv), & + rho_phy,vvel,u_phy,v_phy,pi_phy,wind_phy, & z_at_w,zmid,g,con_cp,con_rd, & - plume_frp, min_fplume2, max_fplume2, & ! new approach + frp_inst, min_fplume2, max_fplume2, & + plume_wind_eff, & + kpbl_thetav, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, errmsg, errflg ) @@ -359,20 +421,21 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d ! -- add biomass burning emissions at every timestep if (addsmoke_flag == 1) then - call add_emis_burn(dt,dz8w,rho_phy,rel_hum,chem, & - julday,gmt,xlat,xlong, & - ivgtyp, vegfrac, peak_hr, & ! RAR - curr_secs,ebu, & - coef_bb_dc,fire_hist,ext3d_smoke,ext3d_dust, & - rcav, rnav,swdown,smoke_forecast, & + call add_emis_burn(dt,dz8w,rho_phy,pi, & + chem,julday,gmt,xlat,xlong, & + fire_end_hr, peak_hr,curr_secs, & + coef_bb_dc,fire_hist,hwp_local,hwp_day_avg, & + swdown,ebb_dcycle,ebu_in,ebu,fire_type, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) endif - !>-- compute coarsepm setting - if (coarsepm_settling == 1) then - call coarsepm_settling_driver(dt,t_phy,rel_hum, & + !>-- compute coarsepm setting if using simple dry dep option and + ! pm_settling is on. This is necessary becasue the simple scheme + ! does not have an explicty settling routine, Emersion (opt=1) does. + if (drydep_opt == 2 .and. pm_settling == 1) then + call coarsepm_settling_driver(dt,t_phy, & chem(:,:,:,p_coarse_pm), & rho_phy,dz8w,p8w,p_phy,sedim, & dxy,g,1, & @@ -380,18 +443,29 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) endif - !>-- compute dry deposition + !>-- compute dry deposition, based on Emerson et al., (2020) if (drydep_opt == 1) then - - call dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & + call dry_dep_driver_emerson(rmol,ust,znt,ndvel,ddvel, & + vgrav,chem,dz8w,snowh,t_phy,p_phy,rho_phy,ivgtyp,g,dt, & + pm_settling,drydep_flux_local,settling_flux,dbg_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - + its,ite, jts,jte, kts,kte ) do nv=1,ndvel - do i=its,ite - ddvel_inout(i,nv)=ddvel(i,1,nv) + do i=its,ite + ddvel_inout(i,nv)=ddvel(i,1,nv) + enddo enddo + !>-- compute dry deposition based on simple parameterization (HRRR-Smoke) + elseif (drydep_opt == 2) then + call dry_dep_driver_simple(rmol,ust,ndvel,ddvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + do nv=1,ndvel + do i=its,ite + ddvel_inout(i,nv)=ddvel(i,1,nv) + enddo enddo else ddvel_inout(:,:)=0. @@ -399,35 +473,49 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d !>- large-scale wet deposition if (wetdep_ls_opt == 1) then - call wetdep_ls(dt,chem,rnav,moist, & - rho_phy,num_chem,num_moist,dz8w,vvel, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call wetdep_ls(dt,chem,rnav,moist, & + rho_phy,num_chem,num_moist,ndvel, dz8w,vvel,& + wetdpr_smoke_local, wetdpr_dust_local, & + wetdpr_coarsepm_local, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + if ( extended_sd_diags .or. dbg_opt) then + do i = its, ite + wetdpr(i,1) = wetdpr(i,1) + wetdpr_smoke_local (i,1) + wetdpr(i,2) = wetdpr(i,2) + wetdpr_dust_local (i,1) + wetdpr(i,3) = wetdpr(i,3) + wetdpr_coarsepm_local(i,1) + enddo + endif endif +! Smoke emisisons diagnostic do k=kts,kte do i=its,ite ebu_smoke(i,k)=ebu(i,k,1) enddo enddo - !---- diagnostic output of hourly wildfire potential (07/2021) + if (ktau == 1 .or. reset_hwp_ave) then + hwp_ave = 0. + endif hwp = 0. do i=its,ite - wdgust(i)=max(1.68*sqrt(us3d(i,1)**2+vs3d(i,1)**2),3.) - snoweq(i)=max((25.-snow(i))/25.,0.) - hwp(i)=0.237*wdgust(i)**1.11*max(t2m(i)-dpt2m(i),15.)**0.92*((1.-wetness(i))**6.95)*snoweq(i) ! Eric 08/2022 - enddo - -!---- diagnostic output of smoke & dust optical extinction (12/2021) - do k=kts,kte - do i=its,ite - smoke_ext(i,k) = ext3d_smoke(i,k,1) - dust_ext (i,k) = ext3d_dust (i,k,1) - enddo + hwp(i)=hwp_local(i,1) + hwp_ave(i) = hwp_ave(i) + hwp(i)*dt enddo + +!---- diagnostic output of dry deposition & gravitational settling fluxes + if ( drydep_opt == 1 .and. (extended_sd_diags .or. dbg_opt) ) then + do nv = 1, ndvel + do i=its,ite + drydep_flux_out(i,nv) = drydep_flux_out(i,nv) + & + drydep_flux_local(i,1,nv) + & + settling_flux(i,1,nv) + enddo + enddo + endif !------------------------------------- !---- put smoke stuff back into tracer array do k=kts,kte @@ -452,19 +540,18 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d !-- to output for diagnostics do i = 1, im emseas (i) = emis_seas(i,1,1,1)*1.e+9 ! size bin 1 sea salt emission: ug/m2/s + emanoc (i) = emis_anoc (i) ! anthropogenic organic carbon: ug/m2/s emdust (i) = emis_dust(i,1,1,1) + emis_dust(i,1,1,2) + & emis_dust(i,1,1,3) + emis_dust(i,1,1,4) ! dust emission: ug/m2/s - emanoc (i) = emis_anoc (i) ! anthropogenic organic carbon: ug/m2/s coef_bb (i) = coef_bb_dc(i,1) + frp_output (i) = coef_bb_dc(i,1)*frp_in(i,1) fhist (i) = fire_hist (i,1) min_fplume (i) = real(min_fplume2(i,1)) max_fplume (i) = real(max_fplume2(i,1)) - emseas (i) = sandf(i,1) ! sand for dust - emanoc (i) = uthr (i,1) ! u threshold for dust enddo do i = 1, im - fire_in(i,10) = peak_hr(i,1) + fire_in(i,1) = peak_hr(i,1) enddo !-- to provide real aerosol emission for Thompson MP @@ -496,46 +583,51 @@ subroutine rrfs_smoke_wrapper_run(im, flag_init, flag_restart, kte, kme, ktau, d end subroutine rrfs_smoke_wrapper_run - subroutine rrfs_smoke_prep( & - current_month,current_hour,gmt,con_rd,con_fv, & - u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & - pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & - nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & - snow_cpl,dust12m_in,emi_in,smoke_RRFS, & - hf2d, pb2d, g, pi, hour_int, & - u10,v10,ust,tsk,xland,xlat,xlong,dxy, & - rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,exch_h, & - z_at_w,vvel,zmid, & - ntrac,gq0, & - num_chem, num_moist, & - ntsmoke, ntdust, ntcoarsepm, & - moist,chem,plume_frp,ebu_in, & - ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & - smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & - snowh,clayf,rdrag,sandf,ssm,uthr,rel_hum, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + subroutine rrfs_smoke_prep( & + ktau,current_month,current_hour,gmt,con_rd,con_fv,con_cp, & + u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, & + nsoil,smc,vegtype_dom,soiltyp,nlcat,vegtype_frac,dswsfc,zorl, & + snow_cpl,dust12m_in,emi_ant_in,smoke_RRFS,smoke2d_RRFS,coef_bb_dc, & + hf2d, pb2d, g, pi, hour_int, peak_hr, & + u10,v10,ust,tsk,xland,xlat,xlong,dxy, & + rri,t_phy,u_phy,v_phy,p_phy,pi_phy,wind_phy,theta_phy, & + rho_phy,dz8w,p8w,t8w,recmol, & + z_at_w,vvel,zmid, & + ntrac,gq0, & + num_chem, num_moist, & + ntsmoke, ntdust, ntcoarsepm, & + moist,chem,ebu_in,kpbl_thetav,ebb_smoke_in, & + fhist,frp_in, hwp_day_avg, fire_end_hr, & + emis_anoc,smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & + snowh,clayf,rdrag,sandf,ssm,uthr,oro,hwp_local, & + t2m,dpt2m,wetness,kpbl, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) !Chem input configuration - integer, intent(in) :: current_month, current_hour, hour_int + integer, intent(in) :: current_month, current_hour, hour_int, nlcat !FV3 input variables - integer, intent(in) :: nsoil - integer, dimension(ims:ime), intent(in) :: land, vegtype, soiltyp + integer, intent(in) :: nsoil, ktau + integer, dimension(ims:ime), intent(in) :: land, vegtype_dom, soiltyp, kpbl integer, intent(in) :: ntrac - real(kind=kind_phys), intent(in) :: g, pi, gmt, con_rd, con_fv + real(kind=kind_phys), intent(in) :: g, pi, gmt, con_rd, con_fv, con_cp real(kind=kind_phys), dimension(ims:ime), intent(in) :: & - u10m, v10m, ustar, garea, rlat, rlon, ts2d, sigmaf, dswsfc, & - zorl, snow_cpl, pb2d, hf2d + u10m, v10m, ustar, garea, rlat, rlon, ts2d, dswsfc, & + zorl, snow_cpl, pb2d, hf2d, oro, t2m, dpt2m, wetness, recmol + real(kind=kind_phys), dimension(ims:ime, nlcat), intent(in) :: vegtype_frac real(kind=kind_phys), dimension(ims:ime, nsoil), intent(in) :: smc real(kind=kind_phys), dimension(ims:ime, 12, 5), intent(in) :: dust12m_in - real(kind=kind_phys), dimension(ims:ime, 24, 3), intent(in) :: smoke_RRFS - real(kind=kind_phys), dimension(ims:ime, 1), intent(in) :: emi_in + real(kind=kind_phys), dimension(ims:ime, 24, 2), intent(in) :: smoke_RRFS +! This is a place holder for ebb_dcycle == 2, currently set to hold a single +! value, which is the previous day's average of hwp, frp, ebb, fire_end + real(kind=kind_phys), dimension(ims:ime, 4), intent(in) :: smoke2d_RRFS + real(kind=kind_phys), dimension(ims:ime, 1), intent(in) :: emi_ant_in real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & - phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w + phl3d,tk3d,prl3d,us3d,vs3d,spechum,w real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 @@ -547,53 +639,60 @@ subroutine rrfs_smoke_prep( & real(kind_phys), dimension(ims:ime, jms:jme),intent(out) :: ebu_in - real(kind_phys), dimension(ims:ime, jms:jme, num_frp_plume), intent(out) :: plume_frp integer,dimension(ims:ime, jms:jme), intent(out) :: isltyp, ivgtyp real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, & - zmid, exch_h, rel_hum + zmid, pi_phy, theta_phy, wind_phy real(kind_phys), dimension(ims:ime, jms:jme), intent(out) :: & - u10, v10, ust, tsk, xland, xlat, xlong, dxy, vegfrac, rmol, swdown, znt, & - pbl, hfx, snowh, clayf, rdrag, sandf, ssm, uthr + u10, v10, ust, tsk, xland, xlat, xlong, dxy, rmol, swdown, znt, & + pbl, hfx, snowh, clayf, rdrag, sandf, ssm, uthr, hwp_local + real(kind_phys), dimension(ims:ime, nlcat, jms:jme), intent(out) :: vegfrac real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w real(kind_phys), dimension(ims:ime, nsoil, jms:jme), intent(out) :: smois - real(kind_phys), dimension(ims:ime), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr - real(kind_phys), dimension(ims:ime), intent(inout) :: emis_anoc - !real(kind_phys), dimension(ims:ime, jms:jme, num_plume_data) :: plume + real(kind_phys), dimension(ims:ime,jms:jme), intent(inout) :: frp_in, fire_end_hr, fhist, coef_bb_dc + real(kind_phys), dimension(ims:ime,jms:jme), intent(inout) :: hwp_day_avg, peak_hr + real(kind_phys), dimension(ims:ime), intent(inout) :: emis_anoc,ebb_smoke_in real(kind_phys), parameter :: conv_frp = 1.e+06_kind_phys ! FRP conversion factor, MW to W - real(kind_phys), parameter :: frpc = 1._kind_phys ! FRP conversion factor (Regional) + real(kind_phys), parameter :: frpc = 1._kind_phys ! FRP conversion factor (Regional) ! -- local variables - integer i,ip,j,k,kp,kk,kkp,nv,l,ll,n + integer i,ip,j,k,k1,kp,kk,kkp,nv,l,ll,n,nl + real(kind_phys) :: SFCWIND,WIND,DELWIND,DZ,wdgust,snoweq,THETA + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme) :: THETAV + real(kind_phys), dimension(ims:ime, jms:jme) :: windgustpot + real(kind_phys), dimension(ims:ime, jms:jme), intent(out) :: kpbl_thetav + real(kind_phys), parameter :: delta_theta4gust = 0.5 + real(kind=kind_phys),parameter :: p1000mb = 100000. ! -- initialize fire emissions - !plume = 0._kind_phys - plume_frp = 0._kind_phys ebu_in = 0._kind_phys - ebb_smoke_hr = 0._kind_phys + ebb_smoke_in = 0._kind_phys emis_anoc = 0._kind_phys - frp_hr = 0._kind_phys - frp_std_hr = 0._kind_phys + frp_in = 0._kind_phys + hwp_day_avg = 0._kind_phys + fire_end_hr = 0._kind_phys ! -- initialize output arrays isltyp = 0._kind_phys ivgtyp = 0._kind_phys rri = 0._kind_phys t_phy = 0._kind_phys + theta_phy = 0._kind_phys u_phy = 0._kind_phys v_phy = 0._kind_phys + wind_phy = 0._kind_phys p_phy = 0._kind_phys + pi_phy = 0._kind_phys rho_phy = 0._kind_phys dz8w = 0._kind_phys p8w = 0._kind_phys t8w = 0._kind_phys vvel = 0._kind_phys zmid = 0._kind_phys - exch_h = 0._kind_phys u10 = 0._kind_phys v10 = 0._kind_phys ust = 0._kind_phys @@ -617,7 +716,6 @@ subroutine rrfs_smoke_prep( & moist = 0._kind_phys chem = 0._kind_phys z_at_w = 0._kind_phys - rel_hum = 0._kind_phys do i=its,ite u10 (i,1)=u10m (i) @@ -638,12 +736,14 @@ subroutine rrfs_smoke_prep( & sandf(i,1)=dust12m_in(i,current_month,3) ssm (i,1)=dust12m_in(i,current_month,4) uthr (i,1)=dust12m_in(i,current_month,5) - ivgtyp (i,1)=vegtype(i) + ivgtyp (i,1)=vegtype_dom (i) isltyp (i,1)=soiltyp(i) - vegfrac(i,1)=sigmaf (i) + do nl = 1,nlcat + vegfrac(i,nl,1)=vegtype_frac (i,nl) + enddo + rmol (i,1)=recmol (i) enddo - rmol=0. do k=1,nsoil do j=jts,jte @@ -686,38 +786,28 @@ subroutine rrfs_smoke_prep( & p_phy(i,k,j)=prl3d(i,kkp) u_phy(i,k,j)=us3d(i,kkp) v_phy(i,k,j)=vs3d(i,kkp) - rho_phy(i,k,j)=p_phy(i,k,j)/(con_rd*t_phy(i,k,j)*(1.+con_fv*spechum(i,kkp))) + pi_phy(i,k,j) = con_cp*(p_phy(i,k,j)/p1000mb)**(con_rd/con_cp) + theta_phy(i,k,j) = t_phy(i,k,j)/pi_phy(i,k,j)*con_cp + wind_phy(i,k,j) = sqrt(u_phy(i,k,j)**2 + v_phy(i,k,j)**2) + ! from mp_thompson.F90 ; rho = con_eps*prsl/(con_rd*tgrs*(qv+con_eps)) + ! from mynnd + rho_phy(i,k,j)=p_phy(i,k,j)/(con_rd*t_phy(i,k,j)) !*(1.+con_fv*spechum(i,kkp))) rri(i,k,j)=1./rho_phy(i,k,j) vvel(i,k,j)=-w(i,kkp)*rri(i,k,j)/g moist(i,k,j,:)=0. moist(i,k,j,1)=gq0(i,kkp,p_atm_shum) if (t_phy(i,k,j) > 265.) then moist(i,k,j,2)=gq0(i,kkp,p_atm_cldq) - moist(i,k,j,3)=0. if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. else moist(i,k,j,2)=0. - moist(i,k,j,3)=gq0(i,kkp,p_atm_cldq) - if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. endif - !rel_hum(i,k,j) = min(0.95,spechum(i,kkp)) - rel_hum(i,k,j) = min(0.95, moist(i,k,j,1) / & - (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & - (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) - rel_hum(i,k,j) = max(0.1,rel_hum(i,k,j)) !-- zmid(i,k,j)=phl3d(i,kkp)/g enddo enddo enddo - ! -- the imported atmospheric heat diffusivity is only available up to kte-1 - do k=kts,kte-1 - do i=its,ite - exch_h(i,k,1)=exch(i,k) - enddo - enddo - do j=jts,jte do k=2,kte do i=its,ite @@ -735,24 +825,110 @@ subroutine rrfs_smoke_prep( & ! -- anthropogenic organic carbon do i=its,ite - emis_anoc(i) = emi_in(i,1) + emis_anoc(i) = emi_ant_in(i,1) enddo - if (hour_int<24) then - do j=jts,jte - do i=its,ite - ebb_smoke_hr(i) = smoke_RRFS(i,hour_int+1,1) ! smoke - frp_hr (i) = smoke_RRFS(i,hour_int+1,2) ! frp - frp_std_hr (i) = smoke_RRFS(i,hour_int+1,3) ! std frp - ebu_in (i,j) = ebb_smoke_hr(i) - plume_frp(i,j,p_frp_hr ) = conv_frp* frp_hr (i) - plume_frp(i,j,p_frp_std) = conv_frp* frp_std_hr (i) - enddo - enddo +!---- Calculate PBLH and K-PBL based on virtual potential temperature profile +!---- First calculate THETAV + do j = jts,jte + do i = its,ite + do k = kts,kte + THETA = t_phy(i,k,j) * (1.E5/p_phy(i,k,j))**0.286 + THETAV(i,k,j) = THETA * (1. + 0.61 * (moist(i,k,j,p_qv))) + enddo + enddo + enddo +!---- Now use the UPP code to deterimine the height and level + do i = its, ite + do j = jts, jte + if ( THETAV(i,kts+1,j) .lt. ( THETAV(i,kts,j) + delta_theta4gust) ) then + do k = kts+1, kte + k1 = k +!--- give theta-v at the sfc a 0.5K boost in the PBLH definition + if ( THETAV(i,kts+k-1,j) .gt. ( THETAV(i,kts,j) + delta_theta4gust) ) then + exit + endif + enddo + kpbl_thetav(i,j) = k1 + else + kpbl_thetav(i,j) = kts + 1 + endif + enddo + enddo + +!---- Calculate wind gust potential and HWP + do i = its,ite + SFCWIND = sqrt(u10m(i)**2+v10m(i)**2) + windgustpot(i,1) = SFCWIND + if (kpbl_thetav(i,1)+1 .ge. kts+1 ) then + do k=kts+1,int(kpbl_thetav(i,1))+1 + WIND = sqrt(us3d(i,k)**2+vs3d(i,k)**2) + DELWIND = WIND - SFCWIND + DZ = zmid(i,k,1) - oro(i) + DELWIND = DELWIND*(1.0-MIN(0.5,DZ/2000.)) + windgustpot(i,1) = max(windgustpot(i,1),SFCWIND+DELWIND) + enddo + endif + enddo + hwp_local = 0. + do i=its,ite + wdgust=max(windgustpot(i,1),3.) + snoweq=max((25.-snow_cpl(i))/25.,0.) + hwp_local(i,1)=0.177*wdgust**0.97*max(t2m(i)-dpt2m(i),15.)**1.03*((1.-wetness(i))**0.4)*snoweq ! Eric update 11/2023 + enddo +! Set paramters for ebb_dcycle option + if (ebb_dcycle == 1 ) then + if (hour_int .le. 24) then + do j=jts,jte + do i=its,ite + + ebu_in (i,j) = smoke_RRFS(i,hour_int+1,1) ! smoke + frp_in (i,j) = smoke_RRFS(i,hour_int+1,2)*conv_frp ! frp + fire_end_hr(i,j) = 0.0 + hwp_day_avg(i,j) = 0.0 + ebb_smoke_in (i) = ebu_in(i,j) + enddo + enddo + endif endif + ! RAR: here we need to initialize various arrays in order to apply HWP to + ! diurnal cycle + ! if ebb_dcycle/=2 then those arrays=0, we need to read in temporal + if (ebb_dcycle == 2) then + do i=its, ite + do j=jts, jte + ebu_in (i,j) = smoke2d_RRFS(i,1)!/86400. + frp_in (i,j) = smoke2d_RRFS(i,2)*conv_frp + fire_end_hr (i,j) = smoke2d_RRFS(i,3) + hwp_day_avg (i,j) = smoke2d_RRFS(i,4) + ebb_smoke_in(i ) = ebu_in(i,j) + enddo + enddo + end if - ! We will add a namelist variable, real :: flam_frac_global + if (ktau==1) then + do j=jts,jte + do i=its,ite + fhist (i,j) = 1. + coef_bb_dc (i,j) = 1. + if (xlong(i,j)<230.) then + peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska + elseif(xlong(i,j)<245.) then + peak_hr(i,j)= 23.0* 3600. + elseif (xlong(i,j)<260.) then + peak_hr(i,j)= 22.0* 3600. ! peak at 22 UTC, fires in the western US + elseif (xlong(i,j)<275.) then + peak_hr(i,j)= 21.0* 3600. + elseif (xlong(i,j)<290.) then ! peak at 20 UTC, fires in the eastern US + peak_hr(i,j)= 20.0* 3600. + else + peak_hr(i,j)= 19.0* 3600. + endif + enddo + enddo + endif + ! We will add a namelist variable, real :: flam_frac_global do k=kms,kte do i=ims,ime chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke )) @@ -761,9 +937,8 @@ subroutine rrfs_smoke_prep( & enddo enddo - - end subroutine rrfs_smoke_prep + !> @} end module rrfs_smoke_wrapper diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta index 498f5fddd..b85596155 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.meta +++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta @@ -1,9 +1,191 @@ [ccpp-table-properties] name = rrfs_smoke_wrapper type = scheme - dependencies = dep_dry_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90,coarsepm_settling_mod.F90 + dependencies = ../hooks/machine.F,dep_dry_simple_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90,coarsepm_settling_mod.F90, dep_dry_mod_emerson.F90,dep_data_mod.F90 ######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_init + type = scheme +[seas_opt_in] + standard_name = control_for_smoke_sea_salt + long_name = rrfs smoke sea salt emission option + units = index + dimensions = () + type = integer + intent = in +[drydep_opt_in] + standard_name = control_for_smoke_dry_deposition + long_name = rrfs smoke dry deposition option + units = index + dimensions = () + type = integer + intent = in +[pm_settling_in] + standard_name = control_for_smoke_pm_settling + long_name = rrfs smoke pm settling option + units = index + dimensions = () + type = integer + intent = in +[wetdep_ls_opt_in] + standard_name = control_for_smoke_wet_deposition + long_name = rrfs smoke large scale wet deposition option + units = index + dimensions = () + type = integer + intent = in +[wetdep_ls_alpha_in] + standard_name = alpha_for_ls_wet_depoistion + long_name = alpha paramter for ls wet deposition + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[add_fire_heat_flux_in] + standard_name = flag_for_fire_heat_flux + long_name = flag to add fire heat flux to LSM + units = flag + dimensions = () + type = logical + intent = in +[do_plumerise_in] + standard_name = do_smoke_plumerise + long_name = rrfs smoke plumerise option + units = index + dimensions = () + type = logical + intent = in +[plumerisefire_frq_in] + standard_name = smoke_plumerise_frequency + long_name = rrfs smoke add smoke option + units = min + dimensions = () + type = integer + intent = in +[plume_wind_eff_in] + standard_name = option_for_wind_effects_on_smoke_plumerise + long_name = wind effect plumerise option + units = index + dimensions = () + type = integer + intent = in +[addsmoke_flag_in] + standard_name = control_for_smoke_biomass_burning_emissions + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + intent = in +[ebb_dcycle_in] + standard_name = control_for_diurnal_cycle_of_biomass_burning_emissions + long_name = rrfs smoke diurnal cycle option + units = index + dimensions = () + type = integer + intent = in +[smoke_forecast_in] + standard_name = do_smoke_forecast + long_name = index for rrfs smoke forecast + units = index + dimensions = () + type = integer + intent = in +[dust_opt_in] + standard_name = control_for_smoke_dust + long_name = rrfs smoke dust chem option + units = index + dimensions = () + type = integer + intent = in +[dust_alpha_in] + standard_name = alpha_fengsha_dust_scheme + long_name = alpha paramter for fengsha dust scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[dust_gamma_in] + standard_name = gamma_fengsha_dust_scheme + long_name = gamma paramter for fengsha dust scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[dust_moist_opt_in] + standard_name = control_for_dust_soil_moisture_option + long_name = smoke dust moisture parameterization 1 - fecan 2 - shao + units = index + dimensions = () + type = integer + active = (do_smoke_coupling) + intent = in +[dust_moist_correction_in] + standard_name = dust_moist_correction_fengsha_dust_scheme + long_name = moisture correction term for fengsha dust emission + units = none + dimensions = () + type = real + kind = kind_phys + active = (do_smoke_coupling) + intent = in +[dust_drylimit_factor_in] + standard_name = dust_drylimit_factor_fengsha_dust_scheme + long_name = moisture correction term for drylimit in fengsha dust emission + units = none + dimensions = () + type = real + kind = kind_phys + active = (do_smoke_coupling) + intent = in +[aero_ind_fdb_in] + standard_name = do_smoke_aerosol_indirect_feedback + long_name = flag for rrfs wfa ifa emission + units = flag + dimensions = () + type = logical + intent = in +[extended_sd_diags_in] + standard_name = flag_for_extended_smoke_dust_diagnostics + long_name = flag for extended smoke dust diagnostics + units = flag + dimensions = () + type = logical + intent = in +[dbg_opt_in] + standard_name = do_smoke_debug + long_name = flag for rrfs smoke plumerise debug + units = flag + dimensions = () + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +##################################################################### [ccpp-arg-table] name = rrfs_smoke_wrapper_run type = scheme @@ -224,21 +406,21 @@ kind = kind_phys intent = in [nsoil] - standard_name = vertical_dimension_of_soil - long_name = soil vertical layer dimension + standard_name = vertical_dimension_of_soil_internal_to_land_surface_scheme + long_name = number of soil layers internal to land surface model units = count dimensions = () type = integer intent = in [smc] - standard_name = volume_fraction_of_condensed_water_in_soil - long_name = volumetric fraction of soil moisture + standard_name = volume_fraction_of_soil_moisture_for_land_surface_model + long_name = volumetric fraction of soil moisture for lsm units = frac - dimensions = (horizontal_loop_extent,vertical_dimension_of_soil) + dimensions = (horizontal_loop_extent,vertical_dimension_of_soil_internal_to_land_surface_scheme) type = real kind = kind_phys intent = inout -[vegtype] +[vegtype_dom] standard_name = vegetation_type_classification long_name = vegetation type at each grid cell units = index @@ -252,11 +434,18 @@ dimensions = (horizontal_loop_extent) type = integer intent = in -[sigmaf] - standard_name = bounded_vegetation_area_fraction - long_name = areal fractional cover of green vegetation bounded on the bottom +[nlcat] + standard_name = number_of_vegetation_categories + long_name = number of vegetation categories + units = count + dimensions = () + type = integer + intent = in +[vegtype_frac] + standard_name = fraction_of_vegetation_category + long_name = fraction of horizontal grid area occupied by given vegetation category units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_loop_extent,number_of_vegetation_categories) type = real kind = kind_phys intent = in @@ -292,6 +481,14 @@ type = real kind = kind_phys intent = in +[recmol] + standard_name = reciprocal_of_obukhov_length + long_name = one over obukhov length + units = m-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [idat] standard_name = date_and_time_at_model_initialization_in_iso_order long_name = initialization date and time @@ -315,14 +512,6 @@ type = real kind = kind_phys intent = in -[exch] - standard_name = atmosphere_heat_diffusivity - long_name = diffusivity for heat - units = m2 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [hf2d] standard_name = instantaneous_surface_upward_sensible_heat_flux long_name = surface upward sensible heat flux valid for current call @@ -379,7 +568,7 @@ type = real kind = kind_phys intent = in -[emi_in] +[emi_ant_in] standard_name = anthropogenic_background_input long_name = anthropogenic background input units = various @@ -391,7 +580,15 @@ standard_name = emission_smoke_RRFS long_name = emission fire RRFS units = various - dimensions = (horizontal_loop_extent,24,3) + dimensions = (horizontal_loop_extent,24,2) + type = real + kind = kind_phys + intent = in +[smoke2d_RRFS] + standard_name = emission_smoke_prvd_RRFS + long_name = emission fire RRFS daily + units = various + dimensions = (horizontal_loop_extent,4) type = real kind = kind_phys intent = in @@ -515,7 +712,7 @@ type = real kind = kind_phys intent = inout -[ebb_smoke_hr] +[ebb_smoke_in] standard_name = surface_smoke_emission long_name = emission of surface smoke units = ug m-2 s-1 @@ -523,7 +720,7 @@ type = real kind = kind_phys intent = inout -[frp_hr] +[frp_output] standard_name = frp_hourly long_name = hourly fire radiative power units = MW @@ -531,14 +728,6 @@ type = real kind = kind_phys intent = inout -[frp_std_hr] - standard_name = frp_std_hourly - long_name = hourly stdandard deviation of fire radiative power - units = MW - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout [coef_bb] standard_name = coef_bb_dc long_name = coef to estimate the fire emission @@ -579,6 +768,22 @@ type = real kind = kind_phys intent = inout +[drydep_flux_out] + standard_name = dry_deposition_flux + long_name = rrfs dry deposition flux + units = ug m-2 + dimensions = (horizontal_loop_extent,number_of_chemical_species_deposited) + type = real + kind = kind_phys + intent = inout +[wetdpr] + standard_name = mp_wet_deposition_smoke_dust + long_name = large scale wet deposition of smoke and dust + units = kg kg-1 + dimensions = (horizontal_loop_extent,number_of_chemical_species_vertically_mixed) + type = real + kind = kind_phys + intent = inout [hwp] standard_name = hourly_wildfire_potential long_name = rrfs hourly fire weather potential @@ -587,6 +792,14 @@ type = real kind = kind_phys intent = out +[hwp_ave] + standard_name = hourly_wildfire_potential_average + long_name = rrfs hourly fire weather potential average + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [wetness] standard_name = normalized_soil_wetness_for_land_surface_model long_name = normalized soil wetness @@ -595,22 +808,6 @@ type = real kind = kind_phys intent = in -[smoke_ext] - standard_name = extinction_coefficient_in_air_due_to_smoke - long_name = extinction coefficient in air due to smoke - units = various - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[dust_ext] - standard_name = extinction_coefficient_in_air_due_to_dust - long_name = extinction coefficient in air due to dust - units = various - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out [ndvel] standard_name = number_of_chemical_species_deposited long_name = number of chemical pbl deposited @@ -626,29 +823,6 @@ type = real kind = kind_phys intent = inout -[rrfs_sd] - standard_name = do_smoke_coupling - long_name = flag controlling rrfs_sd collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[dust_alpha_in] - standard_name = alpha_fengsha_dust_scheme - long_name = alpha paramter for fengsha dust scheme - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[dust_gamma_in] - standard_name = gamma_fengsha_dust_scheme - long_name = gamma paramter for fengsha dust scheme - units = none - dimensions = () - type = real - kind = kind_phys - intent = in [fire_in] standard_name = smoke_fire_auxiliary_input long_name = smoke fire auxiliary input variables @@ -672,90 +846,36 @@ dimensions = () type = logical intent = in -[seas_opt_in] - standard_name = control_for_smoke_sea_salt - long_name = rrfs smoke sea salt emission option - units = index - dimensions = () - type = integer - intent = in -[dust_opt_in] - standard_name = control_for_smoke_dust - long_name = rrfs smoke dust chem option - units = index - dimensions = () - type = integer - intent = in -[drydep_opt_in] - standard_name = control_for_smoke_dry_deposition - long_name = rrfs smoke dry deposition option - units = index - dimensions = () - type = integer - intent = in -[coarsepm_settling_in] - standard_name = control_for_smoke_coarsepm_settling - long_name = rrfs smoke coarsepm settling option - units = index - dimensions = () - type = integer - intent = in -[wetdep_ls_opt_in] - standard_name = control_for_smoke_wet_deposition - long_name = rrfs smoke large scale wet deposition option - units = index - dimensions = () - type = integer - intent = in -[wetdep_ls_alpha_in] - standard_name = alpha_for_ls_wet_depoistion - long_name = alpha paramter for ls wet deposition - units = none - dimensions = () +[fire_heat_flux_out] + standard_name = surface_fire_heat_flux + long_name = heat flux of fire at the surface + units = W m-2 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in -[do_plumerise_in] - standard_name = do_smoke_plumerise - long_name = rrfs smoke plumerise option - units = index - dimensions = () - type = logical - intent = in -[plumerisefire_frq_in] - standard_name = smoke_plumerise_frequency - long_name = rrfs smoke add smoke option - units = min - dimensions = () - type = integer - intent = in -[addsmoke_flag_in] - standard_name = control_for_smoke_biomass_burning_emissions - long_name = rrfs smoke add smoke option - units = index - dimensions = () - type = integer - intent = in -[smoke_forecast_in] - standard_name = do_smoke_forecast - long_name = index for rrfs smoke forecast + intent = out +[frac_grid_burned_out] + standard_name = fraction_of_grid_cell_burning + long_name = ration of the burnt area to the grid cell area + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = PBL top model level index units = index - dimensions = () + dimensions = (horizontal_loop_extent) type = integer intent = in -[aero_ind_fdb_in] - standard_name = do_smoke_aerosol_indirect_feedback - long_name = flag for rrfs wfa ifa emission - units = flag - dimensions = () - type = logical - intent = in -[dbg_opt_in] - standard_name = do_smoke_debug - long_name = flag for rrfs smoke plumerise debug - units = flag - dimensions = () - type = logical +[oro] + standard_name = height_above_mean_sea_level + long_name = height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys intent = in [errmsg] standard_name = ccpp_error_message diff --git a/physics/smoke_dust/seas_mod.F90 b/physics/smoke_dust/seas_mod.F90 index 1d18046ad..e5e63e909 100755 --- a/physics/smoke_dust/seas_mod.F90 +++ b/physics/smoke_dust/seas_mod.F90 @@ -185,7 +185,6 @@ subroutine gocart_seasalt_driver(dt,alt,t_phy,u_phy, & chem(i,kts,j,p_seas_3) = chem(i,kts,j,p_seas_3) + tc(3)*converi chem(i,kts,j,p_seas_4) = chem(i,kts,j,p_seas_4) + tc(4)*converi chem(i,kts,j,p_seas_5) = chem(i,kts,j,p_seas_5) + tc(5)*converi - !print*,'hli tc(2),chem(i,kts,j,p_seas_2)',tc(2),chem(i,kts,j,p_seas_2) ! for output diagnostics emis_seas(i,1,j,p_eseas1) = bems(1) diff --git a/physics/funcphys.f90 b/physics/tools/funcphys.f90 similarity index 100% rename from physics/funcphys.f90 rename to physics/tools/funcphys.f90 diff --git a/physics/get_phi_fv3.F90 b/physics/tools/get_phi_fv3.F90 similarity index 100% rename from physics/get_phi_fv3.F90 rename to physics/tools/get_phi_fv3.F90 diff --git a/physics/get_phi_fv3.meta b/physics/tools/get_phi_fv3.meta similarity index 97% rename from physics/get_phi_fv3.meta rename to physics/tools/get_phi_fv3.meta index cbca14080..5c162c746 100644 --- a/physics/get_phi_fv3.meta +++ b/physics/tools/get_phi_fv3.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = get_phi_fv3 type = scheme - dependencies = machine.F,physcons.F90 + dependencies = ../hooks/machine.F,../hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/get_prs_fv3.F90 b/physics/tools/get_prs_fv3.F90 similarity index 100% rename from physics/get_prs_fv3.F90 rename to physics/tools/get_prs_fv3.F90 diff --git a/physics/get_prs_fv3.meta b/physics/tools/get_prs_fv3.meta similarity index 98% rename from physics/get_prs_fv3.meta rename to physics/tools/get_prs_fv3.meta index c26f5c308..4cdad7566 100644 --- a/physics/get_prs_fv3.meta +++ b/physics/tools/get_prs_fv3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = get_prs_fv3 type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table]