From d0eb0f1c133589ef092711e14128da2f3bb76f19 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Wed, 15 Jul 2026 16:36:22 -0400 Subject: [PATCH 01/25] Added some of Ted's p3 testing changes/runtime switches. Added runtime switch to turn on/off the new category-based initiation option --- src/cm1.F | 20 +- src/module_mp_p3.F | 575 +++++++++++++++++++++++++++++++++------- src/mp_driver.F | 581 ++++++++++++++++++++++++++++++++++++++--- src/param.F | 399 ++++++++++++++++++++++++++-- src/radiation_driver.F | 27 +- src/writeout.F | 36 +-- 6 files changed, 1433 insertions(+), 205 deletions(-) diff --git a/src/cm1.F b/src/cm1.F index 19b2578..32c77b1 100644 --- a/src/cm1.F +++ b/src/cm1.F @@ -7,7 +7,7 @@ program cm1 ! 20 April 2022 ! https://www2.mmm.ucar.edu/people/bryan/cm1/ ! -! (c)2022 - University Corporation for Atmospheric Research +! (c)2022 - University Corporation for Atmospheric Research ! !----------------------------------------------------------------------------- ! @@ -269,7 +269,7 @@ program cm1 #ifdef MPI integer :: reqs,rc,ii,jj,id,itmp1,itmp2,jtmp1,jtmp2 integer, dimension(MPI_STATUS_SIZE) :: status - real :: mp_total,minvalue,temx,temy,temni,temnj ! Changed "minval" to "minvalue" here because it was overriding + real :: mp_total,minvalue,temx,temy,temni,temnj ! Changed "minval" to "minvalue" here because it was overriding ! the built-in function "minval" and causing an "Unclassifiable statement" error double precision :: tstart,tend integer, dimension(:), allocatable :: isum,jsum @@ -391,7 +391,7 @@ program cm1 cm1rversion = 21.0 !---------------------------------------------------------------------- -! For arbitrary 3d output array: +! For arbitrary 3d output array: ! ! nout3d is the total number of output variables. ! @@ -399,14 +399,14 @@ program cm1 ! fill in the out3d(i,j,k,1) and out3d(i,j,k,2) etc arrays with the ! information you wish to write out.) ! -! No other changes are necessary: output file will contain the +! No other changes are necessary: output file will contain the ! variables "out1", "out2", "out3", ... etc. ! nout3d = 3 nout3d = 19 !---------------------------------------------------------------------- -! For arbitrary 2d output array: +! For arbitrary 2d output array: ! ! nout2d is the total number of output variables. ! @@ -414,7 +414,7 @@ program cm1 ! fill in the out2d(i,j,1) and out3d(i,j,2) etc arrays with the ! information you wish to write out.) ! -! No other changes are necessary: output file will contain the +! No other changes are necessary: output file will contain the ! variables "out2d1", "out2d2", "out2d3", ... etc. nout2d = 2 @@ -2689,7 +2689,7 @@ program cm1 if(dowr) write(outfile,*) ' restart_read time = ',time_misc if(dowr) write(outfile,*) ! In case user wants to change values on a restart: - IF( restart_reset_frqtim )THEN + IF( restart_reset_frqtim )THEN if( statfrq.gt.1.0e-6 ) stattim = mtime + statfrq if( tapfrq.gt.1.0e-6 ) taptim = mtime + tapfrq if( rstfrq.gt.1.0e-6 ) rsttim = mtime + rstfrq @@ -2905,7 +2905,7 @@ program cm1 call read_lsnudge(lsnudge_u,lsnudge_v,lsnudge_th,lsnudge_qv,sngl(mtime),zh) - ! 190407: moved this from lsnudge_module + ! 190407: moved this from lsnudge_module !!! lsnudge_tau = var1 ! time scale (seconds) for damping !!! lsnudge_start = var2 ! time (seconds) to begin large-scale nudging !!! lsnudge_end = var3 ! time (seconds) to end large-scale nudging @@ -2994,7 +2994,7 @@ program cm1 adtlast = dbldt - ! adaptive dt if starting CM1 for first time + ! adaptive dt if starting CM1 for first time ! (ie, not a restart) call calccflquick(dt,uh,vh,mh,u3d,v3d,w3d,reqc) @@ -3390,7 +3390,7 @@ program cm1 effc,effi,effs,effr,effg,effis, & tdiag,qdiag,out2d,out3d, & dowriteout,dorad,dotdwrite,doazimwrite,dorestart, & - getdbz,getvt,dotbud,doqbud) + getdbz,getvt,dotbud,doqbud,qunit) endif ENDIF diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 45f3c5d..80999d2 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -89,6 +89,11 @@ MODULE microphy_p3 ! integer switch for warm rain autoconversion/accretion schemes integer :: iparam +! integer switch for primary ice nucleation (ERM) + integer :: iparamice + + logical :: log_nislf ! flag for ice self-aggregation + logical :: log_maxnsmall ! number of diagnostic ice-phase hydrometeor types integer, public, parameter :: n_qiType = 6 @@ -111,15 +116,26 @@ MODULE microphy_p3 vi,epsm,rhoa,map,ma,rr,bact,inv_rm1,inv_rm2,sig1,nanew1,f11,f21,sig2, & nanew2,f12,f22,pi,thrd,sxth,piov3,piov6,rho_rimeMin, & rho_rimeMax,inv_rho_rimeMax,max_total_Ni,dbrk,nmltratio,minVIS, & - maxVIS,mu_i_initial,mu_r_constant,inv_Drmax,Dmin_HM,Dinit_HM - + maxVIS,mu_i_initial,mu_r_constant,inv_Drmax,ntiny,Dmin_HM,Dinit_HM + real, parameter :: rho00 = 1.225 ! ERM integer :: n_iceCat = -1 !used for GEM interface + ! Added by ERM + integer :: rssflg = 1 ! Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value + integer :: sssflg = 1 ! As above but for ice (all ice) + integer :: ccn_on = 0 + integer :: merge_opt = 1 ! 0 = no merging; 1 = diameter-difference merge (original); 2 = percent difference in diam. (Cholette 2024) + integer :: qrcol_opt = 0 ! 0 = no size check on qrcol; 1 = only allow qrcol for ice larger than rain + ! for merge_opt=0 with qrcol_opt=2 and ncat=2, this disables qrcol for iice=2 + logical :: cat_init_new_default = .true. ! default for mechanism-based ice category initialization + ! End ERM contains !==================================================================================================! - subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err,dowr) + subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err,dowr, & + nanew1_in,iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt,iparamice_in, & + rssflg_in,sssflg_in,max_total_Ni_in,cat_init_new_in) !------------------------------------------------------------------------------------------! ! This subroutine initializes all physical constants and parameters needed by the P3 ! @@ -143,7 +159,12 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err logical, intent(in), optional :: abort_on_err ! abort when an error is encountered [.false.] character(len=*), intent(in), optional :: model ! driving model logical, intent(in), optional :: dowr - + ! Added by ERM + real, intent(in), optional :: nanew1_in, max_total_Ni_in + integer, intent(in), optional :: iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt, & + iparamice_in,rssflg_in,sssflg_in + logical, intent(in), optional :: cat_init_new_in + ! End ERM ! Local variables and parameters: logical, save :: is_init = .false. character(len=1024), parameter :: version_p3 = '5.4.1' @@ -199,13 +220,32 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err ! maximum total ice concentration (sum of all categories) max_total_Ni = 2000.e+3 !(m) + IF ( present( max_total_Ni_in ) ) max_total_Ni = max_total_Ni_in ! Added by ERM ! switch for warm-rain parameterization ! = 1 Seifert and Beheng 2001 ! = 2 Beheng 1994 ! = 3 Khairoutdinov and Kogan 2000 ! = 4 Kogan 2013 - iparam = 3 + iparam = 3 ! set default +! Below added by ERM + IF ( present( iparam_in ) ) iparam = iparam_in + + IF ( present( iparamice_in ) ) iparamice = iparamice_in + IF ( present( rssflg_in ) ) rssflg = rssflg_in + IF ( present( sssflg_in ) ) sssflg = sssflg_in + IF ( present( p3_ccn_on ) ) ccn_on = p3_ccn_on + IF ( present( p3_merge_opt ) ) merge_opt = p3_merge_opt + IF ( present( p3_qrcol_opt ) ) qrcol_opt = p3_qrcol_opt + IF ( present( cat_init_new_in ) ) cat_init_new_default = cat_init_new_in + log_nislf = .true. ! flag for ice self-aggregation + log_maxnsmall = .true. !flag for resetting n up to nsmall + +! Primary ice nucleation +! 1 = Cooper +! 2 = Meyers-Ferrier + iparamice = 1 +! End ERM ! droplet concentration (m-3) nccnst = 200.e+6 @@ -218,7 +258,7 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err cp = 1005. inv_cp = 1./cp g = 9.816 - rd = 287.15 + rd = 287.05 ! Corrected from 287.15 - ERM detected, I think rv = 461.51 ep_2 = 0.622 rhosur = 100000./(rd*273.15) @@ -242,8 +282,9 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err inv_rho_rimeMax = 1./rho_rimeMax ! minium allowable prognostic variables - qsmall = 1.e-14 - nsmall = 1.e-16 + qsmall = 1.e-12 ! 1.e-14 Mod by ERM + nsmall = 1.e-8 ! 1.e-16 Mod by ERM + ntiny = nsmall ! *1.e-8 ! 1.e-16 Added by ERM bsmall = qsmall*inv_rho_rimeMax zsmall = 1.e-35 @@ -261,7 +302,7 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err bcn = 2. ! mean size for soft lambda_r limiter [microns] - dbrk = 3000.e-6 + dbrk = 3000.e-6 ! 600.0e-6 Mod by DTD ! ratio of rain number produced to ice number loss from melting ! Note: this is not needed with the prognostic qi,liq nmltratio = 1. @@ -296,7 +337,8 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err ! mode 1 inv_rm1 = 2.e+7 ! inverse aerosol mean size (m-1) sig1 = 2.0 ! aerosol standard deviation - nanew1 = 1500.e6 ! aerosol number mixing ratio (kg-1) DTD changed from 300.e6 + nanew1 = 300.e6 ! aerosol number mixing ratio (kg-1) + IF ( present( nanew1_in ) ) nanew1 = nanew1_in/rho00 ! ERM f11 = 0.5*exp(2.5*(log(sig1))**2) f21 = 1. + 0.25*log(sig1) @@ -762,7 +804,7 @@ END subroutine p3_init #ifndef ECCCGEM SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimestep, & - rainnc,rainncv,sr,snownc,snowncv, & + rainnc,rainncv,sr,snownc,snowncv, & ids, ide, jds, jde, kds, kde , & ims, ime, jms, jme, kms, kme , & its, ite, jts, jte, kts, kte , & @@ -771,8 +813,8 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes qit_2, qni_2, qir_2, qib_2, diag_vmi_2, diag_dmi_2, diag_rhoi_2, qzi_2, qli_2, & qit_3, qni_3, qir_3, qib_3, diag_vmi_3, diag_dmi_3, diag_rhoi_3, qzi_3, qli_3, & qit_4, qni_4, qir_4, qib_4, diag_vmi_4, diag_dmi_4, diag_rhoi_4, qzi_4, qli_4, & - nc, diag2d_01, diag2d_02, diag3d_01, diag3d_02, diag3d_03, & - diag_dhmax_1, diag_dhmax_2, diag_dhmax_3, diag_dhmax_4, j_index) ! DTD added j index for debugging + nc, cn, diag2d_01, diag2d_02, diag3d_01, diag3d_02, diag3d_03, & ! ERM added cn + diag_dhmax_1, diag_dhmax_2, diag_dhmax_3, diag_dhmax_4, diagflag, j_index) ! DTD added j index for debugging, ERM added diagflag !------------------------------------------------------------------------------------------! ! This is the main WRF interface with the P3 microphysics scheme. ! @@ -834,7 +876,7 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: th,qv,qc,qr,qnr,th_old,qv_old, & diag_zdbz,diag_effc, & qit_1,qni_1,qir_1,qib_1 - real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: nc + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: nc, cn ! ERM added cn real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qzi_1 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qli_1 @@ -875,13 +917,14 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes real, intent(in) :: dt integer, intent(in) :: itimestep integer, intent(in) :: n_iceCat - integer, intent(in), optional :: j_index + integer, intent(in), optional :: j_index ! DTD added + logical, intent(in), optional :: diagflag ! ERM added !--- local variables/parameters: character(len=16), parameter :: model = 'WRF' - real, dimension(ims:ime, kms:kme) ::nc_loc,ssat + real, dimension(ims:ime, kms:kme) ::nc_loc,cn_loc,ssat ! ERM added cn_loc real, dimension(ims:ime, kms:kme, n_iceCat) :: qitot,qirim,nitot,birim,diag_dmi,diag_vmi, & diag_rhoi,diag_effi @@ -905,6 +948,7 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes logical :: log_liqFrac logical, parameter :: log_scpf = .false. ! switch for activation of SCPF scheme logical, parameter :: log_debug = .false. ! switch for internal real-time debug checking + logical :: log_diag ! ERM added real, dimension(ims:ime, kms:kme) :: cldfrac ! cloud fraction computed by SCPF real :: scpf_pfrac ! precipitation fraction factor (SCPF) @@ -921,6 +965,13 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes scpf_pfrac = 0. ! SCPF currently not used in WRF/CM1 scpf_resfact = 0. ! SCPF currently not used in WRF/CM1 + ! Begin ERM + IF ( present( diagflag ) ) THEN + log_diag = diagflag + ELSE + log_diag = .false. + ENDIF + ! End ERM j_loop: do j = jts,jte ! j loop (north-south) if (log_predictNc) then @@ -929,6 +980,14 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes nc_loc = 0. endif + ! Begin ERM + if ( present( cn ) .and. ccn_on > 0 ) then + cn_loc(:,:) = cn(:,:,j) ! # of activated CCN + else + cn_loc = nc_loc(:,:) + endif + ! End ERM + ssat = 0. ! note: code for prediction of ssat not currently avaiable ! contruct full ice arrays (with dimension n_iceCat) from individual ice category arrays: @@ -977,13 +1036,14 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes birim(its:ite,kts:kte,1:n_iceCat),zitot(its:ite,kts:kte,1:n_iceCat), & ssat(its:ite,kts:kte),w(its:ite,kts:kte,j),p(its:ite,kts:kte,j), & dz(its:ite,kts:kte,j),itimestep,pcprt_liq,pcprt_sol,its,ite,kts,kte, & - n_iceCat,diag_zdbz(its:ite,kts:kte,j),diag_effc(its:ite,kts:kte,j), & + n_iceCat,diag_zdbz(its:ite,kts:kte,j),diag_effc(its:ite,kts:kte,j),cn_loc, & ! ERM added cn_loc diag_effi(its:ite,kts:kte,1:n_iceCat),diag_vmi(its:ite,kts:kte,1:n_iceCat), & diag_dmi(its:ite,kts:kte,1:n_iceCat),diag_rhoi(its:ite,kts:kte,1:n_iceCat), & n_diag2d,diag2d(its:ite,1:n_diag2d),n_diag3d,diag3d(its:ite,kts:kte,1:n_diag3d), & log_predictNc,trim(model),clbfact_dep,clbfact_sub,log_debug,log_scpf, & scpf_pfrac,scpf_resfact,cldfrac,log_3momIce,log_liqFrac, & - diag_dhmax = diag_dhmax, j_index = j_index) ! DTD added j-index for debugging + diag_dhmax = diag_dhmax, j_index = j_index, log_diag = log_diag, & + cat_init_new = cat_init_new_default) ! DTD added j-index for debugging, ERM added log_diag !surface precipitation output: dum1 = 1000.*dt @@ -994,6 +1054,11 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes sr(its:ite,j) = pcprt_sol(:)/(pcprt_liq(:)+pcprt_sol(:)+1.e-12) ! solid-to-total ratio if (log_predictNc) nc(:,:,j) = nc_loc(:,:) + ! ERM begin + if ( present( cn ) .and. ccn_on > 0 ) then + cn(:,:,j) = cn_loc(:,:) + endif + ! ERM end !set background effective radii (i.e. with no explicit condensate) to prescribed values: ! where (qc(:,:,j) < 1.e-14) diag_effc(:,:,j) = 10.e-6 @@ -1493,7 +1558,8 @@ function mp_p3_wrapper_gem(ttend,qtend,qctend,qrtend,qitend, diag_vis1 = diag_vis1, & diag_vis2 = diag_vis2, & diag_vis3 = diag_vis3, & - diag_dhmax = diag_dhmax) + diag_dhmax = diag_dhmax, & + cat_init_new = cat_init_new_default) if (global_status /= STATUS_OK) return @@ -1915,12 +1981,13 @@ END SUBROUTINE compute_SCPF SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,birim, & zitot,ssat,uzpl,pres,dzq,it,prt_liq,prt_sol,its,ite,kts,kte,nCat, & - diag_ze,diag_effc,diag_effi,diag_vmi,diag_di,diag_rhoi,n_diag_2d, & + diag_ze,diag_effc,cn,diag_effi,diag_vmi,diag_di,diag_rhoi,n_diag_2d, & ! ERM added cn diag_2d,n_diag_3d,diag_3d,log_predictNc,model,clbfact_dep, & clbfact_sub,debug_on,scpf_on,scpf_pfrac,scpf_resfact,SCF_out, & log_3momentIce,log_LiquidFrac,prt_drzl,prt_rain,prt_crys,prt_snow, & prt_grpl,prt_pell,prt_hail,prt_sndp,prt_wsnow,qi_type, & - diag_vis,diag_vis1,diag_vis2,diag_vis3,diag_dhmax,j_index) ! DTD added j-index for debugging + diag_vis,diag_vis1,diag_vis2,diag_vis3,diag_dhmax,j_index,log_diag, & + cat_init_new) ! DTD added j-index for debugging, ERM added log_diag !----------------------------------------------------------------------------------------! ! ! @@ -1949,6 +2016,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real, intent(inout), dimension(its:ite,kts:kte) :: qc ! cloud, mass mixing ratio kg kg-1 ! note: Nc may be specified or predicted (set by log_predictNc) real, intent(inout), dimension(its:ite,kts:kte) :: nc ! cloud, number mixing ratio # kg-1 + real, intent(inout), dimension(its:ite,kts:kte) :: cn ! act. CCN, number mixing ratio # kg-1 (ERM) real, intent(inout), dimension(its:ite,kts:kte) :: qr ! rain, mass mixing ratio kg kg-1 real, intent(inout), dimension(its:ite,kts:kte) :: nr ! rain, number mixing ratio # kg-1 real, intent(inout), dimension(its:ite,kts:kte,nCat) :: qitot ! ice, total mass mixing ratio kg kg-1 @@ -2013,6 +2081,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real, intent(in) :: scpf_resfact ! model resolution factor (SCPF) real, intent(out), dimension(its:ite,kts:kte) :: SCF_out ! cloud fraction from SCPF integer, intent(in), optional :: j_index ! DTD added j-index for debugging + logical, intent(in) :: log_diag ! ERM added + logical, intent(in), optional :: cat_init_new ! optional switch for category initialization !----- Local variables and parameters: -------------------------------------------------! @@ -2020,8 +2090,17 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real, dimension(its:ite,kts:kte) :: t ! temperature at the beginning of the microhpysics step [K] real, dimension(its:ite,kts:kte) :: t_old ! temperature at the beginning of the model time step [K] real, dimension(its:ite,nCat) :: prt_soli ! precipitation rate, solid iice-dep m s-1 + ! Begin ERM + real, dimension(its:ite,kts:kte) :: q_old,qr_old,qc_old,qv_old1 ! starting total mass + real, dimension(its:ite,kts:kte,nCat) :: qitot_old ! ice, total mass mixing ratio kg kg-1 + real, dimension(its:ite,kts:kte) :: q_new ! starting total mass + real :: qtolmax,qtolmin + real, parameter :: qtol = 1.e-9 + integer :: iqtolcnt + ! End ERM logical, parameter :: log_liqsatadj = .false. ! temporary; to be put as GEM namelist + logical :: cat_init_new_loc ! 2D size distribution and fallspeed parameters: @@ -2124,7 +2203,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real, dimension(its:ite,kts:kte) :: inv_dzq,inv_rho,ze_ice,ze_rain,prec,acn,rho, & rhofacr,rhofaci,xxls,xxlv,xlf,qvs,qvi,sup,supi,vtrmi1,tmparr1,mflux_r, & - mflux_i,invexn + mflux_i,invexn, t7 ! ERM added t7 real, dimension(kts:kte) :: V_qr,V_qit,V_nit,V_nr,V_qc,V_nc,V_zit,flux_qit,flux_qx, & flux_nx,flux_nit,flux_qir,flux_bir,flux_zit,flux_qil @@ -2142,11 +2221,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi double precision :: tmpdbl1,tmpdbl2,tmpdbl3 + ! ERM begin + integer, parameter :: dmrauto = 0 + integer :: dmropt = 0 ! extra option for crcnw + double precision t2s, xdp, xvc, xvr, rwrad + double precision xl2p,rb + real :: alphac, alphar, volb, xdiac, rh, nh, erw + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 + ! ERM end integer :: dumi,i,k,ii,iice,iice_dest,dumj,dumii,dumjj,dumzz,tmpint1,ktop,kbot,kdir, & dumic,dumiic,dumjjc,catcoll,k_qxbot,k_qxtop,k_temp,dumll,dumllc logical :: log_nucleationPossible,log_hydrometeorsPresent,log_predictSsat, & - log_exitlevel,log_hmossopOn,log_qxpresent + log_exitlevel,log_hmossopOn,log_qxpresent,log_test ! ERM added log_test ! quantities related to process rates/parameters, interpolated from lookup tables: @@ -2231,7 +2318,6 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! logical, parameter :: log_muDiagnostics = .true. ! switch to turn on mu_i budget analysis (not in current version) logical, parameter :: log_ModAdvZitot = .true. ! switch to use scaled Zitot advection and mixing (Zitot*Nitot)^(1/2) logical, parameter :: log_full3Mom = .true. ! switch to turn on fully 3-moment ice - logical, parameter :: cat_init_new = .true. ! switch to turn on new (mechanism based) ice category initialization !-----------------------------------------------------------------------------------! ! End of variables/parameters declarations !-----------------------------------------------------------------------------------! @@ -2279,6 +2365,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi tmp1 = uzpl(1,1) !avoids compiler warning for unused variable 'uzpl' + cat_init_new_loc = cat_init_new_default + if (present(cat_init_new)) cat_init_new_loc = cat_init_new + ! direction of vertical leveling: if (trim(model)=='GEM' .or. trim(model)=='KIN1D') then ktop = kts !k of top level @@ -2303,6 +2392,17 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif + ! ERM begin + where (nitot<0.) + nitot = 0. + endwhere + where (nr<0.) + nr = 0. + endwhere + where (nc<0.) + nc = 0. + endwhere + ! ERM end ! Determine threshold size difference [m] as a function of nCat ! (used for destination category upon ice initiation) ! note -- this code could be moved to 'p3_init' @@ -2337,6 +2437,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! note: '1./max(30.,dt)' = '1.*min(1./30., 1./dt)' timeScaleFactor = min(1./120., odt) + ! ERM begin + qtolmax = 0. + qtolmin = 0. + iqtolcnt = 0 + ! ERM end prt_liq = 0. prt_sol = 0. prt_soli = 0. @@ -2371,6 +2476,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi t = th *tmparr1 !compute temperature from theta (value at beginning of microphysics step) t_old = th_old*tmparr1 !compute temperature from theta (value at beginning of model time step) qv = max(qv,0.) !clip water vapor to prevent negative values passed in (beginning of microphysics) + ! ERM begin + q_old(:,:) = 0. + qv_old1(:,:) = 0. + qc_old(:,:) = 0. + qr_old(:,:) = 0. + qitot_old(:,:,:) = 0. + q_new(:,:) = 0. + ! ERM end !== !log_hmossopOn = (nCat.gt.1) !default: off for nCat=1, off for nCat>1 @@ -2463,6 +2576,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qc(i,k) = 0. nc(i,k) = 0. else + nc(i,k) = Max( nc(i,k), nsmall ) ! ERM log_hydrometeorsPresent = .true. ! updated further down endif @@ -2472,12 +2586,13 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qr(i,k) = 0. nr(i,k) = 0. else + nr(i,k) = Max( nr(i,k), nsmall ) ! ERM log_hydrometeorsPresent = .true. ! updated further down endif do iice = 1,nCat if (qitot(i,k,iice).lt.qsmall .or. (qitot(i,k,iice).lt.1.e-12 .and. & - supi(i,k).lt.-0.1)) then + supi(i,k).lt.-0.1)) then ! Note that ERM removed second sup criterion for testing. May try later qv(i,k) = qv(i,k) + qitot(i,k,iice) th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp @@ -2487,10 +2602,13 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qiliq(i,k,iice) = 0. birim(i,k,iice) = 0. else + nitot(i,k,iice) = Max (nitot(i,k,iice), nsmall) ! ERM log_hydrometeorsPresent = .true. ! final update endif - if (log_LiquidFrac .and. qitot(i,k,iice).ge.qsmall .and. (qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then + ! if (log_LiquidFrac .and. qitot(i,k,iice).ge.qsmall .and. (qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then + if (log_LiquidFrac .and. qitot(i,k,iice).ge.qsmall ) then ! ERM split line in case qitot = 0 + if (( qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then qr(i,k) = qr(i,k) + qitot(i,k,iice) nr(i,k) = nr(i,k) + nitot(i,k,iice) th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xlf(i,k)*inv_cp @@ -2499,6 +2617,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qirim(i,k,iice) = 0. qiliq(i,k,iice) = 0. birim(i,k,iice) = 0. + endif endif if (qitot(i,k,iice).ge.qsmall .and. qitot(i,k,iice).lt.1.e-12 .and. & @@ -2515,6 +2634,15 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo !iice-loop + ! ERM begin + q_old(i,k) = qv(i,k) + qc(i,k) + qr(i,k) + Sum( qitot(i,k,1:nCat) ) + qv_old1(i,k) = qv(i,k) + qc_old(i,k) = qc(i,k) + qr_old(i,k) = qr(i,k) + do iice = 1,nCat + qitot_old(i,k,iice) = qitot(i,k,iice) + enddo + ! ERM end !=== enddo k_loop_1 @@ -2625,8 +2753,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (ssat(i,k).lt.0.) epsilon = min(0.,epsilon) ! now do the adjustment - if (abs(epsilon).ge.1.e-15) then +! if (abs(epsilon).ge.1.e-15) then + if (abs(epsilon).ge.qsmall) then ! ERM qc(i,k) = qc(i,k)+epsilon + nc(i,k) = Max(nc(i,k), nsmall) ! ERM qv(i,k) = qv(i,k)-epsilon th(i,k) = th(i,k)+epsilon*invexn(i,k)*xxlv(i,k)*inv_cp ! recalculate variables if there was adjustment @@ -2690,11 +2820,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_loop1: do iice = 1,nCat - qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall) then + qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > nsmall ) then ! ERM added nitot check !impose lower limits to prevent taking log of # < 0 - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) - nr(i,k) = max(nr(i,k),nsmall) + if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM + if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM !compute mean-mass ice diameters (estimated; rigorous approach to be implemented later) !dum2 = 500. !ice density @@ -2923,7 +3053,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ex: rhofaci is grid-mean, f1pr04 is grid-mean, qc*iSCF is in-cloud, ! eci is a constant, rho(i,k) is grid-mean, nitot*iSCF is in-cloud ! (qc*iSCF*nitot*iSCF)*SCF = (qc*nitot)*iSCF to obtain grid-mean qccol - if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > 0. .and. qc(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check, ERM added nitot check qccol(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) @@ -2932,21 +3062,27 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif - if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15 .and. iice==2) then ! .and. diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check ! DTD: only allow qrcol for iice==2 (ice from Biggs freezing) - ! if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15) then + ! if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15 .and. iice==2) then ! .and. diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check ! DTD: only allow qrcol for iice==2 (ice from Biggs freezing) + ! if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! orig check + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > 0. .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! ERM added nitot check + IF ( qitot(i,k,iice)/nitot(i,k,iice) > qr(i,k)/nr(i,k) .or. qrcol_opt == 0 ) THEN ! ERM ice size check (Must be larger than rain in mean size) ! qrcol(iice)=f1pr08*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice) ! nrcol(iice)=f1pr07*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice) ! note: f1pr08 and logn0r are already calculated as log_10 (in-precip) ! note: (SPF(k)-SPF_clr(k)) is SPF_cld(k) - if (qitot(i,k,iice)/nitot(i,k,iice) > qr(i,k)/nr(i,k)) then ! DTD: added Ted's size check (ice must be larger than rain in mean size) qrcol(iice) = 10.**(f1pr08+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) nrcol(iice) = 10.**(f1pr07+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) - if (log_3momentIce) then zqrcol(iice) = 10.**(logn0r(i,k))*f1pr36*rho(i,k)*rhofaci(i,k)*eri*iSCF(k)*(SPF(k)-SPF_clr(k)) endif - endif - + ! ERM begin + IF ( ncat == 2 .and. merge_opt == 0 .and. iice == 2 .and. qrcol_opt == 2. .and. .not. cat_init_new_loc) THEN ! DTD added additional cat_init_new check + qrcol(iice) = 0.0 + nrcol(iice) = 0.0 + zqrcol(iice) = 0.0 ! DTD + ENDIF + ! ERM end + ENDIF endif !....................... @@ -3100,7 +3236,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! in the lookup table calculations ! note 'f1pr' values are normalized, so we need to multiply by N - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. log_nislf) then ! ERM added log_nislf nislf(iice) = f1pr03*rho(i,k)*eii*Eii_fact(iice)*rhofaci(i,k)*nitot(i,k,iice)*nitot(i,k,iice)*iSCF(k) if (log_3momentIce) then ! NOTE: already correct sign from lookup table, thus not multiplied by -1 @@ -3392,13 +3528,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (nCat>1) then !determine destination ice-phase category: - if (.not. cat_init_new) then + if (.not. cat_init_new_loc) then dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ! ERM begin + IF ( merge_opt == 0 .and. nCat == 2 ) THEN + iice_dest = 2 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ENDIF + ! ERM end (call of icecat_destination is still there in orig code of course else if (nCat == 2) then - iice_dest = 1 + iice_dest = 1 ! DTD need to see if we want to make this consistent with Ted's option above elseif (nCat == 3) then iice_dest = 3 elseif (nCat == 4) then @@ -3432,14 +3574,22 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (nCat>1) then !determine destination ice-phase category: - if (.not. cat_init_new) then + if (.not. cat_init_new_loc) then dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new, & + ! ERM begin + diag_3d(i,k,2) = 1000.*D_new + IF ( merge_opt == 0 .and. nCat == 2 ) THEN + iice_dest = 1 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new, & deltaD_init,iice_dest) + ENDIF + diag_3d(i,k,1) = iice_dest + ! ERM end (call of icecat_destination is still there in original of course) else if (nCat == 2) then - iice_dest = 2 + iice_dest = 2 ! DTD need to see if we want to make this consistent with Ted's option above elseif (nCat == 3) then iice_dest = 2 elseif (nCat == 4) then @@ -3467,12 +3617,18 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (nCat>1) then !determine destination ice-phase category - if (.not. cat_init_new) then + if (.not. cat_init_new_loc) then D_new = 10.e-6 !assumes ice crystals from rime splintering are tiny - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ! ERM begin + IF ( merge_opt == 0 .and. nCat == 2 ) THEN + iice_dest = 2 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ENDIF + ! ERM end (call of icecat_destination is still there in original of course) else if (nCat == 2) then - iice_dest = 1 + iice_dest = 1 ! DTD need to see if we want to make this consistent with Ted's option above elseif (nCat == 3) then iice_dest = 3 elseif (nCat == 4) then @@ -3686,7 +3842,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! if (log_LiquidFrac) then - if (qitot(i,k,iice).ge.qsmall .and. (qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then + if (qitot(i,k,iice).ge.qsmall ) then + if ( (qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then ! ERM split off second part into separate if ! Sublimation/deposition of ice !note: diffusional growth/decay rate: (stored as 'qidep' temporarily; may go to qisub below) !Note (BUG): Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon @@ -3695,12 +3852,15 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qi qidep(iice) = (aaa*epsi(iice)*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsi(iice)*oxx* & (1.d0-dexp(-dble(xx*dt))))*oabi+(qvs(i,k)-dumqvi)*epsi(iice)*oabi + endif ! ERM inner if/else endif !for very small ice contents in dry air, sublimate all ice instantly - if (supi_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall .and. & - (qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) & + if (supi_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall ) then ! ERM split off second part into separate if + if (qiliq(i,k,iice)/qitot(i,k,iice).lt.0.01) then qidep(iice) = -(qitot(i,k,iice)-qiliq(i,k,iice))*odt + endif + endif !note: 'clbfact_dep' and 'clbfact_sub' calibration factors for ice deposition and sublimation ! These are adjustable ad hoc factors used to increase or decrease deposition and/or @@ -3729,7 +3889,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif - if (qitot(i,k,iice).ge.qsmall .and. (qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then + if (qitot(i,k,iice).ge.qsmall ) then + if ((qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then ! ERM split off second part into separate if ! Condensation/evaporation fo qiliq !Note (BUG) Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon ! qlcon(iice) = ((aaa*epsiw(iice)*oxx+(ssat_cld-aaa*oxx)*odt*epsiw(iice)*oxx* & @@ -3737,11 +3898,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qi qlcon(iice) = (aaa*epsiw(iice)*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsiw(iice)*oxx* & (1.d0-dexp(-dble(xx*dt))))/ab + endif ! ERM inner if/else endif - if (sup_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall .and. & - (qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) & - qlcon(iice) = -qiliq(i,k,iice)*odt + if (sup_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall ) then ! ERM split off second part into separate if + if ( (qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) qlcon(iice) = -qiliq(i,k,iice)*odt + endif if (qlcon(iice).lt.0.) then qlevp(iice) = -qlcon(iice) @@ -3823,9 +3985,15 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sup_cld = Qv_cld(k)/qvs(i,k)-1.!in-cloud sub/sur-saturation w.r.t. liq in % endif - if (t(i,k).lt.258.15 .and. supi_cld.ge.0.05) then -! dum = exp(-0.639+0.1296*100.*supi(i,k))*1000.*inv_rho(i,k) !Meyers et al. (1992) - dum = 0.005*exp(0.304*(273.15-t(i,k)))*1000.*inv_rho(i,k) !Cooper (1986) + ! ERM modified logic below to choose between either Meyers or Cooper approach + if ( ( ( iparamice == 1 .and. t(i,k).lt.258.15) .or. & + ( iparamice == 2 .and. t(i,k).lt.268.15) ) & + .and. supi_cld.ge.0.05) then + if (iparamice == 1 ) then + dum = 0.005*exp(0.304*(273.15-t(i,k)))*1000./rho00 ! *inv_rho(i,k) !Cooper (1986) + elseif (iparamice == 2 ) then + dum = exp(-0.639+0.1296*100.*supi(i,k))*1000./rho00 ! *inv_rho(i,k) !Meyers et al. (1992) + endif ! dum = 0.005*dexp(dble(0.304*(273.15-t(i,k))))*1000.*inv_rho(i,k) !Cooper (1986) dum = min(dum,100.e3*inv_rho(i,k)*SCF(k)) N_nuc = max(0.,(dum-sum(nitot(i,k,:)))*odt) @@ -3834,13 +4002,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi Q_nuc = max(0.,(dum-sum(nitot(i,k,:)))*mi0*odt) if (nCat>1) then !determine destination ice-phase category: - if (.not. cat_init_new) then + if (.not. cat_init_new_loc) then dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ! ERM begin + IF ( merge_opt == 0 .and. nCat == 2 ) THEN + iice_dest = 2 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ENDIF + ! ERM end (call of icecat_destination is still there in original of course) else if (nCat == 2) then - iice_dest = 1 + iice_dest = 1 ! DTD need to see if we want to make this consistent with Ted's option above elseif (nCat == 3) then iice_dest = 3 elseif (nCat == 4) then @@ -3890,7 +4064,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum2 = nanew2*0.5*(1.-derf(uu2)) ! activated number in kg-1 mode 2 ! make sure this value is not greater than total number of aerosol dum2 = min((nanew1+nanew2),dum1+dum2) - dum2 = (dum2-nc(i,k)*iSCF(k))*odt*SCF(k) + dum2 = (dum2-cn(i,k)*iSCF(k))*odt*SCF(k) ! ERM changed from nc to cn dum2 = max(0.,dum2) ncnuc = dum2 ! don't include mass increase from droplet activation during first time step @@ -3923,7 +4097,26 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !................................................................ ! autoconversion - + ! ERM begin + if (iparam.eq.5) then + alphar = 0.0 + erw = 1.0 + if ( qr(i,k) > qsmall .and. nr(i,k) > nsmall ) then + xvr = Max((4./3.)*pi*(10.e-6)**3, qr(i,k)/(nr(i,k)*1000.)) + rwrad = 0.5*(6.*xvr/pi)**(1./3.) + diag_3d(i,k,3) = 1000.*rwrad + else + xvr = 0.0 + rwrad = 0.0 + endif + else + if ( qr(i,k) > qsmall .and. nr(i,k) > nsmall ) then + xvr = Max((4./3.)*pi*(10.e-6)**3, qr(i,k)/(nr(i,k)*1000.)) + rwrad = 0.5*(6.*xvr/pi)**(1./3.) + diag_3d(i,k,3) = 1000.*rwrad + endif + endif + ! ERM end !Note (BUG), needs to be in-cloud condition qc_not_small_1: if (qc(i,k)*iSCF(k).ge.1.e-8) then @@ -3974,12 +4167,89 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qcaut = 7.98e10*dum**4.22*(nc(i,k)*iSCF(k)*1.e-6*rho(i,k))**(-3.01)*SCF(k) ncautr = qcaut*cons8 ncautc = qcaut*nc(i,k)/qc(i,k) - + ! ERM begin adding Cohard and Pinty autoconversion + elseif (iparam.eq.5) then + ! Cohard and Pinty (2000) + xvc = qc(i,k)/(nc(i,k)*1000.) + + alphac = 0.0 + + xdiac = ((6.*xvc)/pi)**thrd + rb = 0.5*xdiac*(1./(1.+alphac))**(1./6.) + xl2p = Max(0.0d0, 2.7e-2*900.0*rho(i,k)*nc(i,k)*xvc* & + & ((0.5e20*rb**3*xdiac)-0.4) ) + IF ( rb .gt. 3.51e-6 ) THEN + rh = Max( 41.d-6, 6.3d-4/(1.d6*(rb - 3.5d-6)) ) + ELSE + rh = 41.d-6 + ENDIF + IF ( xl2p .gt. 0.0 ) THEN + nh = 4.2d9*xl2p + ELSE + nh = 1.e30 + ENDIF + + !volb = xvc*(1./(1.+alphac))**(1./2.) + ncautc = Max(0.0, ((alphac+2.)/(alphac+1.))*aa1*rho(i,k)*(nc(i,k))**2*xvc**2 ) + + IF ( rb .le. 7.51d-6 ) THEN + t2s = 1.d30 + qcaut = 0.0 + ncautr = 0.0 + ncslf = -ncautc + ELSE + t2s = 3.72/(1.e6*(rb-7.500d-6)*rho(i,k)*qc(i,k)) + + qcaut = Max( 0.0d0, xl2p/(t2s*rho(i,k)) ) + + IF ( qr(i,k)*rho(i,k) > 1.2*xl2p .and. rho(i,k)*nc(i,k) > 1.e-8 ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19) + ncautr = nr(i,k)/qr(i,k)*qcaut + ELSE + ncautr = Max( 0.0d0, Min(3.5e9*xl2p/t2s*inv_rho(i,k),0.5*ncautc) ) + ENDIF + ncslf = 0.0 + ENDIF + +! IF ( i == 15 ) write(6,*) 'ncautr,k = ',k,ncautr,qc(i,k),nc(i,k),ncautc,xvc + + IF ( qr(i,k) > qsmall .and. qr(i,k)*rho(i,k) > 1.2*xl2p ) THEN + ! xvr = Max((4./3.)*pi*(40.e-6)**3, qr(i,k)/(nr(i,k)*900.)) + + IF ( rwrad > rh ) THEN + + IF ( rwrad > 50.e-6 ) THEN + ncacc = aa2*nr(i,k)*(rho(i,k)*nc(i,k))*(xvc + xvr) + + ! IF ( qr(i,k)*rho(i,k) > 1.2*xl2p ) THEN + qcacc = erw*aa2*nr(i,k)*rho(i,k)*qc(i,k)* & + & ((alphac + 2.)*xvc/(alphac + 1.) + xvr) !*rhoinv(mgs) + ELSE + qcacc = aa1*nc(i,k)*rho(i,k)*qc(i,k)* & + & ((alphac + 3.)*(alphac + 2.)*xvc**2/(alphac + 1.)**2 + & + & (alphar + 6.)*(alphar + 5.)*(alphar + 4.)*xvr**2/ & + & ((alphar + 3.)*(alphar + 2.)*(alphar + 1.))) + + ncacc = aa1*nr(i,k)*nc(i,k)*rho(i,k)* & + & ((alphac + 2.)*xvc**2/(alphac + 1.) + & + & (alphar + 6.)*(alphar + 5.)*(alphar + 4.)*xvr**2/ & + & ((alphar + 3.)*(alphar + 2.)*(alphar + 1.)) ) + ENDIF ! rwrad + + ! ncacc = Min(ncacc, 0.10*nc(i,k)*odt ) + ! qcacc = Min(qcacc, 0.10*qc(i,k)*odt ) + + ENDIF ! rwrad > rh + ENDIF ! qr > qsmall + ! ERM end Cohard and Pinty endif if (qcaut .eq.0.) ncautc = 0. if (ncautc.eq.0.) qcaut = 0. + else ! ERM Cohard and Pinty + if (iparam.eq.5) then + xvc = 0.0 + endif endif qc_not_small_1 !............................ @@ -3997,6 +4267,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi elseif (iparam.eq.3.or.iparam.eq.4) then !Khroutdinov and Kogan (2000) ncslf = 0. + elseif (iparam.eq.5) then ! ERM + ncslf = 0. endif endif @@ -4031,6 +4303,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum2 = (SPF(k)-SPF_clr(k)) !in-cloud Precipitation fraction qcacc = 8.53*(qc(i,k)*iSCF(k))**1.05*(qr(i,k)*iSPF(k))**0.98 *dum2 ncacc = qcacc*nc(i,k)/qc(i,k) + elseif (iparam.eq.5) then ! ERM + ! Cohard and Pinty 2000 + ! Done in section with autoconversion endif if (qcacc.eq.0.) ncacc = 0. @@ -4042,11 +4317,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! self-collection and breakup of rain ! (breakup following modified Verlinde and Cotton scheme) - if (qr(i,k).ge.qsmall) then + if (qr(i,k).ge.qsmall .and. nr(i,k) > nsmall ) then ! ERM added nsmall check ! include breakup dum1 = 500.e-6 ! DTD changed from 280.e-6 - nr(i,k) = max(nr(i,k),nsmall) + if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall check and using ntiny instead of nsmall ! use mass-mean diameter (do this by using ! the old version of lambda w/o mu dependence) ! note there should be a factor of 6^(1/3), but we @@ -4066,6 +4341,29 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi nrslf = dum*5.78*nr(i,k)*iSPF(k)*qr(i,k)*iSPF(k)*rho(i,k)*SPF(k) elseif (iparam.eq.4) then nrslf = dum*205.*(qr(i,k)*iSPF(k))**1.55*(nr(i,k)*1.e-6*rho(i,k)*iSPF(k))**0.6*1.e6/rho(i,k)*SPF(k) ! 1.e6 converts cm-3 to m-3 + elseif (iparam.eq.5) then ! ERM + ! xvr = qr(i,k)/(nr(i,k)*900.) + ! alphar = 0 + ! rwrad = 0.5*((6.*xvr)/pi)**thrd ! (6.*qr(i,k)/(pi*900.*nr(i,k)))**(1./3.) + dum2 = (3.67+alphar)*2.*rwrad + IF ( dum1 > 1.9e-3 ) THEN + dum = 0.0 + ELSE + IF ( 2.*rwrad .lt. 6.1e-4 ) THEN + dum = 1.0 + ELSE + dum = Exp(-50.0*(50.0*(2.*rwrad - 6.0e-4))) + ENDIF + ENDIF + IF ( rwrad .ge. 50.e-6 ) THEN + nrslf = dum*aa2*rho(i,k)*(nr(i,k))**2*xvr + ELSE + nrslf = aa1*rho(i,k)*(nr(i,k)*xvr)**2* & + & (alphar + 6.)*(alphar + 5.)*(alphar + 4.)/ & + & ((alphar + 3.)*(alphar + 2.)*(alphar + 1.)) + + ENDIF +! IF ( i == 15 ) write(6,*) 'nrslf,k = ',k,nrslf,qr(i,k),nr(i,k),dum,rwrad endif endif @@ -4429,6 +4727,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (log_predictNc) then nc(i,k) = nc(i,k) + (-ncacc-ncautc+ncslf+ncnuc)*dt + cn(i,k) = cn(i,k) + ncnuc*dt ! ERM else nc(i,k) = nccnst*inv_rho(i,k) endif @@ -4446,7 +4745,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! clipping for Filiq > 0.99 (transfer unmelted ice to rain) if (log_LiquidFrac) then do iice = 1,nCat - if (qitot(i,k,iice).ge.qsmall .and. (qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then + if (qitot(i,k,iice).ge.qsmall ) then + if ((qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then ! ERM split conditional to avoid div by zero qr(i,k) = qr(i,k) + qitot(i,k,iice) nr(i,k) = nr(i,k) + nitot(i,k,iice) th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xlf(i,k)*inv_cp @@ -4455,6 +4755,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qirim(i,k,iice) = 0. qiliq(i,k,iice) = 0. birim(i,k,iice) = 0. + endif endif enddo !iice-loop endif @@ -4663,6 +4964,16 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi 555 continue + ! ERM begin + q_new(i,k) = qv(i,k) + qc(i,k) + qr(i,k) + Sum( qitot(i,k,1:nCat) ) + + qtolmax = Max( qtolmax, q_new(i,k) - q_old(i,k) ) + qtolmin = Min( qtolmin, q_new(i,k) - q_old(i,k) ) + IF ( Abs( q_new(i,k) - q_old(i,k) ) > qtol ) THEN + iqtolcnt = iqtolcnt + 1 + ENDIF + ! ERM end + enddo k_loop_main !-- for sedimentation-only tests: @@ -4756,7 +5067,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_c2: do k = k_qxtop,k_qxbot,-kdir - if (qc(i,k)*iSCF(k).ge.qsmall) then + if (qc(i,k)*iSCF(k).ge.qsmall .and. nc(i,k) > nsmall) then ! ERM added nc check call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu, & lamc(i,k),lammin,lammax,tmp1,tmp2,iSCF(k)) dum = 1./lamc(i,k)**bcn @@ -4901,10 +5212,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_r1: do k = k_qxtop,k_qxbot,-kdir - qr_not_small_1: if (qr(i,k)*iSPF(k).ge.qsmall) then + qr_not_small_1: if (qr(i,k)*iSPF(k).ge.qsmall .and. nr(i,k) > nsmall ) then ! ERM added nr check !Compute Vq, Vn: - nr(i,k) = max(nr(i,k),nsmall) + if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny instead of nsmall call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),cdistr(i,k), & logn0r(i,k),iSPF(k)) @@ -4928,6 +5239,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi V_nr(k) = dum1+(rdumjj-real(dumjj))*(dum2-dum1) !interpolated V_nr(k) = V_nr(k)*rhofacr(i,k) !corrected for air density + if ( rssflg /= 1 ) V_nr(k) = V_qr(k) ! ERM endif qr_not_small_1 Co_max = max(Co_max, V_qr(k)*dt_left*inv_dzq(i,k)) @@ -5028,10 +5340,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i1: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i1: if (qitot(i,k,iice).ge.qsmall) then + qi_notsmall_i1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > nsmall ) then ! ERM added nitot check !--Compute Vq, Vn: - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose lower limits to prevent log(<0) + if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & @@ -5048,6 +5360,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi V_qit(k) = f1pr02*rhofaci(i,k) !mass-weighted fall speed (with density factor) V_nit(k) = f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor) !== + if ( sssflg /= 1 ) V_nit(k) = V_qit(k) ! ERM endif qi_notsmall_i1 @@ -5121,10 +5434,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i2: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i2: if (qitot(i,k,iice).ge.qsmall) then + qi_notsmall_i2: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > nsmall ) then ! ERM added nitot check !--Compute Vq, Vn: - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose lower limits to prevent log(<0) + if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & isize,rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice), & @@ -5140,6 +5453,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi V_qit(k) = f1pr02*rhofaci(i,k) !mass-weighted fall speed (with density factor) V_nit(k) = f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor) !== + if ( sssflg /= 1 ) V_nit(k) = V_qit(k) ! ERM endif qi_notsmall_i2 @@ -5224,10 +5538,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i3: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i3: if (qitot(i,k,iice).ge.qsmall) then + qi_notsmall_i3: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) >= nsmall ) then ! ERM added nitot check !--Compute Vq, Vn: - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose lower limits to prevent log(<0) + if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & @@ -5270,6 +5584,29 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi V_nit(k) = f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor) V_zit(k) = f1pr19*rhofaci(i,k) !reflectivity-weighted fall speed (with density factor) + ! ERM begin + if ( sssflg /= 1 ) then + V_nit(k) = V_qit(k) + V_zit(k) = V_qit(k) + endif + ! ERM end + + ! DTD: Ted also had this section in his code. It's not in the original P3 + ! version he was working off of, and I'm not sure if it is necessary. Placing here + ! and commenting out just in case we want it at some point. + + ! else + ! + ! qv(i,k) = qv(i,k) + qitot(i,k,iice) + ! th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp + ! th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp + ! qitot(i,k,iice) = 0. + ! nitot(i,k,iice) = 0. + ! qirim(i,k,iice) = 0. + ! qiliq(i,k,iice) = 0. + ! birim(i,k,iice) = 0. + + endif qi_notsmall_i3 ! use V_zit for calculating sub-stepping since it is larger than V_qit @@ -5350,10 +5687,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i4: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i4: if (qitot(i,k,iice).ge.qsmall) then + qi_notsmall_i4: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > nsmall ) then ! ERM added nitot check !--Compute Vq, Vn: - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose lower limits to prevent log(<0) + if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & @@ -5412,6 +5749,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi V_nit(k) = f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor) V_zit(k) = f1pr19*rhofaci(i,k) !reflectivity-weighted fall speed (with density factor) + ! ERM begin + if ( sssflg /= 1 ) then + V_nit(k) = V_qit(k) + V_zit(k) = V_qit(k) + endif + ! ERM end endif qi_notsmall_i4 ! use V_zit for calculating sub-stepping since it is larger than V_qit @@ -5539,7 +5882,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi diam_ice(i,k,:) = 0. do iice = 1,nCat if (qitot(i,k,iice).ge.qsmall) then - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) + if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7,isize, & rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), & @@ -5575,19 +5918,25 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qc_not_small_2: if (qc(i,k).ge.qsmall .and. t(i,k).lt.233.15) then Q_nuc = qc(i,k) - nc(i,k) = max(nc(i,k),nsmall) + if ( log_maxnsmall ) nc(i,k) = max(nc(i,k),ntiny) ! ERM added log_maxnsmall and ntiny N_nuc = nc(i,k) if (nCat>1) then !determine destination ice-phase category: - if (.not. cat_init_new) then + if (.not. cat_init_new_loc) then dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init, & + ! ERM begin + IF ( merge_opt == 0 .and. nCat == 2 ) THEN + iice_dest = 2 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init, & iice_dest) + ENDIF + ! ERM end (call of icecat_destination is still there in orig code of course else if (nCat == 2) then - iice_dest = 1 + iice_dest = 1 ! DTD need to see if we want to make this consistent with Ted's option above elseif (nCat == 3) then iice_dest = 1 elseif (nCat == 4) then @@ -5623,17 +5972,23 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qr_not_small_2: if (qr(i,k).ge.qsmall .and. t(i,k).lt.233.15) then Q_nuc = qr(i,k) - nr(i,k) = max(nr(i,k),nsmall) + if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny N_nuc = nr(i,k) if (nCat>1) then !determine destination ice-phase category: - if (.not. cat_init_new) then + if (.not. cat_init_new_loc) then dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ! ERM begin + IF ( merge_opt == 0 .and. nCat == 2 ) THEN + iice_dest = 1 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ENDIF + ! ERM end (call of icecat_destination is still there in orig code of course else if (nCat == 2) then - iice_dest = 2 + iice_dest = 2 ! DTD need to see if we want to make this consistent with Ted's option above elseif (nCat == 3) then iice_dest = 2 elseif (nCat == 4) then @@ -5666,7 +6021,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !.............................................. ! Merge ice categories with similar properties (based on specified similarly condition) - if (.not. cat_init_new) then + if (.not. cat_init_new_loc) then ! DTD turn off category merging for the new category initialization option for now multicat: if (nCat.gt.1) then ! multicat: if (.FALSE.) then ! **** TEST @@ -5675,7 +6030,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_loop_check_before_merge: do iice = 1,nCat qi_not_small_merge: if (qitot(i,k,iice).ge.qsmall) then - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) + if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7,isize, & rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), & @@ -5751,8 +6106,23 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !step 2: merge ice with similar properties into one category do k = kbot,ktop,kdir do iice = nCat,2,-1 - tmp1 = abs(diag_di(i,k,iice)-diag_di(i,k,iice-1)) - if (tmp1.le.deltaD_init .and. qitot(i,k,iice).gt.0. .and. & + ! ERM begin new merge options + log_test = .false. + IF ( merge_opt == 1 ) THEN + ! absolute difference + tmp1 = abs(diag_di(i,k,iice)-diag_di(i,k,iice-1)) + log_test = tmp1.le.deltaD_init + ELSEIF ( merge_opt == 2 ) THEN + ! relative difference + tmp1 = 100. + IF ( diag_di(i,k,iice)+diag_di(i,k,iice-1) > 0.0 ) THEN + tmp1 = 100.*abs(diag_di(i,k,iice)-diag_di(i,k,iice-1))/ & + (diag_di(i,k,iice)+diag_di(i,k,iice-1)) + ENDIF + log_test = tmp1.le.10. + ENDIF + ! ERM end new merge options + if ( log_test .and. qitot(i,k,iice).gt.0. .and. & qitot(i,k,iice-1).gt.0.) then qitot(i,k,iice-1) = qitot(i,k,iice-1) + qitot(i,k,iice) nitot(i,k,iice-1) = nitot(i,k,iice-1) + nitot(i,k,iice) @@ -5849,11 +6219,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_loop_final_diagnostics: do iice = 1,nCat - qi_not_small: if (qitot(i,k,iice).ge.qsmall) then + qi_not_small: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then ! ERM added nitot check !impose lower limits to prevent taking log of # < 0 - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) - nr(i,k) = max(nr(i,k),nsmall) + if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny + if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) @@ -6029,7 +6399,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! DTD: changed to check on ice mean diameter above 2 cm for cat 2 ! DTD: changed back to reflectivity check !if (diag_di(i,k,2).gt.2.e-2) then - if (diag_ze(i,k).gt.85.) then + if (diag_ze(i,k).gt.85. .and. .false.) then tmparr1(i,k) = th(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp) print*,'i,j,k, ze_ice, ze_rain, ze_total, dbz',i,j_index,k,ze_ice(i,k),ze_rain(i,k),ze_ice(i,k)+ze_rain(i,k),diag_ze(i,k) print*,'qv, T, qc, nc, qr, nr' @@ -6230,13 +6600,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! partition surface precipitation rates into types (and aslo for the ! maximum hail size, dhmax). - if (freq3DtypeDiag>0. .and. mod(it*dt,freq3DtypeDiag*60.)==0. .and. trim(model)=='WRF') then + ! ERM modified below to add log_diag + if ( (log_diag .or. (freq3DtypeDiag>0. .and. mod(it*dt,freq3DtypeDiag*60.)==0.)) & + .and. trim(model)=='WRF') then do i = its,ite do k = ktop,kbot,-kdir do iice = 1,nCat + if ( nitot(i,k,iice) > nsmall .and. qitot(i,k,iice) > qsmall ) then ! ERM added diag_dhmax(i,k,iice) = maxHailSize(rho(i,k),nitot(i,k,iice),rhofaci(i,k), & arr_lami(i,k,iice),arr_mui(i,k,iice)) + else + diag_dhmax(i,k,iice) = 0.0 + endif enddo diag_3d(i,k,1) = sum(qitot(i,k,:)) diag_3d(i,k,2) = maxval(diag_dhmax(i,k,:)) @@ -6270,7 +6646,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (present(qi_type)) qi_type(:,:,:) = 0. - if (freq3DtypeDiag>0. .and. mod(it*dt,freq3DtypeDiag*60.)==0.) then + if (log_diag .or. (freq3DtypeDiag>0. .and. mod(it*dt,freq3DtypeDiag*60.)==0.)) then ! ERM added log_diag !diagnose hydrometeor types for full columns ktop_typeDiag = ktop else @@ -11513,12 +11889,13 @@ subroutine get_cloud_dsd2(qc_grd,nc_grd,mu_c,rho,nu,dnu,lamc,lammin,lammax,cdist qc = qc_grd*iSCF !in-cloud value - if (qc.ge.qsmall) then + if (qc.ge.qsmall .and. nc_grd*iSCF >= nsmall) then ! ERM added nc check +! if (qc.ge.qsmall) then nc = nc_grd*iSCF !in-cloud value ! set minimum nc to prevent floating point error - nc = max(nc,nsmall) + if ( log_maxnsmall ) nc = max(nc,ntiny) ! ERM added log_maxnsmall and ntiny mu_c = 0.0005714*(nc*1.e-6*rho)+0.2714 mu_c = 1./(mu_c**2)-1. mu_c = max(mu_c,2.) @@ -11593,7 +11970,7 @@ subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) ! find spot in lookup table ! (scaled N/q for lookup table parameter space_ - nr = max(nr,nsmall) + if ( log_maxnsmall ) nr = max(nr,ntiny) ! ERM added log_maxnsmall and ntiny inv_dum = (qr/(cons1*nr*6.))**thrd ! apply constant mu_r: diff --git a/src/mp_driver.F b/src/mp_driver.F index cec1637..26e5cb0 100644 --- a/src/mp_driver.F +++ b/src/mp_driver.F @@ -22,7 +22,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & effc,effi,effs,effr,effg,effis, & tdiag,qdiag,out2d,out3d, & dowriteout,dorad,dotdwrite,doazimwrite,dorestart, & - getdbz,getvt,dotbud,doqbud) + getdbz,getvt,dotbud,doqbud,qunit) use input use constants @@ -69,6 +69,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & logical, intent(in) :: dowriteout,dorad,dotdwrite,doazimwrite,dorestart logical, intent(inout) :: getdbz,getvt logical, intent(in) :: dotbud,doqbud + character(len=20), dimension(maxq), intent(in) :: qunit !........ @@ -961,6 +962,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ! 52 2-mom-cld, 2-mom-rain, 2-mom-ice, 2-ice-category ! 53 2-mom-cld, 2-mom-rain, 3-mom-ice, 1-ice-category ! 54 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category +! 56 2-mom-cld, 2-mom-rain, 3-mom-ice, 3-ice-category +! 57 2-mom-cld, 2-mom-rain, 3-mom-ice, 4-ice-category ! 60 2-mom-cld, 2-mom-rain, 3-mom-ice, 1-ice-category, liq-frac ! 61 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category, liq-frac ! 62 2-mom-cld, 2-mom-rain, 3-mom-ice, 3-ice-category, liq-frac @@ -978,11 +981,18 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ELSEIF (ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.53 .or.ptype.eq.60) THEN ! for 1-ice-category configurations + ! ERM added this, I think + DO i = 1,numq + call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ENDDO + ! ERM end rdt = 1.0/dt p3_jloop1: DO j=1,nj + dum1(:,:,:) = 0.0 ! ERM added (I think) + do k=1,nk do i=1,ni p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) @@ -1031,7 +1041,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & rainnc = p3a(1,1,22), & rainncv = dum1(ib,jb,2), & sr = dum1(ib,jb,3), & - snownc = dum1(ib,jb,4), & + snownc = dum1(ib,jb,4), & ! ERM has dum1(1:ni,1:1,4) here. Why? (applies to all p3 calls) snowncv = dum1(ib,jb,5), & ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & @@ -1052,7 +1062,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag2d_02 = p3a(1,1,25), & diag3d_01 = p3a(1,1,26), & diag3d_02 = p3a(1,1,27), & - diag3d_03 = p3a(1,1,28) ) + diag3d_03 = p3a(1,1,28), & + diagflag = (getdbz .or. dowriteout) ) ! ERM added diagflag (applies to all p3 calls) ! user-specified diagnostic output do i=1,ni @@ -1118,7 +1129,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag2d_02 = p3a(1,1,26), & diag3d_01 = p3a(1,1,27), & diag3d_02 = p3a(1,1,28), & - diag3d_03 = p3a(1,1,29) ) + diag3d_03 = p3a(1,1,29), & + diagflag = (getdbz .or. dowriteout) ) do k=1,nk do i=1,ni @@ -1149,6 +1161,11 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & do i=1,ni p3a(i,k,23) = q3d(i,j,k,9) p3a(i,k,24) = q3d(i,j,k,10) + ! ERM begin + IF ( trim(qunit(lccn)) /= 'none' ) THEN + p3a(i,k,31) = q3d(i,j,k,lccn) + ENDIF + ! ERM end enddo enddo @@ -1192,19 +1209,19 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,28), & diag3d_02 = p3a(1,1,29), & - diag3d_03 = p3a(1,1,30) ) -! diag3d_04 = p3a(1,1,31), & -! diag3d_05 = p3a(1,1,32), & -! diag3d_06 = p3a(1,1,33), & -! diag3d_07 = p3a(1,1,34), & -! diag3d_08 = p3a(1,1,35), & -! diag3d_09 = p3a(1,1,36), & -! diag3d_10 = p3a(1,1,37) ) + diag3d_03 = p3a(1,1,30), & + cn = p3a(1,1,31), & ! cn added by ERM (applies to other p3 calls with this) + diagflag = (getdbz .or. dowriteout) ) do k=1,nk do i=1,ni q3d(i,j,k, 9) = p3a(i,k,23) ! nc q3d(i,j,k,10) = p3a(i,k,24) ! qzi_1 + ! ERM begin + IF ( trim(qunit(lccn)) /= 'none' ) THEN + q3d(i,j,k,lccn) = p3a(i,k,31) ! ccn + ENDIF + ! ERM end enddo enddo @@ -1218,13 +1235,13 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & out3d(i,j,k,1) = p3a(i,k,28) out3d(i,j,k,2) = p3a(i,k,29) out3d(i,j,k,3) = p3a(i,k,30) - out3d(i,j,k,4) = p3a(i,k,31) - out3d(i,j,k,5) = p3a(i,k,32) - out3d(i,j,k,6) = p3a(i,k,33) - out3d(i,j,k,7) = p3a(i,k,34) - out3d(i,j,k,8) = p3a(i,k,35) - out3d(i,j,k,9) = p3a(i,k,36) - out3d(i,j,k,10) = p3a(i,k,37) + ! out3d(i,j,k,4) = p3a(i,k,31) + ! out3d(i,j,k,5) = p3a(i,k,32) + ! out3d(i,j,k,6) = p3a(i,k,33) + ! out3d(i,j,k,7) = p3a(i,k,34) + ! out3d(i,j,k,8) = p3a(i,k,35) + ! out3d(i,j,k,9) = p3a(i,k,36) + ! out3d(i,j,k,10) = p3a(i,k,37) enddo enddo @@ -1284,14 +1301,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,29), & diag3d_02 = p3a(1,1,30), & - diag3d_03 = p3a(1,1,31) ) -! diag3d_04 = p3a(1,1,32), & -! diag3d_05 = p3a(1,1,33), & -! diag3d_06 = p3a(1,1,34), & -! diag3d_07 = p3a(1,1,35), & -! diag3d_08 = p3a(1,1,36), & -! diag3d_09 = p3a(1,1,37), & -! diag3d_10 = p3a(1,1,38) ) + diag3d_03 = p3a(1,1,31), & + diagflag = (getdbz .or. dowriteout) ) do k=1,nk do i=1,ni @@ -1408,10 +1419,17 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 2-mom-ice, 2-ice-category ! !---------------------------------------------------------------------------! + ! ERM begin + DO i = 1,numq + call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ENDDO + ! ERM end rdt = 1.0/dt p3_jloop2: DO j=1,nj + dum1(:,:,:) = 0.0 ! Added by ERM + do k=1,nk do i=1,ni p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th_3d @@ -1489,7 +1507,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag2d_02 = p3a(1,1,34), & diag3d_01 = p3a(1,1,35), & diag3d_02 = p3a(1,1,36), & - diag3d_03 = p3a(1,1,37) ) + diag3d_03 = p3a(1,1,37), & + diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni @@ -1590,11 +1609,17 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & !---------------------------------------------------------------------------! ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category ! !---------------------------------------------------------------------------! - + ! ERM begin + DO i = 1,numq ! nqs2 + call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ENDDO + ! ERM end rdt = 1.0/dt p3_jloop5: DO j=1,nj + dum1(:,:,:) = 0.0 + do k=1,nk do i=1,ni p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th_3d @@ -1621,6 +1646,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & p3a(i,k,27) = q3d(i,j,k, 6) ! nc_3d p3a(i,k,31) = q3d(i,j,k,14) ! qzi1_3d p3a(i,k,32) = q3d(i,j,k,15) ! qzi2_3d + IF ( trim(qunit(lccn)) /= 'none' ) THEN + p3a(i,k,40) = q3d(i,j,k,lccn) ! ccna (added by ERM) + ENDIF enddo enddo @@ -1676,7 +1704,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag2d_02 = p3a(1,1,36), & diag3d_01 = p3a(1,1,37), & diag3d_02 = p3a(1,1,38), & - diag3d_03 = p3a(1,1,39) ) + diag3d_03 = p3a(1,1,39), & + cn = p3a(1,1,40), & + diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni @@ -1721,6 +1751,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & q3d(i,j,k, 6 ) = p3a(i,k,27) ! nc_3d q3d(i,j,k,14 ) = p3a(i,k,31) ! qzi1_3d q3d(i,j,k,15 ) = p3a(i,k,32) ! qzi2_3d + IF ( trim(qunit(lccn)) /= 'none' ) THEN ! Added by ERM + q3d(i,j,k,lccn) = p3a(i,k,40) ! ccna + ENDIF enddo enddo @@ -1773,17 +1806,475 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & if(timestats.ge.1) time_microphy=time_microphy+mytime() + ELSEIF (ptype.eq.56) THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 3-ice-category ! +!-------------------------------------------------------------------------------------! + + rdt = 1.0/dt + + p3_jloop7: DO j=1,nj + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th_3d + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv_3d + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc_3d + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr_3d + p3a(i,k, 5) = q3d(i,j,k,8) ! qnr_3d + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,18) = q3d(i,j,k,nqi) ! qi1_3d + p3a(i,k,19) = q3d(i,j,k,9) ! qni1_3d + p3a(i,k,20) = q3d(i,j,k,10) ! qir1_3d + p3a(i,k,21) = q3d(i,j,k,11) ! qib1_3d + p3a(i,k,23) = q3d(i,j,k, 5) ! qi2_3d + p3a(i,k,24) = q3d(i,j,k,13) ! qir2_3d + p3a(i,k,25) = q3d(i,j,k,12) ! qni2_3d + p3a(i,k,26) = q3d(i,j,k,14) ! qib2_3d + p3a(i,k,27) = q3d(i,j,k, 7) ! nc_3d + p3a(i,k,31) = q3d(i,j,k,18) ! qzi1_3d + p3a(i,k,32) = q3d(i,j,k,19) ! qzi2_3d + p3a(i,k,33) = q3d(i,j,k, 6) ! qi3_3d + p3a(i,k,34) = q3d(i,j,k,16) ! qir3_3d + p3a(i,k,35) = q3d(i,j,k,15) ! qni3_3d + p3a(i,k,36) = q3d(i,j,k,17) ! qib3_3d + p3a(i,k,37) = q3d(i,j,k,20) ! qzi3_3d + enddo + enddo + + do i=1,ni + p3a(i,1,22) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,22), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 3, & + qit_1 = p3a(1,1,18), & + qni_1 = p3a(1,1,19), & + qir_1 = p3a(1,1,20), & + qib_1 = p3a(1,1,21), & + diag_vmi_1 = p3a(1,1,15), & + diag_dmi_1 = p3a(1,1,16), & + diag_rhoi_1 = p3a(1,1,17), & + qzi_1 = p3a(1,1,31), & + nc = p3a(1,1,27), & + qit_2 = p3a(1,1,23), & + qir_2 = p3a(1,1,24), & + qni_2 = p3a(1,1,25), & + qib_2 = p3a(1,1,26), & + qzi_2 = p3a(1,1,32), & + diag_vmi_2 = p3a(1,1,28), & + diag_dmi_2 = p3a(1,1,29), & + diag_rhoi_2 = p3a(1,1,30), & + qit_3 = p3a(1,1,33), & + qir_3 = p3a(1,1,34), & + qni_3 = p3a(1,1,35), & + qib_3 = p3a(1,1,36), & + qzi_3 = p3a(1,1,37), & + diag_vmi_3 = p3a(1,1,38), & + diag_dmi_3 = p3a(1,1,39), & + diag_rhoi_3 = p3a(1,1,40), & + diag_dhmax_1 = p3a(1,1,41), & + diag_dhmax_2 = p3a(1,1,42), & + diag_dhmax_3 = p3a(1,1,43), & + diag2d_01 = p3a(1,1,44), & + diag2d_02 = p3a(1,1,45), & + diag3d_01 = p3a(1,1,46), & + diag3d_02 = p3a(1,1,47), & + diag3d_03 = p3a(1,1,48), & + diagflag = (getdbz .or. dowriteout) ) + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,22)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,22)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,22) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc_3d + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr_3d + q3d(i,j,k, 8 ) = p3a(i,k, 5) ! qnr_3d + q3d(i,j,k,nqi) = p3a(i,k,18) ! qi1_3d + q3d(i,j,k, 9 ) = p3a(i,k,19) ! qni1_3d + q3d(i,j,k,10 ) = p3a(i,k,20) ! qir1_3d + q3d(i,j,k,11 ) = p3a(i,k,21) ! qib1_3d + q3d(i,j,k, 5 ) = p3a(i,k,23) ! qi2_3d + q3d(i,j,k,13 ) = p3a(i,k,24) ! qir2_3d + q3d(i,j,k,12 ) = p3a(i,k,25) ! qni2_3d + q3d(i,j,k,14 ) = p3a(i,k,26) ! qib2_3d + q3d(i,j,k, 7 ) = p3a(i,k,27) ! nc_3d + q3d(i,j,k,18 ) = p3a(i,k,31) ! qzi1_3d + q3d(i,j,k,19 ) = p3a(i,k,32) ! qzi2_3d + q3d(i,j,k, 6 ) = p3a(i,k,33) ! qi3_3d + q3d(i,j,k,16 ) = p3a(i,k,34) ! qir3_3d + q3d(i,j,k,15 ) = p3a(i,k,35) ! qni3_3d + q3d(i,j,k,17 ) = p3a(i,k,36) ! qib3_3d + q3d(i,j,k,20 ) = p3a(i,k,37) ! qzi3_3d + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,15) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,16) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,17) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,41) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,28) ! _2 + p3o(i,j,k, 6) = p3a(i,k,29) + p3o(i,j,k, 7) = p3a(i,k,30) + p3o(i,j,k, 8) = p3a(i,k,42) + + p3o(i,j,k, 9) = p3a(i,k,38) ! _3 + p3o(i,j,k,10) = p3a(i,k,39) + p3o(i,j,k,11) = p3a(i,k,40) + p3o(i,j,k,12) = p3a(i,k,43) + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,44) + out2d(i,j,2) = p3a(i,1,45) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,46) + out3d(i,j,k,2) = p3a(i,k,47) + out3d(i,j,k,3) = p3a(i,k,48) + enddo + enddo + + + ENDDO p3_jloop7 + + if(timestats.ge.1) time_microphy=time_microphy+mytime() + + ELSEIF (ptype.eq.57) THEN +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 4-ice-category, ! +!-------------------------------------------------------------------------------------! + + rdt = 1.0/dt + + p3_jloop8: DO j=1,nj + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,9) ! qnr + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,18) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,19) = q3d(i,j,k,10) ! qni_1 + p3a(i,k,20) = q3d(i,j,k,11) ! qir_1 + p3a(i,k,21) = q3d(i,j,k,12) ! qib_1 + p3a(i,k,23) = q3d(i,j,k, 5) ! qit_2 + p3a(i,k,24) = q3d(i,j,k,14) ! qir_2 + p3a(i,k,25) = q3d(i,j,k,13) ! qni_2 + p3a(i,k,26) = q3d(i,j,k,15) ! qib_2 + p3a(i,k,27) = q3d(i,j,k, 8) ! nc + p3a(i,k,31) = q3d(i,j,k,22) ! qzi_1 + p3a(i,k,32) = q3d(i,j,k,23) ! qzi_2 + p3a(i,k,33) = q3d(i,j,k, 6) ! qit_3 + p3a(i,k,34) = q3d(i,j,k,17) ! qir_3 + p3a(i,k,35) = q3d(i,j,k,16) ! qni_3 + p3a(i,k,36) = q3d(i,j,k,18) ! qib_3 + p3a(i,k,37) = q3d(i,j,k,24) ! qzi_3 + p3a(i,k,41) = q3d(i,j,k, 7) ! qit_4 + p3a(i,k,42) = q3d(i,j,k,20) ! qir_4 + p3a(i,k,43) = q3d(i,j,k,19) ! qni_4 + p3a(i,k,44) = q3d(i,j,k,21) ! qib_4 + p3a(i,k,45) = q3d(i,j,k,25) ! qzi_4 + enddo + enddo + + + do i=1,ni + p3a(i,1,22) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,22), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 4, & + qit_1 = p3a(1,1,18), & + qni_1 = p3a(1,1,19), & + qir_1 = p3a(1,1,20), & + qib_1 = p3a(1,1,21), & + diag_vmi_1 = p3a(1,1,15), & + diag_dmi_1 = p3a(1,1,16), & + diag_rhoi_1 = p3a(1,1,17), & + qzi_1 = p3a(1,1,31), & + nc = p3a(1,1,27), & + qit_2 = p3a(1,1,23), & + qir_2 = p3a(1,1,24), & + qni_2 = p3a(1,1,25), & + qib_2 = p3a(1,1,26), & + qzi_2 = p3a(1,1,32), & + diag_vmi_2 = p3a(1,1,28), & + diag_dmi_2 = p3a(1,1,29), & + diag_rhoi_2 = p3a(1,1,30), & + qit_3 = p3a(1,1,33), & + qir_3 = p3a(1,1,34), & + qni_3 = p3a(1,1,35), & + qib_3 = p3a(1,1,36), & + qzi_3 = p3a(1,1,37), & + diag_vmi_3 = p3a(1,1,38), & + diag_dmi_3 = p3a(1,1,39), & + diag_rhoi_3 = p3a(1,1,40), & + qit_4 = p3a(1,1,41), & + qir_4 = p3a(1,1,42), & + qni_4 = p3a(1,1,43), & + qib_4 = p3a(1,1,44), & + qzi_4 = p3a(1,1,45), & + diag_vmi_4 = p3a(1,1,46), & + diag_dmi_4 = p3a(1,1,47), & + diag_rhoi_4 = p3a(1,1,48), & + diag_dhmax_1 = p3a(1,1,49), & + diag_dhmax_2 = p3a(1,1,50), & + diag_dhmax_3 = p3a(1,1,51), & + diag_dhmax_4 = p3a(1,1,52), & + diag2d_01 = p3a(1,1,53), & + diag2d_02 = p3a(1,1,54), & + diag3d_01 = p3a(1,1,55), & + diag3d_02 = p3a(1,1,56), & + diag3d_03 = p3a(1,1,57), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,22)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,22)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,22) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr + q3d(i,j,k, 9 ) = p3a(i,k, 5) ! qnr_1 + q3d(i,j,k,nqi) = p3a(i,k,18) ! qit_1 + q3d(i,j,k,10 ) = p3a(i,k,19) ! qni_1 + q3d(i,j,k,11 ) = p3a(i,k,20) ! qir_1 + q3d(i,j,k,12 ) = p3a(i,k,21) ! qib_1 + q3d(i,j,k, 5 ) = p3a(i,k,23) ! qit_2 + q3d(i,j,k,14 ) = p3a(i,k,24) ! qir_2 + q3d(i,j,k,13 ) = p3a(i,k,25) ! qni_2 + q3d(i,j,k,15 ) = p3a(i,k,26) ! qib_2 + q3d(i,j,k, 8 ) = p3a(i,k,27) ! nc + q3d(i,j,k,22 ) = p3a(i,k,31) ! qzi_1 + q3d(i,j,k,23 ) = p3a(i,k,32) ! qzi_2 + q3d(i,j,k, 6 ) = p3a(i,k,33) ! qit_3 + q3d(i,j,k,17 ) = p3a(i,k,34) ! qir_3 + q3d(i,j,k,16 ) = p3a(i,k,35) ! qni_3 + q3d(i,j,k,18 ) = p3a(i,k,36) ! qib_3 + q3d(i,j,k,24 ) = p3a(i,k,37) ! qzi_3 + q3d(i,j,k, 7 ) = p3a(i,k,41) ! qit_4 + q3d(i,j,k,20 ) = p3a(i,k,42) ! qir_4 + q3d(i,j,k,19 ) = p3a(i,k,43) ! qni_4 + q3d(i,j,k,21 ) = p3a(i,k,44) ! qib_4 + q3d(i,j,k,25 ) = p3a(i,k,45) ! qzi_4 + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,15) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,16) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,17) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,49) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,28) ! _2 + p3o(i,j,k, 6) = p3a(i,k,29) + p3o(i,j,k, 7) = p3a(i,k,30) + p3o(i,j,k, 8) = p3a(i,k,50) + + p3o(i,j,k, 9) = p3a(i,k,38) ! _3 + p3o(i,j,k,10) = p3a(i,k,39) + p3o(i,j,k,11) = p3a(i,k,40) + p3o(i,j,k,12) = p3a(i,k,51) + + p3o(i,j,k,13) = p3a(i,k,46) ! _4 + p3o(i,j,k,14) = p3a(i,k,47) + p3o(i,j,k,15) = p3a(i,k,48) + p3o(i,j,k,16) = p3a(i,k,52) + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,53) + out2d(i,j,2) = p3a(i,1,54) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,55) + out3d(i,j,k,2) = p3a(i,k,56) + out3d(i,j,k,3) = p3a(i,k,57) + enddo + enddo + + + ENDDO p3_jloop8 + + if (timestats.ge.1) time_microphy = time_microphy+mytime() ELSEIF (ptype.eq.61) THEN !-------------------------------------------------------------------------------------! ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category, liq-frac ! !-------------------------------------------------------------------------------------! - + ! ERM begin + DO i = 1,numq + call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ENDDO + ! ERM end rdt = 1.0/dt p3_jloop3: DO j=1,nj + dum1(:,:,:) = 0.0 + do k=1,nk do i=1,ni p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th_3d @@ -1869,7 +2360,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag2d_02 = p3a(1,1,38), & diag3d_01 = p3a(1,1,39), & diag3d_02 = p3a(1,1,40), & - diag3d_03 = p3a(1,1,41) ) + diag3d_03 = p3a(1,1,41), & + diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni @@ -1973,11 +2465,17 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & !-------------------------------------------------------------------------------------! ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 3-ice-category, liq-frac ! !-------------------------------------------------------------------------------------! - + ! ERM begin + DO i = 1,numq + call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ENDDO + ! ERM end rdt = 1.0/dt p3_jloop4: DO j=1,nj + dum1(:,:,:) = 0.0 + do k=1,nk do i=1,ni p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th_3d @@ -2080,7 +2578,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag2d_02 = p3a(1,1,48), & diag3d_01 = p3a(1,1,49), & diag3d_02 = p3a(1,1,50), & - diag3d_03 = p3a(1,1,51) ) + diag3d_03 = p3a(1,1,51), & + diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni @@ -2198,11 +2697,17 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & !-------------------------------------------------------------------------------------! ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 4-ice-category, liq-frac ! !-------------------------------------------------------------------------------------! - + ! ERM begin + DO i = 1,numq + call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ENDDO + ! ERM end rdt = 1.0/dt p3_jloop6: DO j=1,nj + dum1(:,:,:) = 0.0 + do k=1,nk do i=1,ni p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th @@ -2322,8 +2827,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,59), & diag3d_02 = p3a(1,1,60), & diag3d_03 = p3a(1,1,61), & - j_index = j ) ! DTD: added j_index for debugging - + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni prate(i,j) = p3a(i,1,22)*rdt @@ -2537,7 +3042,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & enddo enddo - if( getdbz )then + if( getdbz .and. qd_dbz.ge.1 )then do k=1,nk do j=1,nj do i=1,ni diff --git a/src/param.F b/src/param.F index f75afbd..a4dadc6 100644 --- a/src/param.F +++ b/src/param.F @@ -150,6 +150,18 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & logical :: doit,getfall logical :: nssl_hail_on = .false. + ! ERM begin for p3 parameters + real :: p3_cccn = 300.e6 + real :: p3_nimax = 2000.e3 + integer :: p3_iparam = 3 + integer :: p3_ccn_on = 0 + integer :: p3_merge_opt = 1 ! 0 = no merging; 1 = diameter-difference merge (original); 2 = percent difference in diam. (Cholette 2024) + integer :: p3_qrcol_opt = 0 ! 0 = no size check on qrcol; 1 = only allow qrcol for ice larger than rain + ! for p3_merge_opt=0 with p3_qrcol_opt=2 and ncat=2, this disables qrcol for iice=2 + integer :: rssflg = 1 ! P3: Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value + integer :: sssflg = 1 ! P3: As for rain but for ice (all ice) + logical :: p3_cat_init_new = .true. ! switch for mechanism-based ice category initialization + ! ERM end #ifdef MPI integer :: ntmp1,ntmp2,ntmp3,ntmp4,reqs,reqs1,reqs2,reqs3,reqs4 integer, dimension(MPI_STATUS_SIZE) :: status @@ -182,6 +194,16 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dmrauto, & ioldlimiter, & ihlcnh + NAMELIST /p3_params/ & ! ERM add p3_params namelist + p3_cccn, & + p3_nimax, & + p3_iparam, & + p3_ccn_on, & + p3_merge_opt, & + p3_qrcol_opt, & + rssflg, & + sssflg, & + p3_cat_init_new NAMELIST /forcing/ & iforce, & @@ -342,7 +364,12 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & 751 continue rewind(20) ENDIF - + ! ERM/DTD for p3_params + IF ( (ptype.ge.50 .and. ptype.le.54) .or. (ptype.ge.56 .and. ptype.le.63) ) THEN + read(20,nml=p3_params,end=752) +752 continue + rewind(20) + ENDIF read(20,nml=param17,end=717) 717 continue rewind(20) @@ -764,6 +791,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(nssl_3moment,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(nssl_density_on,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) ENDIF + ! ERM begin + call MPI_BCAST(p3_cccn ,1,MPI_REAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_nimax ,1,MPI_REAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_iparam ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_ccn_on ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_merge_opt,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_qrcol_opt,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(rssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(sssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_cat_init_new,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + ! ERM end #endif open(unit=20,file='namelist.input',form='formatted',status='old', & @@ -1036,15 +1074,15 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & eqtset = 1 ENDIF !----- - IF( (ptype.eq.4.or.ptype.eq.50.or.ptype.eq.51.or.ptype.eq.52.or.ptype.eq.53.or.ptype.eq.54.or.ptype.eq.55.or.ptype.eq.60 & - .or.ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) .and. eqtset.eq.2 )THEN + IF( (ptype.eq.4.or.ptype.eq.50.or.ptype.eq.51.or.ptype.eq.52.or.ptype.eq.53.or.ptype.eq.54.or.ptype.eq.55.or.ptype.eq.56 & + .or.ptype.eq.57 .or.ptype.eq.60.or.ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) .and. eqtset.eq.2 )THEN if(myid.eq.0)then print *,' -------------------------------- ' print * print *,' ptype = ',ptype print *,' eqtset = ',eqtset print * - print *,' ptype=4,50,51,52,53,54,55,60,61,62,63 requires eqtset=1 ' + print *,' ptype=4,50,51,52,53,54,55,56,57,60,61,62,63 requires eqtset=1 ' print * print *,' ... setting eqtset to 1 ... ' print * @@ -2382,14 +2420,15 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ENDIF !----- IF( radopt.eq.2 .and. ( ptype.ne.3 .and. ptype.ne.5 .and. ptype.ne.50 .and. ptype.ne.51 .and. & - ptype.ne.52 .and. ptype.ne.53 .and. ptype.ne.54 .and. ptype.ne.55 .and. ptype.ne.60 .and. & + ptype.ne.52 .and. ptype.ne.53 .and. ptype.ne.54 .and. ptype.ne.55 .and. & + ptype.ne.56 .and. ptype.ne.57 .and. ptype.ne.60 .and. & ptype.ne.61 .and. ptype.ne.62 .and. ptype.ne.63) )THEN if(myid.eq.0)then print * print *,' radopt = ',radopt print *,' ptype = ',ptype print * - print *,' radopt=2 requires ptype=3,5,26,27,50,51,52,53,54,55,60,61,62,63 (for now) ' + print *,' radopt=2 requires ptype=3,5,26,27,50,51,52,53,54,55,56,57,60,61,62,63 (for now) ' print * print *,' stopping model .... ' print * @@ -2817,6 +2856,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & if( ptype.eq.53 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.54 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.55 ) param_mp = 'Jensen_ISHMAEL' + if( ptype.eq.56 ) param_mp = 'Predicted Particle Property (P3)' + if( ptype.eq.57 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.60 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.61 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.62 ) param_mp = 'Predicted Particle Property (P3)' @@ -3103,7 +3144,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & if(dowr) write(outfile,*) - IF ( ptype >= 26 .and. dowr ) THEN + IF ( ptype >= 26 .and. ptype <= 28 .and. dowr ) THEN write(outfile,NML=nssl2mom_params) ! write(outfile,*) 'alphah =',alphah ! write(outfile,*) 'alphahl =',alphahl @@ -3121,7 +3162,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! write(outfile,*) 'dmrauto =',dmrauto ! write(outfile,*) 'ioldlimiter=',ioldlimiter ENDIF - + ! ERM/DTD for p3 + IF ( (ptype.ge.50 .and. ptype.le.54) .or. (ptype.ge.56 .and. ptype.le.63) ) THEN + write(outfile,NML=p3_params) + ENDIF !-------------------------------------------------------------- if(dowr) write(outfile,*) @@ -3860,7 +3904,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qunit(nvl1:nvl2) = 'm^3/kg' ENDIF IF ( nssl_3moment ) THEN - qunit(nzl1:nzl2) = 'Z/m^3/kg' + qunit(nzl1:nzl2) = 'Z/kg' ENDIF rhovar(lv:lhab) = .false. @@ -4036,8 +4080,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & !----------------------------------------------------------------------- - ELSEIF( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.60 & - .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) THEN ! P3 + ELSEIF( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.56 & + .or. ptype.eq.57 .or. ptype.eq.60 .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) THEN ! P3 !----- initialize the P3 scheme ----- @@ -4052,7 +4096,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & ! ERM added new p3 options (all calls) + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) elseif( ptype.eq.51 )then call p3_init(lookup_file_dir='.', & nCat=1, & @@ -4061,7 +4108,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) elseif( ptype.eq.52 )then call p3_init(lookup_file_dir='.', & nCat=2, & @@ -4070,7 +4120,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) elseif( ptype.eq.53 )then call p3_init(lookup_file_dir='.', & nCat=1, & @@ -4079,7 +4132,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) elseif( ptype.eq.54 )then call p3_init(lookup_file_dir='.', & nCat=2, & @@ -4088,7 +4144,34 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) + elseif( ptype.eq.56 )then + call p3_init(lookup_file_dir='.', & + nCat=3, & + trplMomI=.true., & + liqFrac=.false., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) + elseif( ptype.eq.57 )then + call p3_init(lookup_file_dir='.', & + nCat=4, & + trplMomI=.true., & + liqFrac=.false., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) elseif( ptype.eq.60 )then call p3_init(lookup_file_dir='.', & nCat=1, & @@ -4097,7 +4180,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) elseif( ptype.eq.61 )then call p3_init(lookup_file_dir='.', & nCat=2, & @@ -4106,7 +4192,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) elseif( ptype.eq.62 )then call p3_init(lookup_file_dir='.', & nCat=3, & @@ -4115,7 +4204,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) elseif( ptype.eq.63 )then call p3_init(lookup_file_dir='.', & nCat=4, & @@ -4124,7 +4216,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new ) endif if(dowr) write(outfile,*) 'Returned from P3_INIT' @@ -4140,6 +4235,12 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & iice = 1 ! this scheme has ice microphysics idm = 1 ! this scheme has at least one double moment + ! ERM begin + ltmp = 0 + lccn = 0 + IF ( p3_ccn_on > 0 ) ltmp = 1 + ! ERM end + !cccccccccccccccccccccccccccccccccccccccccccccccccccc! IF( ptype.eq.50 )THEN @@ -4331,7 +4432,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ELSEIF( ptype.eq.53 )THEN - numq = 10 ! there are 9 q variables + numq = 10+ltmp ! there are 10 q variables (11 with CCN added by ERM) nqv = 1 ! qv nql1 = 2 ! the first liquid variable @@ -4349,17 +4450,19 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & cloudvar(8) = .false. cloudvar(9) = .false. cloudvar(10) = .false. + cloudvar(11) = .false. ! ERM qname(1) = 'qv ' qname(2) = 'qc ' qname(3) = 'qr ' qname(4) = 'qi1' qname(5) = 'ni1' - qname(6) = 'qnr' + qname(6) = 'qnr' ! ERM has these named just "nr", "nc". Does it matter? qname(7) = 'ri1' qname(8) = 'bi1' qname(9) = 'qnc' qname(10) = 'zi1' + qname(11) = 'ccn' ! ERM qunit(1) = 'kg/kg' qunit(2) = 'kg/kg' @@ -4371,6 +4474,12 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qunit(8) = 'm^3 kg^-1' qunit(9) = '#/kg' qunit(10) = 'm(6) kg(-1)' + IF ( p3_ccn_on > 0 ) THEN ! Added by ERM + lccn = 11 + qunit(11) = '#/kg' + ELSE + qunit(11) = 'none' + ENDIF ! likely maximum value (order-of-magnitude) ! (needed for monotonic advection schemes) @@ -4384,6 +4493,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qmag(8) = 1.0e-5 qmag(9) = 1.0e8 qmag(10) = 1.0e-3 + qmag(11) = 1.0e8 ! Added by ERM ! for p3 arrays: !--v00: @@ -4391,8 +4501,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! np3a = 29 ! for 3 + 2 (nout3d = 3, nout2d = 2) additional output variables ! np3o = 3 !-- - np3a = 24 ! 3-mom, no_liqfrac, 1-cat (incl. vmi_1, dmi_1, rhoi_1) - np3a = np3a + nout2d + nout3d + 1 !(1 for dhmax_x) + np3a = 24 + ltmp ! 3-mom, no_liqfrac, 1-cat (incl. vmi_1, dmi_1, rhoi_1) ltmp added by ERM + np3a = np3a + nout2d + nout3d + 1 + ltmp !(1 for dhmax_x) ! ltmp added by ERM np3o = 4 ! 1 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) np3a = np3a + 7 ! adding 7 additional 3d output fields @@ -4400,7 +4510,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ELSEIF( ptype.eq.54 )THEN - numq = 15 ! there are 13 q variables + numq = 15 + ltmp ! there are 15 q variables (16 with CCN added by ERM) nqv = 1 ! qv nql1 = 2 ! the first liquid variable @@ -4423,6 +4533,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & cloudvar(13) = .false. cloudvar(14) = .false. cloudvar(15) = .false. + cloudvar(16) = .false. ! ERM qname( 1) = 'qv ' qname( 2) = 'qc ' @@ -4439,6 +4550,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qname(13) = 'bi2' qname(14) = 'zi1' qname(15) = 'zi2' + qname(16) = 'ccn' ! ERM qunit( 1) = 'kg/kg' qunit( 2) = 'kg/kg' @@ -4455,6 +4567,14 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qunit(13) = 'm^-3 kg^-1' qunit(14) = 'm^6/kg' qunit(15) = 'm^6/kg' + ! ERM begin + IF ( p3_ccn_on > 0 ) THEN + lccn = 16 + qunit(16) = '#/kg' + ELSE + qunit(16) = 'none' + ENDIF + ! ERM end ! likely maximum value (order-of-magnitude) ! (needed for monotonic advection schemes) @@ -4473,6 +4593,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qmag(13) = 1.0e-5 qmag(14) = 1.0e-3 qmag(15) = 1.0e-3 + qmag(16) = 1.e8 ! ERM ! for p3 arrays: !--v00: @@ -4486,6 +4607,227 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & !cccccccccccccccccccccccccccccccccccccccccccccccccccc! + ELSEIF( ptype.eq.56 )THEN + + numq = 20 ! there are 20 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 6 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .false. + cloudvar( 8) = .false. + cloudvar( 9) = .false. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'nc ' + qname( 8) = 'nr ' + qname( 9) = 'ni1' + qname(10) = 'ri1' + qname(11) = 'bi1' + qname(12) = 'ni2' + qname(13) = 'ri2' + qname(14) = 'bi2' + qname(15) = 'ni3' + qname(16) = 'ri3' + qname(17) = 'bi3' + qname(18) = 'zi1' + qname(19) = 'zi2' + qname(20) = 'zi3' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = '#/kg' + qunit( 8) = '#/kg' + qunit( 9) = '#/kg' + qunit(10) = 'kg/kg' + qunit(11) = 'm^-3 kg^-1' + qunit(12) = '#/kg' + qunit(13) = 'kg/kg' + qunit(14) = 'm^-3 kg^-1' + qunit(15) = '#/kg' + qunit(16) = 'kg/kg' + qunit(17) = 'm^-3 kg^-1' + qunit(18) = 'm^6/kg' + qunit(19) = 'm^6/kg' + qunit(20) = 'm^6/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 1.0e5 + qmag( 8) = 1.0e5 + qmag( 9) = 1.0e5 + qmag(10) = 0.01 + qmag(11) = 1.0e-5 + qmag(12) = 1.0e5 + qmag(13) = 0.01 + qmag(14) = 1.0e-5 + qmag(15) = 1.0e5 + qmag(16) = 0.01 + qmag(17) = 1.0e-5 + qmag(18) = 1.0e-3 + qmag(19) = 1.0e-3 + qmag(20) = 1.0e-3 + + ! for p3 arrays: + np3a = 40 ! 3-mom, no_liqfrac, 3-cat (no extra output) + np3a = np3a + nout2d + nout3d + 3 !(3 for dhmax_x) + np3o = 12 ! 3 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) + + ELSEIF( ptype.eq.57 )THEN + + numq = 25 ! there are 25 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 7 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .true. + cloudvar( 8) = .false. + cloudvar( 9) = .false. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + cloudvar(21) = .false. + cloudvar(22) = .false. + cloudvar(23) = .false. + cloudvar(24) = .false. + cloudvar(25) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'qi4' + qname( 8) = 'nc ' + qname( 9) = 'nr ' + qname(10) = 'ni1' + qname(11) = 'ri1' + qname(12) = 'bi1' + qname(13) = 'ni2' + qname(14) = 'ri2' + qname(15) = 'bi2' + qname(16) = 'ni3' + qname(17) = 'ri3' + qname(18) = 'bi3' + qname(19) = 'ni4' + qname(20) = 'ri4' + qname(21) = 'bi4' + qname(22) = 'zi1' + qname(23) = 'zi2' + qname(24) = 'zi3' + qname(25) = 'zi4' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = 'kg/kg' + qunit( 8) = '#/kg' + qunit( 9) = '#/kg' + qunit(10) = '#/kg' + qunit(11) = 'kg/kg' + qunit(12) = 'm^-3 kg^-1' + qunit(13) = '#/kg' + qunit(14) = 'kg/kg' + qunit(15) = 'm^-3 kg^-1' + qunit(16) = '#/kg' + qunit(17) = 'kg/kg' + qunit(18) = 'm^-3 kg^-1' + qunit(19) = '#/kg' + qunit(20) = 'kg/kg' + qunit(21) = 'm^-3 kg^-1' + qunit(22) = 'm^6/kg' + qunit(23) = 'm^6/kg' + qunit(24) = 'm^6/kg' + qunit(25) = 'm^6/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 0.01 + qmag( 8) = 1.0e5 + qmag( 9) = 1.0e5 + qmag(10) = 1.0e5 + qmag(11) = 0.01 + qmag(12) = 1.0e-5 + qmag(13) = 1.0e5 + qmag(14) = 0.01 + qmag(15) = 1.0e-5 + qmag(16) = 1.0e5 + qmag(17) = 0.01 + qmag(18) = 1.0e-5 + qmag(19) = 1.0e5 + qmag(20) = 0.01 + qmag(21) = 1.0e-5 + qmag(22) = 1.0e-3 + qmag(23) = 1.0e-3 + qmag(24) = 1.0e-3 + qmag(25) = 1.0e-3 + + ! for p3 arrays: + np3a = 48 ! 3-mom, no_liqfrac, 4-cat (no extra output) + np3a = np3a + nout2d + nout3d + 4 !(4 for dhmax_x) + np3o = 16 ! 4 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) ELSEIF( ptype.eq.60 )THEN @@ -4658,7 +5000,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ELSEIF( ptype.eq.62 )THEN - numq = 23 ! there are 17 q variables + numq = 23 ! there are 23 q variables nqv = 1 ! qv nql1 = 2 ! the first liquid variable @@ -5773,7 +6115,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! array indices for P3 microphysics: ! (use these arrays for ISHMAEL diag output, too) if( imoist.eq.1 .and. ( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. & - ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.55 .or. ptype.eq.60 .or. & + ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.55 .or. ptype.eq.56 .or. & + ptype.eq.57 .or. ptype.eq.60 .or. & ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) )then ibp3 = 1 iep3 = ni @@ -10097,7 +10440,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & write(21,*) ' tconfig = ',tconfig write(21,*) ' bcturbs = ',bcturbs write(21,*) ' ptype = ',ptype - IF ( ptype.eq.26 .or. ptype.eq.27 ) THEN + IF ( ptype.eq.26 .or. ptype.eq.27 .or. ptype.eq.28 ) THEN write(21,*) ' nssl_3moment = ',nssl_3moment ENDIF write(21,*) ' wbc = ',wbc diff --git a/src/radiation_driver.F b/src/radiation_driver.F index 1ea45d7..3e9b506 100644 --- a/src/radiation_driver.F +++ b/src/radiation_driver.F @@ -470,13 +470,14 @@ subroutine radiation_driver(mtime,radtim,dt,rbufsz,xh,yh,xf,yf,zf,rmh,c1,c2, has_reqs = 1 endif if( ptype.eq.26 .or. ptype.eq.27 )then - ! NSSL scheme + ! NSSL scheme (DTD: will this work for 28 as well?) mp_physics = 18 has_reqc = 1 has_reqi = 1 has_reqs = 1 endif - if( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.60 & + if( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. & + ptype.eq.56 .or. ptype.eq.57 .or. ptype.eq.60 & .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63)then ! P3 microphysics ! use eff arrays from P3 scheme: @@ -779,7 +780,7 @@ SUBROUTINE radconst(XTIME,DECLIN,SOLCON,JULIAN, & DECDEG,DJUL,RJUL,ECCFAC ! ! !DESCRIPTION: -! Compute terms used in radiation physics +! Compute terms used in radiation physics !EOP ! for short wave radiation @@ -788,12 +789,12 @@ SUBROUTINE radconst(XTIME,DECLIN,SOLCON,JULIAN, & SOLCON=0. !-----OBECL : OBLIQUITY = 23.5 DEGREE. - + OBECL=23.5*DEGRAD SINOB=SIN(OBECL) - + !-----CALCULATE LONGITUDE OF THE SUN FROM VERNAL EQUINOX: - + IF(JULIAN.GE.80.)SXLONG=DPD*(JULIAN-80.) IF(JULIAN.LT.80.)SXLONG=DPD*(JULIAN+285.) SXLONG=SXLONG*DEGRAD @@ -806,7 +807,7 @@ SUBROUTINE radconst(XTIME,DECLIN,SOLCON,JULIAN, & ECCFAC=1.000110+0.034221*COS(RJUL)+0.001280*SIN(RJUL)+0.000719* & COS(2*RJUL)+0.000077*SIN(2*RJUL) SOLCON=1370.*ECCFAC - + END SUBROUTINE radconst @@ -873,7 +874,7 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & USE module_state_description, ONLY : KFCUPSCHEME, KFETASCHEME !wig, CuP 4-Fb-2008 !BSINGH - For WRFCuP scheme #if (HWRF == 1) - USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF + USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF #else USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT #endif @@ -928,13 +929,13 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & ! if provided. ! ! Whether QI or QC is active or not is determined from the indices of -! the fields into the 4D scalar arrays in WRF. These indices are +! the fields into the 4D scalar arrays in WRF. These indices are ! P_QI and P_QC, respectively, and they are passed in to the routine ! to enable testing to see if QI and QC represent active fields in ! the moisture 4D scalar array carried by WRF. -! +! ! If a field is active its index will have a value greater than or -! equal to PARAM_FIRST_SCALAR, which is also an input argument to +! equal to PARAM_FIRST_SCALAR, which is also an input argument to ! this routine. !EOP @@ -1095,8 +1096,8 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & !! ARG=MAX(ARG, ARGMIN) !! CLDFRA(i,j,k)=(RHUM/RHGRID)*(1.-EXP(ARG)) IF (CLDFRA(i,j,k) .LT. .01) CLDFRA(i,j,k)=0. - - ENDIF !--- End IF (QCLD .LT. QCLDMIN) ... + + ENDIF !--- End IF (QCLD .LT. QCLDMIN) ... ENDDO !--- End DO i ENDDO !--- End DO k ENDDO !--- End DO j diff --git a/src/writeout.F b/src/writeout.F index 03161d3..72dd7ad 100644 --- a/src/writeout.F +++ b/src/writeout.F @@ -3571,7 +3571,7 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, enddo enddo enddo - + IF ( output_n_as_m3 > 0 ) THEN ! convert output to number per m^3 IF ( trim(qunit(n)) == '#/kg' ) THEN @@ -3606,8 +3606,9 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then - if ( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. & - ptype.eq.60 .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) then + if ( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. & + ptype.eq.56 .or. ptype.eq.57 .or.ptype.eq.60 .or. ptype.eq.61 .or. ptype.eq.62 .or. & + ptype.eq.63) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi1' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 1' @@ -3678,7 +3679,8 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then - if (ptype.eq.52 .or. ptype.eq.54 .or. ptype.eq.61 .or. ptype.eq. 62 .or. ptype.eq.63) then + if (ptype.eq.52 .or. ptype.eq.54 .or. ptype.eq.56 .or. ptype.eq.57 .or.ptype.eq.61 .or. & + ptype.eq. 62 .or. ptype.eq.63) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi2' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 2' @@ -3750,7 +3752,7 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then - if (ptype.eq.62 .or. ptype.eq.63) then + if (ptype.eq. 56 .or. ptype.eq.57 .or. ptype.eq.62 .or. ptype.eq.63) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi3' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 3' @@ -3824,7 +3826,7 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then - if (ptype.eq.63) then + if (ptype.eq. 57 .or. ptype.eq.63) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi4' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 4' @@ -6841,11 +6843,11 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, grid_output(n_out) = 'u' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts IF ( output_uv_ground == 0 ) THEN - + call writeu( ua ,unum,urec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) - + ELSE - + do k=1,maxk do j=1,nj do i=1,ni+1 @@ -6853,9 +6855,9 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, enddo enddo enddo - + call writeu(dumu,unum,urec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) - + ENDIF endif @@ -7317,11 +7319,11 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, grid_output(n_out) = 'v' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts IF ( output_uv_ground == 0 ) THEN - + call writev( va ,vnum,vrec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) - + ELSE - + do k=1,maxk do j=1,nj+1 do i=1,ni @@ -7329,9 +7331,9 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, enddo enddo enddo - + call writev(dumv,vnum,vrec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) - + ENDIF endif @@ -9167,7 +9169,7 @@ subroutine writeocomm3(numi,numj,numk1,numk2,ngxy,d2i,d2j,d3i,d3j,d3n,d3t,nodele enddo ! wait for data to arrive: - ntot = ppnode-1 + nodes-1 + ntot = ppnode-1 + nodes-1 do nn=1,ntot call mpi_waitany(ntot,reqt(1:ntot),index,MPI_STATUS_IGNORE,ierr) if( index.le.(ppnode-1) )then From 2a7224065675218a699370d7cac55e2b6b1ecbf7 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Thu, 16 Jul 2026 20:10:32 -0400 Subject: [PATCH 02/25] Added new runtime options for p3 for cat_init_new to choose ice category destinations for different processes --- run/namelist.input | 31 ++++++++ src/module_mp_p3.F | 106 ++++++++++++++++++------- src/param.F | 188 ++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 285 insertions(+), 40 deletions(-) diff --git a/run/namelist.input b/run/namelist.input index 4f222da..63cfefc 100644 --- a/run/namelist.input +++ b/run/namelist.input @@ -87,6 +87,37 @@ nparcels = 1, / + ! Used when ptype is one of the P3 options (50-54,56-63) + &p3_params + p3_cccn = 300.e6, + p3_nimax = 2000.e3, + p3_iparam = 3, + p3_ccn_on = 0, + p3_merge_opt = 1, + p3_qrcol_opt = 0, + rssflg = 1, + sssflg = 1, + p3_cat_init_new = .true., + p3_catdest_contact_n2 = 1, + p3_catdest_contact_n3 = 3, + p3_catdest_contact_n4 = 4, + p3_catdest_rainimm_n2 = 2, + p3_catdest_rainimm_n3 = 2, + p3_catdest_rainimm_n4 = 2, + p3_catdest_rimesplinter_n2 = 1, + p3_catdest_rimesplinter_n3 = 3, + p3_catdest_rimesplinter_n4 = 3, + p3_catdest_depnuc_n2 = 1, + p3_catdest_depnuc_n3 = 3, + p3_catdest_depnuc_n4 = 4, + p3_catdest_homocloud_n2 = 1, + p3_catdest_homocloud_n3 = 1, + p3_catdest_homocloud_n4 = 1, + p3_catdest_homorain_n2 = 2, + p3_catdest_homorain_n3 = 2, + p3_catdest_homorain_n4 = 2, + / + ¶m3 kdiff2 = 75.0, kdiff6 = 0.040, diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 80999d2..0b1cb9b 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -124,10 +124,29 @@ MODULE microphy_p3 integer :: rssflg = 1 ! Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value integer :: sssflg = 1 ! As above but for ice (all ice) integer :: ccn_on = 0 - integer :: merge_opt = 1 ! 0 = no merging; 1 = diameter-difference merge (original); 2 = percent difference in diam. (Cholette 2024) + integer :: merge_opt = 1 ! -1 = no merging with explicit ice category destination for ncat=2 only (Ted's original hardcoded test with merge_opt = 0) + ! 0 = no merging; 1 = diameter-difference merge (original); 2 = percent difference in diam. (Cholette 2024) integer :: qrcol_opt = 0 ! 0 = no size check on qrcol; 1 = only allow qrcol for ice larger than rain ! for merge_opt=0 with qrcol_opt=2 and ncat=2, this disables qrcol for iice=2 logical :: cat_init_new_default = .true. ! default for mechanism-based ice category initialization + integer :: catdest_contact_n2 = 1 + integer :: catdest_contact_n3 = 3 + integer :: catdest_contact_n4 = 4 + integer :: catdest_rainimm_n2 = 2 + integer :: catdest_rainimm_n3 = 2 + integer :: catdest_rainimm_n4 = 2 + integer :: catdest_rimesplinter_n2 = 1 + integer :: catdest_rimesplinter_n3 = 3 + integer :: catdest_rimesplinter_n4 = 3 + integer :: catdest_depnuc_n2 = 1 + integer :: catdest_depnuc_n3 = 3 + integer :: catdest_depnuc_n4 = 4 + integer :: catdest_homocloud_n2 = 1 + integer :: catdest_homocloud_n3 = 1 + integer :: catdest_homocloud_n4 = 1 + integer :: catdest_homorain_n2 = 2 + integer :: catdest_homorain_n3 = 2 + integer :: catdest_homorain_n4 = 2 ! End ERM contains @@ -135,7 +154,14 @@ MODULE microphy_p3 subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err,dowr, & nanew1_in,iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt,iparamice_in, & - rssflg_in,sssflg_in,max_total_Ni_in,cat_init_new_in) + rssflg_in,sssflg_in,max_total_Ni_in,cat_init_new_in, & + catdest_contact_n2_in,catdest_contact_n3_in,catdest_contact_n4_in, & + catdest_rainimm_n2_in,catdest_rainimm_n3_in,catdest_rainimm_n4_in, & + catdest_rimesplinter_n2_in,catdest_rimesplinter_n3_in, & + catdest_rimesplinter_n4_in,catdest_depnuc_n2_in,catdest_depnuc_n3_in, & + catdest_depnuc_n4_in,catdest_homocloud_n2_in,catdest_homocloud_n3_in, & + catdest_homocloud_n4_in,catdest_homorain_n2_in,catdest_homorain_n3_in, & + catdest_homorain_n4_in) !------------------------------------------------------------------------------------------! ! This subroutine initializes all physical constants and parameters needed by the P3 ! @@ -164,6 +190,12 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err integer, intent(in), optional :: iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt, & iparamice_in,rssflg_in,sssflg_in logical, intent(in), optional :: cat_init_new_in + integer, intent(in), optional :: catdest_contact_n2_in,catdest_contact_n3_in,catdest_contact_n4_in + integer, intent(in), optional :: catdest_rainimm_n2_in,catdest_rainimm_n3_in,catdest_rainimm_n4_in + integer, intent(in), optional :: catdest_rimesplinter_n2_in,catdest_rimesplinter_n3_in,catdest_rimesplinter_n4_in + integer, intent(in), optional :: catdest_depnuc_n2_in,catdest_depnuc_n3_in,catdest_depnuc_n4_in + integer, intent(in), optional :: catdest_homocloud_n2_in,catdest_homocloud_n3_in,catdest_homocloud_n4_in + integer, intent(in), optional :: catdest_homorain_n2_in,catdest_homorain_n3_in,catdest_homorain_n4_in ! End ERM ! Local variables and parameters: logical, save :: is_init = .false. @@ -238,6 +270,24 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err IF ( present( p3_merge_opt ) ) merge_opt = p3_merge_opt IF ( present( p3_qrcol_opt ) ) qrcol_opt = p3_qrcol_opt IF ( present( cat_init_new_in ) ) cat_init_new_default = cat_init_new_in + IF ( present( catdest_contact_n2_in ) ) catdest_contact_n2 = min(2,max(1,catdest_contact_n2_in)) + IF ( present( catdest_contact_n3_in ) ) catdest_contact_n3 = min(3,max(1,catdest_contact_n3_in)) + IF ( present( catdest_contact_n4_in ) ) catdest_contact_n4 = min(4,max(1,catdest_contact_n4_in)) + IF ( present( catdest_rainimm_n2_in ) ) catdest_rainimm_n2 = min(2,max(1,catdest_rainimm_n2_in)) + IF ( present( catdest_rainimm_n3_in ) ) catdest_rainimm_n3 = min(3,max(1,catdest_rainimm_n3_in)) + IF ( present( catdest_rainimm_n4_in ) ) catdest_rainimm_n4 = min(4,max(1,catdest_rainimm_n4_in)) + IF ( present( catdest_rimesplinter_n2_in ) ) catdest_rimesplinter_n2 = min(2,max(1,catdest_rimesplinter_n2_in)) + IF ( present( catdest_rimesplinter_n3_in ) ) catdest_rimesplinter_n3 = min(3,max(1,catdest_rimesplinter_n3_in)) + IF ( present( catdest_rimesplinter_n4_in ) ) catdest_rimesplinter_n4 = min(4,max(1,catdest_rimesplinter_n4_in)) + IF ( present( catdest_depnuc_n2_in ) ) catdest_depnuc_n2 = min(2,max(1,catdest_depnuc_n2_in)) + IF ( present( catdest_depnuc_n3_in ) ) catdest_depnuc_n3 = min(3,max(1,catdest_depnuc_n3_in)) + IF ( present( catdest_depnuc_n4_in ) ) catdest_depnuc_n4 = min(4,max(1,catdest_depnuc_n4_in)) + IF ( present( catdest_homocloud_n2_in ) ) catdest_homocloud_n2 = min(2,max(1,catdest_homocloud_n2_in)) + IF ( present( catdest_homocloud_n3_in ) ) catdest_homocloud_n3 = min(3,max(1,catdest_homocloud_n3_in)) + IF ( present( catdest_homocloud_n4_in ) ) catdest_homocloud_n4 = min(4,max(1,catdest_homocloud_n4_in)) + IF ( present( catdest_homorain_n2_in ) ) catdest_homorain_n2 = min(2,max(1,catdest_homorain_n2_in)) + IF ( present( catdest_homorain_n3_in ) ) catdest_homorain_n3 = min(3,max(1,catdest_homorain_n3_in)) + IF ( present( catdest_homorain_n4_in ) ) catdest_homorain_n4 = min(4,max(1,catdest_homorain_n4_in)) log_nislf = .true. ! flag for ice self-aggregation log_maxnsmall = .true. !flag for resetting n up to nsmall @@ -3076,7 +3126,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi zqrcol(iice) = 10.**(logn0r(i,k))*f1pr36*rho(i,k)*rhofaci(i,k)*eri*iSCF(k)*(SPF(k)-SPF_clr(k)) endif ! ERM begin - IF ( ncat == 2 .and. merge_opt == 0 .and. iice == 2 .and. qrcol_opt == 2. .and. .not. cat_init_new_loc) THEN ! DTD added additional cat_init_new check + IF ( ncat == 2 .and. merge_opt == -1 .and. iice == 2 .and. qrcol_opt == 2. .and. .not. cat_init_new_loc) THEN ! DTD added additional cat_init_new check qrcol(iice) = 0.0 nrcol(iice) = 0.0 zqrcol(iice) = 0.0 ! DTD @@ -3532,7 +3582,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd ! ERM begin - IF ( merge_opt == 0 .and. nCat == 2 ) THEN + IF ( merge_opt == -1 .and. nCat == 2 ) THEN iice_dest = 2 ELSE call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) @@ -3540,11 +3590,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ERM end (call of icecat_destination is still there in orig code of course else if (nCat == 2) then - iice_dest = 1 ! DTD need to see if we want to make this consistent with Ted's option above + iice_dest = catdest_contact_n2 elseif (nCat == 3) then - iice_dest = 3 + iice_dest = catdest_contact_n3 elseif (nCat == 4) then - iice_dest = 4 + iice_dest = catdest_contact_n4 endif endif @@ -3579,7 +3629,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd ! ERM begin diag_3d(i,k,2) = 1000.*D_new - IF ( merge_opt == 0 .and. nCat == 2 ) THEN + IF ( merge_opt == -1 .and. nCat == 2 ) THEN iice_dest = 1 ELSE call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new, & @@ -3589,11 +3639,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ERM end (call of icecat_destination is still there in original of course) else if (nCat == 2) then - iice_dest = 2 ! DTD need to see if we want to make this consistent with Ted's option above + iice_dest = catdest_rainimm_n2 elseif (nCat == 3) then - iice_dest = 2 + iice_dest = catdest_rainimm_n3 elseif (nCat == 4) then - iice_dest = 2 + iice_dest = catdest_rainimm_n4 endif endif if (global_status /= STATUS_OK) return @@ -3620,7 +3670,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (.not. cat_init_new_loc) then D_new = 10.e-6 !assumes ice crystals from rime splintering are tiny ! ERM begin - IF ( merge_opt == 0 .and. nCat == 2 ) THEN + IF ( merge_opt == -1 .and. nCat == 2 ) THEN iice_dest = 2 ELSE call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) @@ -3628,11 +3678,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ERM end (call of icecat_destination is still there in original of course) else if (nCat == 2) then - iice_dest = 1 ! DTD need to see if we want to make this consistent with Ted's option above + iice_dest = catdest_rimesplinter_n2 elseif (nCat == 3) then - iice_dest = 3 + iice_dest = catdest_rimesplinter_n3 elseif (nCat == 4) then - iice_dest = 3 + iice_dest = catdest_rimesplinter_n4 endif endif if (global_status /= STATUS_OK) return @@ -4006,7 +4056,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd ! ERM begin - IF ( merge_opt == 0 .and. nCat == 2 ) THEN + IF ( merge_opt == -1 .and. nCat == 2 ) THEN iice_dest = 2 ELSE call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) @@ -4014,11 +4064,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ERM end (call of icecat_destination is still there in original of course) else if (nCat == 2) then - iice_dest = 1 ! DTD need to see if we want to make this consistent with Ted's option above + iice_dest = catdest_depnuc_n2 elseif (nCat == 3) then - iice_dest = 3 + iice_dest = catdest_depnuc_n3 elseif (nCat == 4) then - iice_dest = 4 + iice_dest = catdest_depnuc_n4 endif endif if (global_status /= STATUS_OK) return @@ -5927,7 +5977,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd ! ERM begin - IF ( merge_opt == 0 .and. nCat == 2 ) THEN + IF ( merge_opt == -1 .and. nCat == 2 ) THEN iice_dest = 2 ELSE call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init, & @@ -5936,11 +5986,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ERM end (call of icecat_destination is still there in orig code of course else if (nCat == 2) then - iice_dest = 1 ! DTD need to see if we want to make this consistent with Ted's option above + iice_dest = catdest_homocloud_n2 elseif (nCat == 3) then - iice_dest = 1 + iice_dest = catdest_homocloud_n3 elseif (nCat == 4) then - iice_dest = 1 + iice_dest = catdest_homocloud_n4 endif endif if (global_status /= STATUS_OK) return @@ -5980,7 +6030,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd ! ERM begin - IF ( merge_opt == 0 .and. nCat == 2 ) THEN + IF ( merge_opt == -1 .and. nCat == 2 ) THEN iice_dest = 1 ELSE call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) @@ -5988,11 +6038,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ERM end (call of icecat_destination is still there in orig code of course else if (nCat == 2) then - iice_dest = 2 ! DTD need to see if we want to make this consistent with Ted's option above + iice_dest = catdest_homorain_n2 elseif (nCat == 3) then - iice_dest = 2 + iice_dest = catdest_homorain_n3 elseif (nCat == 4) then - iice_dest = 2 + iice_dest = catdest_homorain_n4 endif endif if (global_status /= STATUS_OK) return @@ -6022,7 +6072,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !.............................................. ! Merge ice categories with similar properties (based on specified similarly condition) if (.not. cat_init_new_loc) then ! DTD turn off category merging for the new category initialization option for now - multicat: if (nCat.gt.1) then + multicat: if (nCat.gt.1 .and. merge_opt >= 1) then ! ERM added merge_opt check ! multicat: if (.FALSE.) then ! **** TEST !step 1: adjustments and calculation of mean diameters diff --git a/src/param.F b/src/param.F index a4dadc6..62ed49d 100644 --- a/src/param.F +++ b/src/param.F @@ -161,6 +161,24 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & integer :: rssflg = 1 ! P3: Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value integer :: sssflg = 1 ! P3: As for rain but for ice (all ice) logical :: p3_cat_init_new = .true. ! switch for mechanism-based ice category initialization + integer :: p3_catdest_contact_n2 = 1 + integer :: p3_catdest_contact_n3 = 3 + integer :: p3_catdest_contact_n4 = 4 + integer :: p3_catdest_rainimm_n2 = 2 + integer :: p3_catdest_rainimm_n3 = 2 + integer :: p3_catdest_rainimm_n4 = 2 + integer :: p3_catdest_rimesplinter_n2 = 1 + integer :: p3_catdest_rimesplinter_n3 = 3 + integer :: p3_catdest_rimesplinter_n4 = 3 + integer :: p3_catdest_depnuc_n2 = 1 + integer :: p3_catdest_depnuc_n3 = 3 + integer :: p3_catdest_depnuc_n4 = 4 + integer :: p3_catdest_homocloud_n2 = 1 + integer :: p3_catdest_homocloud_n3 = 1 + integer :: p3_catdest_homocloud_n4 = 1 + integer :: p3_catdest_homorain_n2 = 2 + integer :: p3_catdest_homorain_n3 = 2 + integer :: p3_catdest_homorain_n4 = 2 ! ERM end #ifdef MPI integer :: ntmp1,ntmp2,ntmp3,ntmp4,reqs,reqs1,reqs2,reqs3,reqs4 @@ -203,7 +221,25 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_qrcol_opt, & rssflg, & sssflg, & - p3_cat_init_new + p3_cat_init_new,& + p3_catdest_contact_n2, & + p3_catdest_contact_n3, & + p3_catdest_contact_n4, & + p3_catdest_rainimm_n2, & + p3_catdest_rainimm_n3, & + p3_catdest_rainimm_n4, & + p3_catdest_rimesplinter_n2, & + p3_catdest_rimesplinter_n3, & + p3_catdest_rimesplinter_n4, & + p3_catdest_depnuc_n2, & + p3_catdest_depnuc_n3, & + p3_catdest_depnuc_n4, & + p3_catdest_homocloud_n2, & + p3_catdest_homocloud_n3, & + p3_catdest_homocloud_n4, & + p3_catdest_homorain_n2, & + p3_catdest_homorain_n3, & + p3_catdest_homorain_n4 NAMELIST /forcing/ & iforce, & @@ -801,6 +837,24 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(rssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(sssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_cat_init_new,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_contact_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_contact_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_contact_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rainimm_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rainimm_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rainimm_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rimesplinter_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rimesplinter_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rimesplinter_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_depnuc_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_depnuc_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_depnuc_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homocloud_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homocloud_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homocloud_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homorain_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homorain_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homorain_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) ! ERM end #endif @@ -4099,7 +4153,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & ! ERM added new p3 options (all calls) p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.51 )then call p3_init(lookup_file_dir='.', & nCat=1, & @@ -4111,7 +4175,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.52 )then call p3_init(lookup_file_dir='.', & nCat=2, & @@ -4123,7 +4197,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.53 )then call p3_init(lookup_file_dir='.', & nCat=1, & @@ -4135,7 +4219,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.54 )then call p3_init(lookup_file_dir='.', & nCat=2, & @@ -4147,7 +4241,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.56 )then call p3_init(lookup_file_dir='.', & nCat=3, & @@ -4159,7 +4263,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.57 )then call p3_init(lookup_file_dir='.', & nCat=4, & @@ -4171,7 +4285,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.60 )then call p3_init(lookup_file_dir='.', & nCat=1, & @@ -4183,7 +4307,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.61 )then call p3_init(lookup_file_dir='.', & nCat=2, & @@ -4195,7 +4329,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.62 )then call p3_init(lookup_file_dir='.', & nCat=3, & @@ -4207,7 +4351,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.63 )then call p3_init(lookup_file_dir='.', & nCat=4, & @@ -4219,7 +4373,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & - cat_init_new_in=p3_cat_init_new ) + cat_init_new_in=p3_cat_init_new, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) endif if(dowr) write(outfile,*) 'Returned from P3_INIT' From 6260c196dcbb851b98d1e2bfc2e1368603e41033 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Sun, 19 Jul 2026 14:57:51 -0400 Subject: [PATCH 03/25] Added some notes from recent Claude cowork session. Lots of minor modifications to P3 module to include more runtime switches, nsmall checks, etc. --- NOTES.md | 221 ++++++++++++++++++++++ p3_category_swap_audit.md | 140 ++++++++++++++ run/namelist.input | 71 +++---- src/Makefile | 14 +- src/module_mp_p3.F | 383 ++++++++++++++++++++++++++++---------- src/param.F | 28 +++ 6 files changed, 725 insertions(+), 132 deletions(-) create mode 100644 NOTES.md create mode 100644 p3_category_swap_audit.md diff --git a/NOTES.md b/NOTES.md new file mode 100644 index 0000000..9c6fb4f --- /dev/null +++ b/NOTES.md @@ -0,0 +1,221 @@ +# NOTES: P3 category-swap divergence investigation (session record) + +Companion file to `p3_category_swap_audit.md` (the full audit report). This file +records the follow-up discussion and the practical plan, for continuing work in +Claude Code. + +--- + +## Context + +Testing multi-category P3 (`module_mp_p3.F`, CM1 host, WRF-style wrapper) with +`cat_init_new = .true.` (fixed `catdest_*` destination categories per initiation +process), ice-ice interaction and merging disabled, nCat = 4. Swapping the +destination category numbers for rime splintering vs. deposition nucleation +(3/4 vs. 4/3) should theoretically leave results unchanged, but simulations are +identical for several minutes and then diverge. + +## Audit conclusions (see report for full detail and line numbers) + +Two distinct causes were identified: + +1. **Genuine bug (report §2.1):** the `qitot_notsmall_1` gate (line 2871) + requires `nitot > nsmall` *strictly*, while the clipping pass (line 2653) + floors `nitot` to exactly `nsmall`. When the gate is skipped, downstream + process blocks (collection 3104/3115, melting 3305/3331, wet growth 3359, + self-collection 3287, `epsi` 3413) still execute under weaker conditions and + consume **stale `f1pr*` lookup scalars and `Eii_fact`** left over from + whichever category was processed previously — an ordering-dependent + contamination. `f1pr*` are never reset per category iteration. + +2. **Structural order-of-operations roundoff (report §3):** reductions over + categories (`sum(qidep)`, `sum(nitot)` in deposition nucleation, conservation + limiter ratios, `epsi_tot` accumulation) and sequential per-category updates + of shared fields (`qc/qr/qv/th` in `iice_loop3`, clipping loops) combine the + same values in a different order after the swap. FP addition is not + associative → last-bit differences → chaotic growth. Bit-identity under a + category permutation is impossible without making these reductions + permutation-invariant. Also applies host-side: CM1's buoyancy/loading sum + over moist scalars in slot order. + +Cleared: interaction/merge gating, `catdest_*` coverage of all six initiation +processes, sedimentation independence, `impose_max_total_Ni` (commented out), +per-process rate arrays (no destination overwrites). + +## Plan: fix items (2.1)/(2.2) first — **DONE, verified in updated module_mp_p3.F (13,018 lines)** + +Verified implemented (new line numbers): + +- Gate 2873: `nitot .ge. nsmall` (was strict `>`); matching `.ge. nsmall` checks + added to all downstream process blocks (collection 3107/3118, T>0 collection + 3146–3175, ice-ice gate 3202, self-collection 3290, melting 3308/3334, wet + growth 3362, epsi 3416, refreezing 3462, HM 3712, dep/sub 3928/3975) and to + the sedimentation gates (5587, 5681, 5785, 5934). Extra `nc`/`nr ≥ nsmall` + checks added alongside. +- `Eii_fact(iice) = 1.0` default at top of `iice_loop1` (2871); `tmp1 = 0.` + before the rime-fraction block (3067). +- NOT done (optional/defensive): resetting `f1pr01–f1pr38` per category + iteration. With aligned gates, all known stale paths are closed; the + NaN-poisoning + FP-trap test remains the definitive check if paranoid. + +**Separate bug found during re-testing:** NaNs appearing ~3000 s into a run, +traced to divide-by-zero in Seifert–Beheng autoconversion (`iparam=1`): +`(1.-dum)**2` denominator blows up as `dum → 1` (qc negligible vs qr). Fixed +with `if (dum < 1.)` guard; `qc_not_small_1` gate now also requires +`nc*iSCF ≥ nsmall`; `isnan` traps added (custom `isnan(x) = x /= x` at 11664). +Switching to default `iparam=3` going forward. `log_debug` off. + +Two minor code observations for later cleanup: +- The `isnan` traps call plain `stop`, which under MPI may not cleanly + terminate all ranks (prefer the host's abort, e.g. MPI_Abort via CM1's + stopcm1 mechanism, if these are kept long-term). +- A custom `x /= x` NaN test can be optimized away under fast-math-style + compiler flags; fine under default gfortran/ifort settings. + +**Status: swap-test divergence persists after these fixes** — consistent with +the report's prediction that the §3 order-of-operations sites are sufficient +on their own. Next step: the §4 program (Phase 1/2 instrumentation below, then +the double-precision A/B test), keeping in mind the CM1 buoyancy-sum ceiling +noted under "CM1-specific notes." + +Original agreed fix list (retained for reference): + +- **Gate consistency (2.1):** change line 2871 (and sedimentation gates 5393, + 5487, 5740 for consistency) to `nitot(i,k,iice) .ge. nsmall`, or make every + downstream consumer of `f1pr*` require the exact same predicate as the gate + (e.g., per-category logical `log_lookupFresh(iice)`). +- **Defaults (2.2):** `Eii_fact(iice) = 1.` is the correct default (matches the + `qirim <= 0` else-branch, i.e., "unrimed / no shutoff"), and `tmp1 = 0.` + before the `if (qirim > 0.)` block (Fr = 0 → `Eii_fact = 1`, consistent). + Caveats discussed: + - Initialize **per category iteration** (top of `iice_loop1`), not once per + column; the hazard is per-(i,k), per-category. + - Set `tmp1 = 0.` immediately before use — it is a reused scratch variable. + - These defaults alone do NOT fix stale `f1pr03/04/05/14` consumption + (`nislf`, collection, melting); the gate alignment is still required. + `Eii_fact = 1` alone would enable self-collection with a wrong lookup value. +- Defensive: reset all `f1pr01–f1pr38` at the top of each `iice_loop1` + iteration. To *prove* the stale path fires: initialize them (and `Eii_fact`, + `tmp1`) to signaling NaNs and compile with FP trapping + (`-ffpe-trap=invalid` / `-fpe0`). + +## Q&A: does `sum()` depend on element order? + +`sum()` is deterministic for fixed contents in fixed slots (same array → same +bits; the earlier DTD fix at line 4477–4481 addressed a different, worse issue: +re-summing a partially modified array). But the swap experiment **permutes the +contents** of the summed arrays. FP addition is commutative but not +associative; `sum()` evaluates in fixed positional order, so +`((a1+a2)+a3)+a4` vs `((a1+a2)+a4)+a3` can differ in the last bit. + +Concrete single-precision example — summing {16777216 (=2^24), 5, 2}, where +float spacing is 2.0: + +- `(2^24 + 5) + 2` → rounds to 16777220, then +2 → **16777222** +- `(2^24 + 2) + 5` → exact 16777218, then +5 → 16777223 → rounds → **16777224** + +Same mechanism applies to the sequential shared-field updates in `iice_loop3` +(a loop-form sum). Note: the Fortran standard doesn't specify `sum()` +evaluation order (optimizers may use vectorized partial sums), but that's +irrelevant when both runs use the same binary. + +## Diagnostic workflow: checksums + bisection + +**Phase 1 — find first divergent timestep.** Bitwise, position-weighted XOR +hash per field per timestep, printed from the wrapper after `p3_main`: + +```fortran +function bitsum(arr) result(cs) + real, intent(in) :: arr(:) + integer(8) :: cs + integer(4) :: bits(size(arr)) + integer :: n + bits = transfer(arr, bits) ! reinterpret bits; no rounding + cs = 0 + do n = 1, size(arr) + cs = ieor(cs, int(bits(n),8) * int(n,8)) + enddo +end function +``` + +Print `itimestep, j, bitsum(qv), bitsum(th), bitsum(qc), bitsum(qr), ...` and +hash each `qitot(:,:,iice)` slice separately. Diff the two runs' logs; first +mismatch = first divergent timestep. + +Caveats: +- Compare ice categories **under the swap mapping** (cat 3 of run A vs cat 4 of + run B for the swapped species); otherwise trivially "divergent." +- Same processor count/decomposition both runs; compare rank-to-rank. + +**Phase 2 — find first divergent (i,k,j) and field.** Restart both runs just +before the divergent step (CM1 `rstfrq` restarts are bit-reproducible for +identical config/decomposition). Dump raw state **before and after** the +`p3_main` call for the two bracketing timesteps (unformatted stream write). +Compare in Python bitwise: + +```python +import numpy as np +a = np.fromfile('A/p3dump_...bin', dtype=np.float32) +b = np.fromfile('B/p3dump_...bin', dtype=np.float32) +d = np.argwhere(a.view(np.int32) != b.view(np.int32)) +``` + +Interpretation: first-diff relative magnitude ~1e-7 → order-of-operations +seeding; larger jump, or located where a category sits at `nitot == nsmall` → +the stale-`f1pr*` bug. Pre- vs post-`p3_main` tells whether the seed is inside +microphysics or in the host (but in CM1 a pre-call divergence may just be the +buoyancy scalar sum flipping a bit first — it does not by itself clear or +implicate the microphysics). + +**Phase 3 — instrument the point.** Targeted prints of individual process +rates (`qccol`, `qidep`, `qrmlt`, `epsi_tot`, conservation `ratio`s) guarded by +`if (i==i0 .and. k==k0 .and. it==it0)`; diff between runs. + +**Discriminating test for the roundoff class:** double-precision build. If +divergence onset is delayed dramatically → roundoff seeding; barely changed → +logic bug. + +## CM1-specific notes + +- No per-rank `rsl.out` files; either run serial for diagnosis or write + checksums to per-rank files (filename with `myid`). +- `radopt = 0` (no radiation) removes the `diag_effi_ave` → radiation pathway. +- CM1's buoyancy/loading term sums moist scalars over the scalar index in fixed + loop order → host-side permutation sensitivity independent of P3. Even a + fully fixed microphysics will not give bit-identity under the swap unless + this is addressed too. + +## MPI reproducibility on laptop (OpenMPI / mpirun) + +- Which physical cores ranks land on is irrelevant to the bits; binding + affects speed only. What matters: **same `-np`**, and set `nodex`/`nodey` + explicitly and identically in `namelist.input` (`nodex*nodey = np`). +- Same executable/build for both runs (swap should be namelist-only). +- If built with OpenMP: `OMP_NUM_THREADS=1` (threaded FP reductions are the one + genuine source of run-to-run nondeterminism). +- CM1's feedback-relevant global reduction (adaptive-dt CFL check) is a `max` + — exact and order-independent; global sums are diagnostics only. +- **Validate first:** run the identical configuration twice (no swap) and + confirm checksums match bit-for-bit every timestep. Prefer `-np 1` for the + definitive comparison runs if feasible. + +## Permutation-invariance options (if pursuing full invariance later) + +(a) accumulate category reductions and shared-field tendencies in double +precision, round once (practical, not formally invariant); (b) sum categories +in value-sorted order (formally slot-permutation-invariant; ties harmless); +(c) restructure so per-category tendencies are stored in arrays and applied to +shared fields in one fused expression (fixes `iice_loop3` and clipping loops, +the largest contributors). Any single surviving order-sensitive reduction will +still eventually diverge. + +## Handoff to Claude Code + +This local Cowork session can't be resumed in the Claude Code CLI (each surface +keeps its own session history; `--teleport` applies to cloud sessions only). +Plan: copy `p3_category_swap_audit.md` and this `NOTES.md` into the CM1 source +directory, start `claude` there, and prompt e.g.: + +> Read p3_category_swap_audit.md and NOTES.md. The report section 2.1/2.2 +> fixes are already implemented in src/module_mp_p3.F. Add the Phase-1 +> checksum instrumentation described in NOTES.md. diff --git a/p3_category_swap_audit.md b/p3_category_swap_audit.md new file mode 100644 index 0000000..6135ed0 --- /dev/null +++ b/p3_category_swap_audit.md @@ -0,0 +1,140 @@ +# Audit: Why swapping `iice_dest` category numbers changes P3 solutions + +> **STATUS UPDATE (post-fix revision of module_mp_p3.F, 13,018 lines — verified):** +> The fixes for Sections 2.1 and 2.2 below have been **implemented and verified** in the +> updated source: +> - Gate at (new) line 2873 changed to `nitot(i,k,iice) .ge. nsmall`, and matching +> `.ge. nsmall` number-concentration checks added to all downstream process blocks +> (collection 3107/3118, T>0 collection 3146–3175, ice-ice gate 3202, self-collection +> 3290, melting 3308/3334, wet growth 3362, epsi 3416, refreezing 3462, HM 3712, +> dep/sub 3928/3975) and to the sedimentation gates (5587, 5681, 5785, 5934). +> Additional `nc`/`nr ≥ nsmall` checks added alongside. +> - `Eii_fact(iice) = 1.0` default at top of `iice_loop1` (line 2871); `tmp1 = 0.` +> initialized before the rime-fraction block (line 3067). +> - Separate issue found and fixed: divide-by-zero in Seifert–Beheng autoconversion +> (`iparam=1`) when `dum → 1` (the `(1.-dum)**2` denominator), a rare trigger that +> produced NaNs ~3000 s into one run. Guarded with `if (dum < 1.)`, the +> `qc_not_small_1` gate now also requires `nc*iSCF ≥ nsmall`, and `isnan` traps were +> added. Default `iparam=3` is used going forward. +> - `f1pr*` scalars are still not defensively reset per category iteration; with the +> aligned gates all *known* stale-consumption paths are closed, but the NaN-poisoning +> test remains available as a definitive check. +> +> **Result: swap-test divergence persists after these fixes.** This is consistent with +> this report's prediction that the Section 3 order-of-operations sites are sufficient +> on their own to break bit-identity. Next step is the Section 4 program: Phase 1/2 +> checksum instrumentation to locate the first divergent timestep/point and measure the +> seed magnitude, and the double-precision A/B test to confirm the roundoff mechanism. +> Line numbers in the body below refer to the **original** audited file (12,823 lines). + +**File audited:** `module_mp_p3.F` (12,823 lines) +**Configuration assumed:** `cat_init_new = .true.` (fixed `catdest_*` destinations), `log_iceice_interaction = .false.`, category merging off (merging is disabled under `cat_init_new`, line 6074), `nCat = 4`, swap of `catdest_depnuc_n4` and `catdest_rimesplinter_n4` (3↔4 vs 4↔3). + +--- + +## 1. Bottom line + +The audit found **both** things you were hoping to distinguish between: + +1. **A genuine bug class** — stale/uninitialized work variables (`f1pr*`, `Eii_fact`, `tmp1`) that leak from one category's lookup-table retrieval into another category's process rates, in a way that depends on category *ordering*. This is a real defect and should be fixed. + +2. **A structural property of the code** — many reductions over categories and sequential updates of shared fields are performed in category-index order. Under a pure content-swap of categories 3 and 4, these combine *the same physical numbers in a different order*, which changes the last bit of the result. In single precision, in a moist convective simulation, a 1-ulp difference amplifies to visible divergence within minutes. + +Even after fixing item 1, **bit-identical results under a category permutation are not achievable with the code as structured** unless the category reductions are made permutation-invariant (Section 4 explains how, and how to test which class is responsible for what you're seeing). + +The "identical for several minutes, then divergence" signature is consistent with either class: nothing differs until the *first* time step and grid point at which the two swapped ice species (or the edge case in Section 2.1) coexist in a single sum or shared-field update; from then on the perturbation grows chaotically. + +--- + +## 2. Genuine bugs (asymmetric, order-dependent behavior) + +### 2.1 Stale `f1pr*` lookup values consumed when `nitot == nsmall` exactly (most likely "real bug") + +This is the strongest candidate for a true defect. + +The main per-category lookup-table block is gated at line 2871: + +```fortran +qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > nsmall ) then ! ERM added nitot check +``` + +Note the **strict** `> nsmall`. But the clipping pass earlier (line 2653) floors number concentration to **exactly** `nsmall` whenever `qitot ≥ qsmall` and `nitot < nsmall`: + +```fortran +nitot(i,k,iice) = Max (nitot(i,k,iice), nsmall) ! ERM +``` + +So any category arriving with `qitot ≥ qsmall` (=1e-12) and depleted number gets `nitot == nsmall` (=1e-8) exactly, and the `qitot_notsmall_1` block is **skipped** — no lookup-table calls, no refresh of `f1pr01…f1pr38`, no `Eii_fact(iice)`, no `diam_ice` update. + +However, the downstream process-rate blocks for that same category use *weaker* conditions and still execute: + +- **Cloud collection** (line 3104): `qitot ≥ qsmall .and. nitot > 0.` → computes `qccol`, `nccol` using `f1pr04`. +- **Rain collection** (line 3115): same gate → uses `f1pr07`, `f1pr08`, `f1pr36`. +- **Melting** (lines 3305/3331): `qitot − qiliq ≥ qsmall .and. T > 273.15` — **no nitot condition at all** → uses `f1pr05`, `f1pr14` (or `f1pr24–f1pr27`). +- **Wet growth** (line 3359): uses `f1pr05`, `f1pr14`. +- **Ice self-collection** (line 3287): `qitot ≥ qsmall` → uses `f1pr03` and `Eii_fact(iice)`. +- **Vapor relaxation timescale** (line 3413): `qitot ≥ qsmall` → `epsi(iice)` from `f1pr05`, `f1pr14`, which feeds `epsi_tot` and hence `xx`, `aaa`, and the deposition/condensation rates of **all** species at that grid point. + +The `f1pr*` variables are **plain scalars, never reset per category iteration** (grep confirms no `f1pr04 = 0.` style initializations; only the `-99` sentinels for `f1pr07/08` when `qr < qsmall`). So the affected category computes its rates using the lookup values of **whichever category was most recently processed through the gate** — or, if no category has passed yet at this grid point, leftover values from a previous k-level or column (or genuinely uninitialized values on first use). + +**Why this breaks your swap symmetry:** suppose at some (i,k), category A has healthy ice and category B is in the degenerate `nitot == nsmall` state. If A has the lower index, B inherits A's `f1pr*` values. After swapping the destination assignments, B now has the lower index — and inherits values from category 2, or from a previous level, instead. The contamination is different in the two runs, so the process rates differ by more than roundoff. The contaminated rates are proportional to `nitot = 1e-8`, so each individual instance is tiny — but a tiny asymmetric perturbation is all it takes. + +The same `ERM` gate (`nitot > nsmall`) appears in sedimentation (lines 5393, 5487, 5740), but there the fall speeds are explicitly zeroed each substep (`V_qit(:) = 0.`), so no staleness occurs. The final-diagnostics loop (line 6272) uses `≥ nsmall` — inconsistent with the strict `>` in the main loop, incidentally. + +**Fix suggestions:** +- Make the gates consistent: either change line 2871 (and the sedimentation gates) to `nitot(i,k,iice) .ge. nsmall`, or make every downstream process condition require exactly the same predicate as `qitot_notsmall_1` (e.g., set a per-category logical `log_lookupFresh(iice)` inside the gate and require it in every block that consumes `f1pr*`). +- Defensively reset all `f1pr*` scalars (and `Eii_fact(iice)`, see 2.2) at the top of each `iice_loop1` iteration. A cheap way to *prove* this mechanism is active: initialize them to signaling NaNs with FP trapping enabled — the trap will fire at the first stale consumption. + +### 2.2 `Eii_fact` and `tmp1` initialization gaps + +`Eii_fact` (dimension `nCat`) is set **only** inside `qitot_notsmall_1` (lines 3065–3079) and is never given a default. Any consumption outside the gate (self-collection at 3288, and ice-ice collection if you ever re-enable it) uses a stale value from a previous k-level or an undefined one on first touch. + +Inside its computation there is a second stale-scalar hazard (lines 3065–3068): + +```fortran +if (qirim(i,k,iice)>0.) then + if ((qitot(i,k,iice)-qiliq(i,k,iice))>0.) then + tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) + endif + if (tmp1.lt.0.6) then ... +``` + +If `qirim > 0` while `qitot − qiliq ≤ 0` (inconsistent but reachable state), `tmp1` retains whatever the previous category or process left in it. `tmp1` is a heavily reused scratch variable, so the inherited value is arbitrary and ordering-dependent. + +### 2.3 Things checked and found clean (for your configuration) + +Ice–ice collection and its tendency application are both properly gated by `log_iceice_interaction` (lines 3188, 4706). Merging is off under `cat_init_new` (line 6074). All six initiation processes (contact/immersion freezing, rain immersion, rime splintering, deposition nucleation, homogeneous cloud and rain freezing) have `catdest_*` assignments for nCat = 2, 3, 4, and none falls back to `icecat_destination` or a hardcoded index when `cat_init_new = .true.`. The `merge_opt == -1` / `qrcol_opt == 2` special cases are restricted to `nCat == 2` and don't fire at nCat = 4. `impose_max_total_Ni` — which scales all categories by a ratio involving `sum(nitot)` — is commented out at all three call sites. Each initiation process writes to its own rate array (`qcheti`, `qrheti`, `qinuc`, `qrmul`, …), so no destination-overwrite conflicts exist. Sedimentation is fully independent per category. `diam_ice` is zeroed at line 2501 and again before homogeneous freezing (5932), so its staleness only causes a category's HM size check to fail deterministically, which is symmetric. + +--- + +## 3. Inherent order-of-operations sites (unavoidable with current structure) + +These all combine identical physical values in category-index order. Floating-point addition is not associative, so a content swap of categories 3 and 4 changes the rounding wherever both hold nonzero values. Each occurrence seeds an O(1 ulp) relative perturbation into a prognostic field. + +**Sequential updates of shared prognostic fields inside category loops.** The largest contributor is `iice_loop3` (lines 4657–4771), where `qc`, `nc`, `qr`, `nr`, `qv`, and `th` are updated once per category, in loop order: `((qc − s₁·dt) − s₂·dt) − s₃·dt − s₄·dt` ≠ the same with s₃ and s₄ interchanged. The same pattern occurs in the initial clipping loop (2641–2683, `qv`/`th` incremented per category), the liquid-fraction clipping loop (4797), the small-value clipping loop (4832), and the final-diagnostics loop (6428). + +**Explicit reductions over categories.** `sum(nitot(i,k,:))` inside deposition nucleation (lines 4047, 4050) — this one directly modulates `N_nuc`/`Q_nuc`, i.e., the very processes you swapped. The saturation-adjustment and conservation limiters at lines 4431, 4447–4448, 4459–4464, 4490–4491, 4518–4521, 4600–4601 (`sum(qidep)`, `sum(qccol)`, `sum(qisub)`, etc.), where the resulting `ratio` rescales every category's rates. The accumulations `epsi_tot = epsi_tot + epsi(iice)` (line 3417) and `epsiw_tot` (3422), which feed `xx` and `aaa` (3783, 3824) and therefore condensation/deposition for everything at that grid point. The Hallett–Mossop accumulation `qrmul(iice_dest) = qrmul(iice_dest) + dum2` over source categories (3739–3740). `compute_SCPF(Qc + sum(Qitot,dim=2), …)` (2718, 5069, 5921) if SCPF is active. + +Notably, the code already contains one fix for exactly this issue — DTD's comment at lines 4477–4481 ("replaced sum(qisub) with tmp2 to avoid repeated summation (and potential order-dependent results)"). That fix addressed a *worse* variant (re-summing a partially-modified array), but the ordinary permuted-content sensitivity remains everywhere `sum()` is used. + +**Host-model couplings outside this file.** Per-scalar advection is identical regardless of which tracer slot holds a species, but anything in the host that sums hydrometeors in array order can also seed differences: total-condensate loading in the pressure/buoyancy terms, and the wrapper's `diag_effi_ave` (lines 1195–1204, `dum1+dum2+dum3+dum4`) if it feeds radiation. + +--- + +## 4. How to determine which class you're seeing, and what to do + +**Diagnose the seed.** At the first divergent time step, difference the two runs' full state. If the maximum relative difference is ~1e-7 (single-precision ulp) and confined to a few grid points where both swapped species coexist, the seed is Section 3 roundoff. If you see a jump much larger than that, or differences localized where one category sits at `nitot == nsmall`, it's the Section 2.1 bug. Writing per-timestep, per-field checksums and bisecting to the first divergent (i,j,k) is cheap and definitive. + +**Trap the stale-value bug directly.** Compile with FP trapping (`-ffpe-trap=invalid` / `-fpe0`) after initializing `f1pr01…f1pr38`, `Eii_fact`, and `tmp1` to signaling NaNs at the top of each `iice_loop1` iteration. Any trap is proof the bug path executes in your runs. Independently, changing the line-2871 gate to `.ge. nsmall` and re-running the swap test tells you how much of the divergence that path explains. + +**Test the roundoff hypothesis.** Build the model in double precision (or promote just the microphysics reals). If divergence onset is delayed dramatically (roundoff seeds shrink from ~1e-7 to ~1e-16 relative), the driver is Section 3. If the timing barely changes, keep hunting for a logic bug. + +**If you want true permutation invariance** (bit-identical results under destination swaps), the reductions must be made independent of which slot holds which value. Practical options, in increasing rigor: (a) accumulate all category reductions and shared-field tendency sums in double precision and round once — not formally invariant, but usually pushes differences below single-precision representability for a long time; (b) sum categories in a *value-sorted* order (a sum over ascending values is invariant to slot permutation; ties are harmless because equal values commute); (c) restructure so per-category tendencies are stored in arrays and applied to shared fields in a single fused expression rather than incrementally per category — this fixes `iice_loop3` and the clipping loops, which are the biggest contributors. Note that even one surviving order-sensitive reduction is enough to eventually diverge. + +--- + +## 5. Summary of most likely culprits, ranked + +**(1)** Order-of-operations roundoff in category reductions and sequential shared-field updates (Section 3) — mathematically guaranteed to break bit-identity once swapped species coexist anywhere; fully consistent with your observed timeline. **(2)** The `nitot == nsmall` stale-`f1pr*`/`Eii_fact` gating bug (Section 2.1) — a genuine, fixable defect producing ordering-dependent physics, though its rate perturbations are individually tiny. **(3)** The `tmp1`/`Eii_fact` initialization gaps (2.2) — same family, rarer trigger. **(4)** Host-side order-sensitive sums (total condensate, `diag_effi_ave` → radiation) — worth checking once the in-scheme sources are controlled. + +The realistic expectation: fixing (2) and (3) is worthwhile and may change the divergence onset, but exact invariance under the swap will additionally require (1)-class restructuring or the double-precision accumulation strategy. The double-precision A/B test in Section 4 is the fastest way to confirm this before investing in refactoring. diff --git a/run/namelist.input b/run/namelist.input index 63cfefc..3051d80 100644 --- a/run/namelist.input +++ b/run/namelist.input @@ -87,37 +87,6 @@ nparcels = 1, / - ! Used when ptype is one of the P3 options (50-54,56-63) - &p3_params - p3_cccn = 300.e6, - p3_nimax = 2000.e3, - p3_iparam = 3, - p3_ccn_on = 0, - p3_merge_opt = 1, - p3_qrcol_opt = 0, - rssflg = 1, - sssflg = 1, - p3_cat_init_new = .true., - p3_catdest_contact_n2 = 1, - p3_catdest_contact_n3 = 3, - p3_catdest_contact_n4 = 4, - p3_catdest_rainimm_n2 = 2, - p3_catdest_rainimm_n3 = 2, - p3_catdest_rainimm_n4 = 2, - p3_catdest_rimesplinter_n2 = 1, - p3_catdest_rimesplinter_n3 = 3, - p3_catdest_rimesplinter_n4 = 3, - p3_catdest_depnuc_n2 = 1, - p3_catdest_depnuc_n3 = 3, - p3_catdest_depnuc_n4 = 4, - p3_catdest_homocloud_n2 = 1, - p3_catdest_homocloud_n3 = 1, - p3_catdest_homocloud_n4 = 1, - p3_catdest_homorain_n2 = 2, - p3_catdest_homorain_n3 = 2, - p3_catdest_homorain_n4 = 2, - / - ¶m3 kdiff2 = 75.0, kdiff6 = 0.040, @@ -243,9 +212,9 @@ ! custom bubble settings for iinit=1 &bubble numbub = 0, - tbubrandpert = 0.0, - tbub = 1.0, 1.0, 3.0, - xradbub = 10000.0, 1.0e4, 1.0e4, + tbubrandpert = 0.0, + tbub = 1.0, 1.0, 3.0, + xradbub = 10000.0, 1.0e4, 1.0e4, yradbub = 10000.0, 1.0e4, 1.0e4, zradbub = 1400.0, 1500., 1500., xcbub = 17000.0, 17000, 5.0e4, @@ -257,7 +226,7 @@ &forcing iforce = 0, nwfor = 0, - iwforce = 0, + iwforce = 0, iwshap = -1, -1, -1, wfmeso = 3.0e-2, 2.0e-2, 4.0e-2 xwfrad = 6000.0, 6000., 2.5e3, @@ -474,3 +443,35 @@ cnoh = 4.e4, ! for single moment only / +! Used when ptype is one of the P3 options (50-54,56-63) + &p3_params + p3_cccn = 300.e6, + p3_nimax = 2000.e3, + p3_iparam = 3, + p3_ccn_on = 0, + p3_merge_opt = 1, + p3_qrcol_opt = 0, + rssflg = 1, + sssflg = 1, + p3_cat_init_new = .true., + log_nislf = .true., + log_iceice_interaction = .true., + p3_catdest_contact_n2 = 1, + p3_catdest_contact_n3 = 3, + p3_catdest_contact_n4 = 4, + p3_catdest_rainimm_n2 = 2, + p3_catdest_rainimm_n3 = 2, + p3_catdest_rainimm_n4 = 2, + p3_catdest_rimesplinter_n2 = 1, + p3_catdest_rimesplinter_n3 = 3, + p3_catdest_rimesplinter_n4 = 3, + p3_catdest_depnuc_n2 = 1, + p3_catdest_depnuc_n3 = 3, + p3_catdest_depnuc_n4 = 4, + p3_catdest_homocloud_n2 = 1, + p3_catdest_homocloud_n3 = 1, + p3_catdest_homocloud_n4 = 1, + p3_catdest_homorain_n2 = 2, + p3_catdest_homorain_n3 = 2, + p3_catdest_homorain_n4 = 2, + / diff --git a/src/Makefile b/src/Makefile index b65f4e6..6505a14 100644 --- a/src/Makefile +++ b/src/Makefile @@ -76,15 +76,23 @@ LINKOPTS = -lnetcdf -lnetcdff #OMP = -DOPENMP #----------------------------------------------------------------------------- # single processor, GNU compiler -FC = gfortran -OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding +# FC = gfortran +# OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions +# CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding #----------------------------------------------------------------------------- # multiple processors, distributed memory (MPI), GNU compiler FC = mpif90 OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding DM = -DMPI +# multiple processors, distributed memory (MPI), GNU compiler, double precision +# DTD TODO: this doesn't seem to work on my Macbook at least. Run stalls somewhere before starting +# the main time loop. +# FC = mpif90 +# OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -fdefault-real-8 -fdefault-double-8 +# CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding +# DM = -DMPI +# DP = -DDP #----------------------------------------------------------------------------- # multiple processors, shared memory (OpenMP), GNU compiler #FC = gfortran diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 0b1cb9b..48b16b8 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -92,7 +92,7 @@ MODULE microphy_p3 ! integer switch for primary ice nucleation (ERM) integer :: iparamice - logical :: log_nislf ! flag for ice self-aggregation + logical :: log_nislf = .true. ! default flag for ice self-aggregation logical :: log_maxnsmall ! number of diagnostic ice-phase hydrometeor types integer, public, parameter :: n_qiType = 6 @@ -128,7 +128,8 @@ MODULE microphy_p3 ! 0 = no merging; 1 = diameter-difference merge (original); 2 = percent difference in diam. (Cholette 2024) integer :: qrcol_opt = 0 ! 0 = no size check on qrcol; 1 = only allow qrcol for ice larger than rain ! for merge_opt=0 with qrcol_opt=2 and ncat=2, this disables qrcol for iice=2 - logical :: cat_init_new_default = .true. ! default for mechanism-based ice category initialization + logical :: cat_init_new = .true. ! default for mechanism-based ice category initialization + logical :: log_iceice_interaction = .true. ! default for allowing ice categories to interact integer :: catdest_contact_n2 = 1 integer :: catdest_contact_n3 = 3 integer :: catdest_contact_n4 = 4 @@ -155,6 +156,8 @@ MODULE microphy_p3 subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err,dowr, & nanew1_in,iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt,iparamice_in, & rssflg_in,sssflg_in,max_total_Ni_in,cat_init_new_in, & + log_nislf_in, & + log_iceice_interaction_in, & catdest_contact_n2_in,catdest_contact_n3_in,catdest_contact_n4_in, & catdest_rainimm_n2_in,catdest_rainimm_n3_in,catdest_rainimm_n4_in, & catdest_rimesplinter_n2_in,catdest_rimesplinter_n3_in, & @@ -190,6 +193,8 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err integer, intent(in), optional :: iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt, & iparamice_in,rssflg_in,sssflg_in logical, intent(in), optional :: cat_init_new_in + logical, intent(in), optional :: log_nislf_in + logical, intent(in), optional :: log_iceice_interaction_in integer, intent(in), optional :: catdest_contact_n2_in,catdest_contact_n3_in,catdest_contact_n4_in integer, intent(in), optional :: catdest_rainimm_n2_in,catdest_rainimm_n3_in,catdest_rainimm_n4_in integer, intent(in), optional :: catdest_rimesplinter_n2_in,catdest_rimesplinter_n3_in,catdest_rimesplinter_n4_in @@ -269,7 +274,9 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err IF ( present( p3_ccn_on ) ) ccn_on = p3_ccn_on IF ( present( p3_merge_opt ) ) merge_opt = p3_merge_opt IF ( present( p3_qrcol_opt ) ) qrcol_opt = p3_qrcol_opt - IF ( present( cat_init_new_in ) ) cat_init_new_default = cat_init_new_in + IF ( present( cat_init_new_in ) ) cat_init_new = cat_init_new_in + IF ( present( log_nislf_in ) ) log_nislf = log_nislf_in + IF ( present( log_iceice_interaction_in ) ) log_iceice_interaction = log_iceice_interaction_in IF ( present( catdest_contact_n2_in ) ) catdest_contact_n2 = min(2,max(1,catdest_contact_n2_in)) IF ( present( catdest_contact_n3_in ) ) catdest_contact_n3 = min(3,max(1,catdest_contact_n3_in)) IF ( present( catdest_contact_n4_in ) ) catdest_contact_n4 = min(4,max(1,catdest_contact_n4_in)) @@ -288,8 +295,7 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err IF ( present( catdest_homorain_n2_in ) ) catdest_homorain_n2 = min(2,max(1,catdest_homorain_n2_in)) IF ( present( catdest_homorain_n3_in ) ) catdest_homorain_n3 = min(3,max(1,catdest_homorain_n3_in)) IF ( present( catdest_homorain_n4_in ) ) catdest_homorain_n4 = min(4,max(1,catdest_homorain_n4_in)) - log_nislf = .true. ! flag for ice self-aggregation - log_maxnsmall = .true. !flag for resetting n up to nsmall + log_maxnsmall = .false. !flag for resetting n up to nsmall ! Primary ice nucleation ! 1 = Cooper @@ -1092,8 +1098,7 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes n_diag2d,diag2d(its:ite,1:n_diag2d),n_diag3d,diag3d(its:ite,kts:kte,1:n_diag3d), & log_predictNc,trim(model),clbfact_dep,clbfact_sub,log_debug,log_scpf, & scpf_pfrac,scpf_resfact,cldfrac,log_3momIce,log_liqFrac, & - diag_dhmax = diag_dhmax, j_index = j_index, log_diag = log_diag, & - cat_init_new = cat_init_new_default) ! DTD added j-index for debugging, ERM added log_diag + diag_dhmax = diag_dhmax, j_index = j_index, log_diag = log_diag) ! DTD added j-index for debugging, ERM added log_diag !surface precipitation output: dum1 = 1000.*dt @@ -1597,7 +1602,7 @@ function mp_p3_wrapper_gem(ttend,qtend,qctend,qrtend,qitend, if (.not. log_trplMomI) zitot = 0. !not used, but avoids passing uninialized values if (.not. log_liqFrac) qiliq = 0. !not used, but avoids passing uninialized values - call p3_main(qc,nc,qr,nr,theta_m,theta,qvapm,qvap,dt_mp,qitot,qirim,qiliq,nitot,birim, & + call p3_main(qc,nc,qr,nr,theta_m,theta,qvapm,qvap,dt_mp,qitot,qirim,qiliq,nitot,birim, & zitot,ssat,ww,pres,DZ,kount,prt_liq,prt_sol,i_strt,ni,k_strt,nk,n_iceCat, & diag_Zet,diag_effc,diag_effi,diag_vmi,diag_di,diag_rhoi,n_diag_2d,diag_2d, & n_diag_3d,diag_3d,log_predictNc,trim(model),clbfact_dep,clbfact_sub, & @@ -1608,8 +1613,7 @@ function mp_p3_wrapper_gem(ttend,qtend,qctend,qrtend,qitend, diag_vis1 = diag_vis1, & diag_vis2 = diag_vis2, & diag_vis3 = diag_vis3, & - diag_dhmax = diag_dhmax, & - cat_init_new = cat_init_new_default) + diag_dhmax = diag_dhmax) if (global_status /= STATUS_OK) return @@ -2036,8 +2040,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi clbfact_sub,debug_on,scpf_on,scpf_pfrac,scpf_resfact,SCF_out, & log_3momentIce,log_LiquidFrac,prt_drzl,prt_rain,prt_crys,prt_snow, & prt_grpl,prt_pell,prt_hail,prt_sndp,prt_wsnow,qi_type, & - diag_vis,diag_vis1,diag_vis2,diag_vis3,diag_dhmax,j_index,log_diag, & - cat_init_new) ! DTD added j-index for debugging, ERM added log_diag + diag_vis,diag_vis1,diag_vis2,diag_vis3,diag_dhmax,j_index,log_diag) ! DTD added j-index for debugging, ERM added log_diag !----------------------------------------------------------------------------------------! ! ! @@ -2132,7 +2135,6 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real, intent(out), dimension(its:ite,kts:kte) :: SCF_out ! cloud fraction from SCPF integer, intent(in), optional :: j_index ! DTD added j-index for debugging logical, intent(in) :: log_diag ! ERM added - logical, intent(in), optional :: cat_init_new ! optional switch for category initialization !----- Local variables and parameters: -------------------------------------------------! @@ -2150,7 +2152,6 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! End ERM logical, parameter :: log_liqsatadj = .false. ! temporary; to be put as GEM namelist - logical :: cat_init_new_loc ! 2D size distribution and fallspeed parameters: @@ -2415,9 +2416,6 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi tmp1 = uzpl(1,1) !avoids compiler warning for unused variable 'uzpl' - cat_init_new_loc = cat_init_new_default - if (present(cat_init_new)) cat_init_new_loc = cat_init_new - ! direction of vertical leveling: if (trim(model)=='GEM' .or. trim(model)=='KIN1D') then ktop = kts !k of top level @@ -2619,29 +2617,29 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !--- apply mass clipping if dry and mass is sufficiently small ! (implying all mass is expected to evaporate/sublimate in one time step) - - if (qc(i,k).lt.qsmall .or. (qc(i,k).lt.1.e-12 .and. sup(i,k).lt.-0.1)) then ! DTD changed to 1.e-12 from 1.e-8 + ! DTD: added nsmall checks to the following + if (qc(i,k).lt.qsmall .or. nc(i,k).lt.nsmall .or. (qc(i,k).lt.1.e-12 .and. sup(i,k).lt.-0.1)) then ! DTD changed to 1.e-12 from 1.e-8 qv(i,k) = qv(i,k) + qc(i,k) th(i,k) = th(i,k) - invexn(i,k)*qc(i,k)*xxlv(i,k)*inv_cp qc(i,k) = 0. nc(i,k) = 0. else - nc(i,k) = Max( nc(i,k), nsmall ) ! ERM + ! nc(i,k) = Max( nc(i,k), nsmall ) ! ERM log_hydrometeorsPresent = .true. ! updated further down endif - if (qr(i,k).lt.qsmall .or. (qr(i,k).lt.1.e-12 .and. sup(i,k).lt.-0.1)) then ! DTD changed to 1.e-12 from 1.e-8 + if (qr(i,k).lt.qsmall .or. nr(i,k).lt.nsmall .or. (qr(i,k).lt.1.e-12 .and. sup(i,k).lt.-0.1)) then ! DTD changed to 1.e-12 from 1.e-8 qv(i,k) = qv(i,k) + qr(i,k) th(i,k) = th(i,k) - invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp qr(i,k) = 0. nr(i,k) = 0. else - nr(i,k) = Max( nr(i,k), nsmall ) ! ERM + ! nr(i,k) = Max( nr(i,k), nsmall ) ! ERM log_hydrometeorsPresent = .true. ! updated further down endif do iice = 1,nCat - if (qitot(i,k,iice).lt.qsmall .or. (qitot(i,k,iice).lt.1.e-12 .and. & + if (qitot(i,k,iice).lt.qsmall .or. nitot(i,k,iice).lt.nsmall .or. (qitot(i,k,iice).lt.1.e-12 .and. & supi(i,k).lt.-0.1)) then ! Note that ERM removed second sup criterion for testing. May try later qv(i,k) = qv(i,k) + qitot(i,k,iice) th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp @@ -2652,7 +2650,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qiliq(i,k,iice) = 0. birim(i,k,iice) = 0. else - nitot(i,k,iice) = Max (nitot(i,k,iice), nsmall) ! ERM + ! nitot(i,k,iice) = Max (nitot(i,k,iice), nsmall) ! ERM log_hydrometeorsPresent = .true. ! final update endif @@ -2698,6 +2696,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo k_loop_1 !zero out zitot if there is no qitot for triple moment + ! DTD do we want to check for nitot < nsmall as well? if (log_3momentIce) where (qitot(i,:,:).lt.qsmall) zitot(i,:,:) = 0. if (debug_on) then @@ -2806,7 +2805,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! if (abs(epsilon).ge.1.e-15) then if (abs(epsilon).ge.qsmall) then ! ERM qc(i,k) = qc(i,k)+epsilon - nc(i,k) = Max(nc(i,k), nsmall) ! ERM + !nc(i,k) = Max(nc(i,k), nsmall) ! ERM qv(i,k) = qv(i,k)-epsilon th(i,k) = th(i,k)+epsilon*invexn(i,k)*xxlv(i,k)*inv_cp ! recalculate variables if there was adjustment @@ -2869,8 +2868,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) iice_loop1: do iice = 1,nCat + Eii_fact(iice) = 1.0 ! DTD: set default value of ice-ice collection efficiency factor to 1.0 to avoid potential stale value issue - qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > nsmall ) then ! ERM added nitot check + qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check ! DTD changed to .ge. from > to ensure case where nitot = nsmall is included !impose lower limits to prevent taking log of # < 0 if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM @@ -2927,7 +2927,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! ice-rain collection processes - if (qr(i,k).ge.qsmall) then + if (qr(i,k).ge.qsmall .and. nr(i,k).ge.nsmall) then ! DTD added nsmall check if (.not. log_LiquidFrac) then call access_lookup_table_coll(dumjj,dumii,dumj,dumi,1,dum1,dum3,dum4,dum5,f1pr07) call access_lookup_table_coll(dumjj,dumii,dumj,dumi,2,dum1,dum3,dum4,dum5,f1pr08) @@ -3016,7 +3016,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! print*,'from table',itab_3mom(dumzz+1,dumjj,dumii,dumll,dumi,22) ! ice-rain collection processes - if (qr(i,k).ge.qsmall) then + if (qr(i,k).ge.qsmall .and. nr(i,k).ge.nsmall) then ! DTD added nsmall check if (.not. log_LiquidFrac) then call access_lookup_table_coll_3mom(dumzz,dumjj,dumii,dumj,dumi,1,dum1,dum3,dum4,dum5,dum6,f1pr07) call access_lookup_table_coll_3mom(dumzz,dumjj,dumii,dumj,dumi,2,dum1,dum3,dum4,dum5,dum6,f1pr08) @@ -3064,6 +3064,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! Determine additional collection efficiency factor to be applied to ice-ice collection. ! The computed values of qicol and nicol are multipiled by Eii_fact to gradually shut off collection ! if the ice in iice is highly rimed. + tmp1 = 0. ! DTD initialize to avoid stale value issue if (qirim(i,k,iice)>0.) then if ((qitot(i,k,iice)-qiliq(i,k,iice))>0.) then tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) !rime mass fraction @@ -3103,7 +3104,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ex: rhofaci is grid-mean, f1pr04 is grid-mean, qc*iSCF is in-cloud, ! eci is a constant, rho(i,k) is grid-mean, nitot*iSCF is in-cloud ! (qc*iSCF*nitot*iSCF)*SCF = (qc*nitot)*iSCF to obtain grid-mean qccol - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > 0. .and. qc(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check, ERM added nitot check + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall .and. t(i,k).le.273.15) then ! diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check, ERM added nitot check ! DTD: changed to .ge. from > to ensure case where nitot = nsmall is included. Also added nc nsmall check qccol(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) @@ -3114,7 +3115,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15 .and. iice==2) then ! .and. diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check ! DTD: only allow qrcol for iice==2 (ice from Biggs freezing) ! if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! orig check - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > 0. .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! ERM added nitot check + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall .and. t(i,k).le.273.15) then ! ERM added nitot check ! DTD: changed to .ge. from > to ensure case where nitot = nsmall is included. Also added nr nsmall check IF ( qitot(i,k,iice)/nitot(i,k,iice) > qr(i,k)/nr(i,k) .or. qrcol_opt == 0 ) THEN ! ERM ice size check (Must be larger than rain in mean size) ! qrcol(iice)=f1pr08*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice) ! nrcol(iice)=f1pr07*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice) @@ -3126,7 +3127,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi zqrcol(iice) = 10.**(logn0r(i,k))*f1pr36*rho(i,k)*rhofaci(i,k)*eri*iSCF(k)*(SPF(k)-SPF_clr(k)) endif ! ERM begin - IF ( ncat == 2 .and. merge_opt == -1 .and. iice == 2 .and. qrcol_opt == 2. .and. .not. cat_init_new_loc) THEN ! DTD added additional cat_init_new check + IF ( ncat == 2 .and. merge_opt == -1 .and. iice == 2 .and. qrcol_opt == 2. .and. .not. cat_init_new) THEN ! DTD added additional cat_init_new check qrcol(iice) = 0.0 nrcol(iice) = 0.0 zqrcol(iice) = 0.0 ! DTD @@ -3142,7 +3143,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! for T > 273.15, assume cloud water is collected and shed as rain drops if (log_LiquidFrac) then ! assume cloud water is collected by qiliq - if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall .and. t(i,k).gt.273.15) then ! DTD added nc and nitot checks qccoll(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccoll(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) if(log_3momentIce) then @@ -3150,7 +3151,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif ! assume collected rain by qiliq - if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall .and. t(i,k).gt.273.15) then ! DTD added nr and nitot checks ! note: f1pr08 and logn0r are already calculated as log_10 qrcoll(iice) = 10.**(f1pr08+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) nrcoll(iice) = 10.**(f1pr07+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) @@ -3160,7 +3161,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif else ! assume cloud water is collected and shed as rain drops (original code) - if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall .and. t(i,k).gt.273.15) then ! DTD added nc and nitot checks ! sink for cloud water mass and number, note qcshed is source for rain mass qcshd(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) @@ -3171,7 +3172,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! assume collected rain number is shed as 1 mm drops (original code) ! collection of rain above freezing does not impact total rain mass - if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall .and. t(i,k).gt.273.15) then ! DTD added nr and nitot checks ! rain number sink due to collection nrcol(iice) = 10.**(f1pr07 + logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) ! rain number source due to shedding = collected rain mass/mass of 1 mm drop @@ -3187,7 +3188,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! collection between ice categories ! iceice_interaction1: if (.false.) then !for testing (to suppress ice-ice interaction) - iceice_interaction1: if (iice.ge.2) then + iceice_interaction1: if (iice.ge.2 .and. log_iceice_interaction) then !note: In this version, lookupTable_2 (LT2, for ice category interactions) is computed for a maximum ! mean ice size of Dm_max=2000.e-6 m (the old lambda_i limiter); thus it is compatible with @@ -3198,9 +3199,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! In a forthcoming version, both LT1-2momI and LT2 (and LT1-3momI) will all be computed ! using the unconstrained size limited (i.e. Dm_max=400000.e-6). - qitot_notsmall: if (qitot(i,k,iice).ge.qsmall) then + qitot_notsmall: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check catcoll_loop: do catcoll = 1,iice-1 - qitotcatcoll_notsmall: if (qitot(i,k,catcoll).ge.qsmall) then + qitotcatcoll_notsmall: if (qitot(i,k,catcoll).ge.qsmall .and. nitot(i,k,catcoll) .ge. nsmall) then ! DTD added nitot check ! first, calculate collection of catcoll category by iice category @@ -3286,7 +3287,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! in the lookup table calculations ! note 'f1pr' values are normalized, so we need to multiply by N - if (qitot(i,k,iice).ge.qsmall .and. log_nislf) then ! ERM added log_nislf + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. log_nislf) then ! ERM added log_nislf. DTD added nitot check nislf(iice) = f1pr03*rho(i,k)*eii*Eii_fact(iice)*rhofaci(i,k)*nitot(i,k,iice)*nitot(i,k,iice)*iSCF(k) if (log_3momentIce) then ! NOTE: already correct sign from lookup table, thus not multiplied by -1 @@ -3304,7 +3305,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (log_LiquidFrac) then ! some portion of the melted water stays into qiliq --> qimlt(iice) (D>Dth) ! the other portion melts into rain --> qrmlt(iice) (D<=Dth) - if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. t(i,k).gt.273.15) then + if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. t(i,k).gt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) dum = 0. qrmlt(iice) = ((f1pr24+f1pr25*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*((t(i,k)- & @@ -3330,7 +3331,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif else - if (qitot(i,k,iice).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. t(i,k).gt.273.15) then ! DTD added nitot check qsat0 = 0.622*e0/(pres(i,k)-e0) ! dum=cpw/xlf(i,k)*(t(i,k)-273.15)*(pracsw1+qcshd(iice)) ! currently enhanced melting from collision is neglected @@ -3358,7 +3359,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! similar to Musil (1970), JAS ! note 'f1pr' values are normalized, so we need to multiply by N - if (qitot(i,k,iice).ge.qsmall .and. (qc(i,k)+qr(i,k)).ge.1.e-6 .and. t(i,k).lt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. (qc(i,k)+qr(i,k)).ge.1.e-6 .and. t(i,k).lt.273.15) then ! DTD added nitot check qsat0 = 0.622*e0/(pres(i,k)-e0) qwgrth(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*((t(i,k)- & @@ -3412,7 +3413,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !Note (BUG) insert *iSCF(k) because epsi and epsiw needs to be in-cloud (to be done) !if (log_LiquidFrac) then - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check if ((qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then epsi(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* & rho(i,k)*dv)*nitot(i,k,iice) @@ -3458,7 +3459,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !............................................................ if (log_LiquidFrac) then - if (qiliq(i,k,iice).ge.qsmall .and. qitot(i,k,iice).ge.qsmall) then + if (qiliq(i,k,iice).ge.qsmall .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check ! Refreezing if (t(i,k).lt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) @@ -3503,7 +3504,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iTc = 1./min(-0.001,t(i,k)-273.15) ! cloud: - if (qc(i,k).ge.qsmall) then + if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall) then ! DTD added nc check ! droplet fall speed ! (use Stokes' formulation (thus use analytic solution) Vt_qc(i,k) = acn(i,k)*gamma(4.+bcn+mu_c(i,k))/(lamc(i,k)**bcn*gamma(mu_c(i,k)+4.)) @@ -3546,6 +3547,22 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop1 !-------------------- + if (debug_on) then + location_ind = 250 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + !............................................................ ! contact and immersion freezing droplets @@ -3557,7 +3574,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! (6.*pi*rin*mu) ! nacnt=exp(-2.80+0.262*(273.15-t(i,k)))*1000. - if (qc(i,k).ge.qsmall .and. t(i,k).le.269.15) then + if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall .and. t(i,k).le.269.15) then ! DTD added nc check ! qchetc(iice) = pi*pi/3.*Dap*Nacnt*rhow*cdist1(i,k)*gamma(mu_c(i,k)+5.)/lamc(i,k)**4 ! nchetc(iice) = 2.*pi*Dap*Nacnt*cdist1(i,k)*gamma(mu_c(i,k)+2.)/lamc(i,k) ! for future: calculate gamma(mu_c+4) in one place since its used multiple times @@ -3578,7 +3595,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (nCat>1) then !determine destination ice-phase category: - if (.not. cat_init_new_loc) then + if (.not. cat_init_new) then dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd ! ERM begin @@ -3612,7 +3629,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! Note (BUG): is *iSPF(k) necessary here - if (qr(i,k)*iSPF(k).ge.qsmall.and.t(i,k).le.269.15) then + if (qr(i,k)*iSPF(k).ge.qsmall .and. nr(i,k)*iSPF(k) .ge. nsmall .and. t(i,k).le.269.15) then ! DTD added nr check ! Q_nuc = cons6*exp(log(cdistr(i,k))+log(gamma(7.+mu_r(i,k)))-6.*log(lamr(i,k)))*exp(aimm*(273.15-t(i,k)))*SPF(k) ! N_nuc = cons5*exp(log(cdistr(i,k))+log(gamma(mu_r(i,k)+4.))-3.*log(lamr(i,k)))*exp(aimm*(273.15-t(i,k)))*SPF(k) @@ -3624,7 +3641,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (nCat>1) then !determine destination ice-phase category: - if (.not. cat_init_new_loc) then + if (.not. cat_init_new) then dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd ! ERM begin @@ -3667,7 +3684,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (nCat>1) then !determine destination ice-phase category - if (.not. cat_init_new_loc) then + if (.not. cat_init_new) then D_new = 10.e-6 !assumes ice crystals from rime splintering are tiny ! ERM begin IF ( merge_opt == -1 .and. nCat == 2 ) THEN @@ -3692,7 +3709,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_loop_HM: do iice = 1,nCat - ice_present: if (qitot(i,k,iice)-qiliq(i,k,iice) .ge. qsmall) then + ice_present: if (qitot(i,k,iice)-qiliq(i,k,iice) .ge. qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) ! rime fraction tmp2 = qiliq(i,k,iice)/qitot(i,k,iice) ! liquid fraction @@ -3757,7 +3774,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! Note (BUG): is *iSPF(k) necessary here (epsr is in-precip anyway) !calculate rain evaporation including ventilation - if (qr(i,k)*iSPF(k).ge.qsmall) then + if (qr(i,k)*iSPF(k).ge.qsmall .and. nr(i,k)*iSPF(k) .ge. nsmall) then ! DTD added nr check call find_lookupTable_indices_3(dumii,dumjj,dum1,rdumii,rdumjj,inv_dum3,mu_r(i,k),lamr(i,k)) !interpolate value at mu_r dum1 = revap_table(dumii,dumjj)+(rdumii-real(dumii))* & @@ -3774,7 +3791,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi epsr = 0. endif - if (qc(i,k).ge.qsmall) then + if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall) then ! DTD added nc check epsc = 2.*pi*rho(i,k)*dv*cdist(i,k) else epsc = 0. @@ -3857,12 +3874,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !Note (BUG) the following three bug fixed change the solution with scpf_on=.false. - if (qc(i,k).ge.qsmall) & + if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall) & ! DTD added nc check !Note (BUG): Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon ! qccon = ((aaa*epsc*oxx+(ssat_cld-aaa*oxx)*odt*epsc*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab)*SCF(k) ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qc qccon = (aaa*epsc*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsc*oxx*(1.d0-dexp(-dble(xx*dt))))/ab - if (qr(i,k).ge.qsmall) & + if (qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall) & ! DTD added nr check !Note (BUG): Cholette (Jul 2022), remove *SPF(k) for ssat_r and multiplication *SPF for grid-mean qccon ! qrcon = ((aaa*epsr*oxx+(ssat_r-aaa*oxx)*odt*epsr*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab)*SPF(k) ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qr @@ -3888,11 +3905,27 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qrcon = min(qrcon, qv(i,k)*odt) endif + if (debug_on) then + location_ind = 260 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + iice_loop_depsub: do iice = 1,nCat ! if (log_LiquidFrac) then - if (qitot(i,k,iice).ge.qsmall ) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check if ( (qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then ! ERM split off second part into separate if ! Sublimation/deposition of ice !note: diffusional growth/decay rate: (stored as 'qidep' temporarily; may go to qisub below) @@ -3905,7 +3938,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! ERM inner if/else endif - !for very small ice contents in dry air, sublimate all ice instantly + !for very small ice contents in dry air, sublimate all ice instantly. DTD: check if we need an nitot check here if (supi_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall ) then ! ERM split off second part into separate if if (qiliq(i,k,iice)/qitot(i,k,iice).lt.0.01) then qidep(iice) = -(qitot(i,k,iice)-qiliq(i,k,iice))*odt @@ -3939,7 +3972,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif - if (qitot(i,k,iice).ge.qsmall ) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check if ((qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then ! ERM split off second part into separate if ! Condensation/evaporation fo qiliq !Note (BUG) Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon @@ -3950,7 +3983,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi (1.d0-dexp(-dble(xx*dt))))/ab endif ! ERM inner if/else endif - + ! DTD: check if we need an nitot check here if (sup_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall ) then ! ERM split off second part into separate if if ( (qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) qlcon(iice) = -qiliq(i,k,iice)*odt endif @@ -4020,6 +4053,23 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop_depsub + if (debug_on) then + location_ind = 270 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + + 444 continue @@ -4052,7 +4102,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi Q_nuc = max(0.,(dum-sum(nitot(i,k,:)))*mi0*odt) if (nCat>1) then !determine destination ice-phase category: - if (.not. cat_init_new_loc) then + if (.not. cat_init_new) then dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd ! ERM begin @@ -4080,6 +4130,21 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif + if (debug_on) then + location_ind = 280 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif !................................................................. ! droplet activation @@ -4114,7 +4179,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum2 = nanew2*0.5*(1.-derf(uu2)) ! activated number in kg-1 mode 2 ! make sure this value is not greater than total number of aerosol dum2 = min((nanew1+nanew2),dum1+dum2) - dum2 = (dum2-cn(i,k)*iSCF(k))*odt*SCF(k) ! ERM changed from nc to cn + if (ccn_on > 0) then + dum2 = (dum2-cn(i,k)*iSCF(k))*odt*SCF(k) ! ERM changed from nc to cn + else + dum2 = (dum2-nc(i,k)*iSCF(k))*odt*SCF(k) + endif dum2 = max(0.,dum2) ncnuc = dum2 ! don't include mass increase from droplet activation during first time step @@ -4144,6 +4213,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (qccon.le.1.e-7) qccon = 0. endif + if(isnan(qcaut)) then + print*,'qcaut is NaN before autoconversion i=',i,' k=',k + print*,'iparam=',iparam,' qc=',qc(i,k),' nc=',nc(i,k) + ! stop + endif + !................................................................ ! autoconversion @@ -4168,17 +4243,28 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! ERM end !Note (BUG), needs to be in-cloud condition - qc_not_small_1: if (qc(i,k)*iSCF(k).ge.1.e-8) then + qc_not_small_1: if (qc(i,k)*iSCF(k).ge.qsmall .and. nc(i,k)*iSCF(k).ge.nsmall) then ! DTD changed to use qsmall and added nc check if (iparam.eq.1) then !Seifert and Beheng (2001) dum = 1.-qc(i,k)*iSCF(k)/(qc(i,k)*iSCF(k)+qr(i,k)*iSPF(k)*(SPF(k)-SPF_clr(k))) dum1 = 600.*dum**0.68*(1.-dum**0.68)**3 - qcaut = kc*1.9230769e-5*(nu(i,k)+2.)*(nu(i,k)+4.)/(nu(i,k)+1.)**2* & + if(dum .lt. 1.) then + qcaut = kc*1.9230769e-5*(nu(i,k)+2.)*(nu(i,k)+4.)/(nu(i,k)+1.)**2* & (rho(i,k)*qc(i,k)*iSCF(k)*1.e-3)**4/ & (rho(i,k)*nc(i,k)*iSCF(k)*1.e-6)**2*(1.+ & dum1/(1.-dum)**2)*1000.*inv_rho(i,k)*SCF(k) + else + qcaut = 0.0 + endif + if(isnan(qcaut)) then + print*,'Error: NaN detected in autoconversion calculation at i=',i,' k=',k + print*,'iSCF=',iSCF(k),'qc=',qc(i,k),' nc=',nc(i,k),' rho=',rho(i,k),'SCF=',SCF(k) + print*,'qr=',qr(i,k),' SPF=',SPF(k),' SPF_clr=',SPF_clr(k),' nu=',nu(i,k) + print*,'dum=',dum,' dum1=',dum1,' kc=',kc,' inv_rho=',inv_rho(i,k) + stop + endif ncautc = qcaut*7.6923076e+9 elseif (iparam.eq.2) then @@ -4206,6 +4292,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !Khroutdinov and Kogan (2000) dum = qc(i,k)*iSCF(k) qcaut = 1350.*dum**2.47*(nc(i,k)*iSCF(k)*1.e-6*rho(i,k))**(-1.79)*SCF(k) + if(isnan(qcaut)) then + print*,'Error: NaN detected in autoconversion calculation at i=',i,' k=',k + print*,'iSCF=',iSCF(k),'qc=',qc(i,k),' nc=',nc(i,k),' rho=',rho(i,k),'SCF=',SCF(k) + stop + endif ! note: ncautr is change in Nr; ncautc is change in Nc ncautr = qcaut*cons3 ncautc = qcaut*nc(i,k)/qc(i,k) @@ -4302,10 +4393,16 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif qc_not_small_1 + if(isnan(qcaut)) then + print*,'qcaut is NaN after autoconversion i=',i,' k=',k + print*,'iparam=',iparam,' qc=',qc(i,k),' nc=',nc(i,k) + ! stop + endif + !............................ ! self-collection of droplets - if (qc(i,k).ge.qsmall) then + if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall) then ! DTD added nsmall check if (iparam.eq.1) then !Seifert and Beheng (2001) @@ -4326,7 +4423,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !............................ ! accretion of cloud by rain - if (qr(i,k).ge.qsmall .and. qc(i,k).ge.qsmall) then + if (qr(i,k).ge.qsmall .and. qc(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall .and. nc(i,k) .ge. nsmall) then ! DTD added nsmall check if (iparam.eq.1) then !Seifert and Beheng (2001) @@ -4367,7 +4464,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! self-collection and breakup of rain ! (breakup following modified Verlinde and Cotton scheme) - if (qr(i,k).ge.qsmall .and. nr(i,k) > nsmall ) then ! ERM added nsmall check + if (qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall ) then ! ERM added nsmall check ! DTD changed from > to .ge. ! include breakup dum1 = 500.e-6 ! DTD changed from 280.e-6 @@ -4418,6 +4515,23 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif + if (debug_on) then + location_ind = 290 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + + !................................................................. ! conservation of mass @@ -4476,9 +4590,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qinuc = qinuc*ratio ninuc = ninuc*ratio endif + tmp2 = sum(qisub) ! DTD sum up qisub *before* changing individual category qisub values below do iice = 1,nCat dum = max(qisub(iice),1.e-20) - qisub(iice) = qisub(iice)*min(1.,max(0.,-qdep_satadj)/max(sum(qisub), 1.e-20)) !optimized (avoids IF(qisub.gt.0.) ) + ! DTD: replaced sum(qisub) with tmp2 to avoid repeated summation (and potential order-dependent results) + qisub(iice) = qisub(iice)*min(1.,max(0.,-qdep_satadj)/max(tmp2, 1.e-20)) !optimized (avoids IF(qisub.gt.0.) ) nisub(iice) = nisub(iice)*min(1.,qisub(iice)/dum) enddo !qchetc = qchetc*min(1.,qc(i,k)*odt/max(sum(qchetc),1.e-20)) !currently not used @@ -4613,6 +4729,22 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !======================================================================================! + if (debug_on) then + location_ind = 291 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + !--------------------------------------------------------------------------------- ! update prognostic microphysics and thermodynamics variables @@ -4635,7 +4767,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi mu_i_s(iice)=mu_i_initial - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nsmall check dumqi=qitot(i,k,iice) dumni=nitot(i,k,iice) dumden=f1pr16 @@ -4654,6 +4786,23 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop2 + if (debug_on) then + location_ind = 292 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + + iice_loop3: do iice = 1,nCat qc(i,k) = qc(i,k) + (-qchetc(iice)-qcheti(iice)-qccol(iice)-qcshd(iice)-qcmul(iice)- & !DTD: added qcmul @@ -4703,7 +4852,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi nislf(iice)+nrhetc(iice)+nrheti(iice)+nchetc(iice)+ & ncheti(iice)+nimul(iice)-nlevp(iice))*dt - if (nCat.gt.1) then + if (nCat.gt.1 .and. log_iceice_interaction) then interactions_loop: do catcoll = 1,nCat diff_categories: if (iice.ne.catcoll) then ! add ice-ice category interaction collection tendencies @@ -4771,7 +4920,34 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop3 !== + if (debug_on) then + location_ind = 293 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + + !-- warm-phase only processes: + ! Check if any of the tendencies are NaN + if (any([isnan(qcevp), isnan(qcacc), isnan(qcaut), isnan(qcnuc), isnan(qccon)])) then + print*,'NaN tendency detected in warm-phase processes at i=', i, ' k=', k + print*,'qcacc=', qcacc, ' qcaut=', qcaut, ' qcnuc=', qcnuc, ' qccon=', qccon, ' qcevp=', qcevp + endif + ! Now for rain processes + if (any([isnan(qcacc), isnan(qcaut), isnan(qrcon), isnan(qrevp)])) then + print*,'NaN tendency detected in rain processes at i=', i, ' k=', k + print*,'qcacc=', qcacc, ' qcaut=', qcaut, ' qrcon=', qrcon, ' qrevp=', qrevp + endif qc(i,k) = qc(i,k) + (-qcacc-qcaut+qcnuc+qccon-qcevp)*dt qr(i,k) = qr(i,k) + (qcacc+qcaut+qrcon-qrevp)*dt @@ -4795,7 +4971,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! clipping for Filiq > 0.99 (transfer unmelted ice to rain) if (log_LiquidFrac) then do iice = 1,nCat - if (qitot(i,k,iice).ge.qsmall ) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nsmall check if ((qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then ! ERM split conditional to avoid div by zero qr(i,k) = qr(i,k) + qitot(i,k,iice) nr(i,k) = nr(i,k) + nitot(i,k,iice) @@ -4811,7 +4987,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! clipping for small hydrometeor values - if (qc(i,k).lt.qsmall) then + if (qc(i,k).lt.qsmall .or. nc(i,k) .lt. nsmall) then ! DTD added nsmall check qv(i,k) = qv(i,k) + qc(i,k) th(i,k) = th(i,k) - invexn(i,k)*qc(i,k)*xxlv(i,k)*inv_cp qc(i,k) = 0. @@ -4820,7 +4996,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi log_hydrometeorsPresent = .true. endif - if (qr(i,k).lt.qsmall) then + if (qr(i,k).lt.qsmall .or. nr(i,k) .lt. nsmall) then ! DTD added nsmall check qv(i,k) = qv(i,k) + qr(i,k) th(i,k) = th(i,k) - invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp qr(i,k) = 0. @@ -4830,7 +5006,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif do iice = 1,nCat - if (qitot(i,k,iice).lt.qsmall) then + if (qitot(i,k,iice).lt.qsmall .or. nitot(i,k,iice) .lt. nsmall) then ! DTD added nsmall check qv(i,k) = qv(i,k) + qitot(i,k,iice) th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp @@ -4850,6 +5026,23 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !--------------------------------------------------------------------------------- + if (debug_on) then + location_ind = 294 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + + if (log_3momentIce) then do iice = 1,nCat @@ -4970,9 +5163,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !---- Group 2 (initiation processes, where mu_i for the new ice resulting from that process (only) is assigned ! note: mu_i_new is the mu_i associated with the new added ice for that process + ! DTD: changed qsmall checks to nsmall checks below, since these are number-based processes !proceses with rain freezing: tmp2 = nrhetc(iice) + nrheti(iice) !moment_0 tendency - if (tmp2.ge.qsmall) then + if (tmp2.ge.nsmall) then tmp1 = (qrhetc(iice) + qrheti(iice))*6./(900.*pi) !estimate of moment_3 tendency mu_i_new = mu_r(i,k) zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt @@ -4980,7 +5174,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !proceses with cloud freezing: tmp2 = nchetc(iice) + ncheti(iice) !moment_0 tendency - if (tmp2.ge.qsmall) then + if (tmp2.ge.nsmall) then tmp1 = (qchetc(iice) + qcheti(iice))*6./(900.*pi) !estimate of moment_3 tendency mu_i_new = mu_c(i,k) zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt @@ -4988,7 +5182,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !proceses of deposition nucleation tmp2 = ninuc(iice) !moment_0 tendency - if (tmp2.ge.qsmall) then + if (tmp2.ge.nsmall) then tmp1 = qinuc(iice)*6./(900.*pi) !estimate of moment_3 tendency mu_i_new = mu_i_initial !estimated assigned value zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt @@ -4996,7 +5190,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !proceses of ice multiplication tmp2 = nimul(iice) !moment_0 tendency - if (tmp2.ge.qsmall) then + if (tmp2.ge.nsmall) then tmp1 = (qcmul(iice)+qrmul(iice))*6./(900.*pi) !estimate of moment_3 tendency ! DTD: added qcmul mu_i_new = mu_i_initial !estimated assigned value zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt @@ -5032,7 +5226,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !== !...................................... -! zero out zitot if there is no qitot for triple moment +! zero out zitot if there is no qitot for triple moment. DTD: check if we need to check nitot as well if (log_3momentIce) then do iice = 1,nCat do k = kbot,ktop,kdir @@ -5117,7 +5311,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_c2: do k = k_qxtop,k_qxbot,-kdir - if (qc(i,k)*iSCF(k).ge.qsmall .and. nc(i,k) > nsmall) then ! ERM added nc check + if (qc(i,k)*iSCF(k).ge.qsmall .and. nc(i,k)*iSCF(k) .ge. nsmall) then ! ERM added nc check DTD changed from > to .ge. call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu, & lamc(i,k),lammin,lammax,tmp1,tmp2,iSCF(k)) dum = 1./lamc(i,k)**bcn @@ -5262,7 +5456,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_r1: do k = k_qxtop,k_qxbot,-kdir - qr_not_small_1: if (qr(i,k)*iSPF(k).ge.qsmall .and. nr(i,k) > nsmall ) then ! ERM added nr check + qr_not_small_1: if (qr(i,k)*iSPF(k).ge.qsmall .and. nr(i,k)*iSPF(k) .ge. nsmall ) then ! ERM added nr check ! DTD changed from > to .ge. !Compute Vq, Vn: if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny instead of nsmall @@ -5390,7 +5584,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i1: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > nsmall ) then ! ERM added nitot check + qi_notsmall_i1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check DTD changed to .ge. from > to ensure that nitot = nsmall is included !--Compute Vq, Vn: if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ERM added log_maxnsmall and ntiny @@ -5484,7 +5678,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i2: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i2: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > nsmall ) then ! ERM added nitot check + qi_notsmall_i2: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check DTD changed to .ge. from > to ensure that nitot = nsmall is included !--Compute Vq, Vn: if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ERM added log_maxnsmall and ntiny @@ -5737,7 +5931,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i4: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i4: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > nsmall ) then ! ERM added nitot check + qi_notsmall_i4: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check DTD changed to .ge. from > to ensure that nitot = nsmall is included !--Compute Vq, Vn: if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ! ERM added log_maxnsmall and ntiny @@ -5931,7 +6125,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! compute mean-mass ice diameters diam_ice(i,k,:) = 0. do iice = 1,nCat - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nsmall check if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7,isize, & @@ -5965,7 +6159,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif multicat1 - qc_not_small_2: if (qc(i,k).ge.qsmall .and. t(i,k).lt.233.15) then + qc_not_small_2: if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall .and. t(i,k).lt.233.15) then ! DTD added nc check Q_nuc = qc(i,k) if ( log_maxnsmall ) nc(i,k) = max(nc(i,k),ntiny) ! ERM added log_maxnsmall and ntiny @@ -5973,7 +6167,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (nCat>1) then !determine destination ice-phase category: - if (.not. cat_init_new_loc) then + if (.not. cat_init_new) then dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd ! ERM begin @@ -6019,14 +6213,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif qc_not_small_2 - qr_not_small_2: if (qr(i,k).ge.qsmall .and. t(i,k).lt.233.15) then + qr_not_small_2: if (qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall .and. t(i,k).lt.233.15) then ! DTD added nsmall check Q_nuc = qr(i,k) if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny N_nuc = nr(i,k) if (nCat>1) then !determine destination ice-phase category: - if (.not. cat_init_new_loc) then + if (.not. cat_init_new) then dum1 = 900. !density of new ice D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd ! ERM begin @@ -6071,14 +6265,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !.............................................. ! Merge ice categories with similar properties (based on specified similarly condition) - if (.not. cat_init_new_loc) then ! DTD turn off category merging for the new category initialization option for now + if (.not. cat_init_new) then ! DTD turn off category merging for the new category initialization option for now multicat: if (nCat.gt.1 .and. merge_opt >= 1) then ! ERM added merge_opt check ! multicat: if (.FALSE.) then ! **** TEST !step 1: adjustments and calculation of mean diameters k_loop_check_before_merge: do k = kbot,ktop,kdir iice_loop_check_before_merge: do iice = 1,nCat - qi_not_small_merge: if (qitot(i,k,iice).ge.qsmall) then + qi_not_small_merge: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nsmall check if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) @@ -6223,7 +6417,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi k_loop_final_diagnostics: do k = kbot,ktop,kdir ! cloud: - if (qc(i,k)*iSCF(k).ge.qsmall) then + if (qc(i,k)*iSCF(k).ge.qsmall .and. nc(i,k) .ge. nsmall) then ! DTD added nsmall check call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu,lamc(i,k), & lammin,lammax,tmp1,tmp2, iSCF(k)) diag_effc(i,k) = 0.5*(mu_c(i,k)+3.)/lamc(i,k) @@ -6235,7 +6429,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! rain: - if (qr(i,k).ge.qsmall) then + if (qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall) then ! DTD added nsmall check call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),tmp1,tmp2,1.) @@ -11666,7 +11860,8 @@ subroutine find_lookupTable_indices_1b(dumj,dum3,rcollsize,qr,nr) ! find index for scaled mean rain size ! if no rain, then just choose dumj = 1 and do not calculate rain-ice collection processes - if (qr.ge.qsmall .and. nr.gt.0.) then + ! DTD: should we change to nsmall instead of 0? + if (qr.ge.qsmall .and. nr.gt.nsmall) then ! DTD changed from 0 to nsmall ! calculate scaled mean size for consistency with ice lookup table dumlr = (qr/(pi*rhow*nr))**thrd dum3 = (alog10(1.*dumlr)+5.)*10.70415 @@ -12011,7 +12206,7 @@ subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) qr = qr_grd*iSPF !in-cloud value - if (qr.ge.qsmall) then + if (qr.ge.qsmall .and. nr_grd*iSPF >= nsmall) then ! DTD added nr check nr = nr_grd*iSPF !in-cloud value diff --git a/src/param.F b/src/param.F index 62ed49d..63151e6 100644 --- a/src/param.F +++ b/src/param.F @@ -161,6 +161,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & integer :: rssflg = 1 ! P3: Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value integer :: sssflg = 1 ! P3: As for rain but for ice (all ice) logical :: p3_cat_init_new = .true. ! switch for mechanism-based ice category initialization + logical :: log_nislf = .true. ! switch to allow ice self-aggregation + logical :: log_iceice_interaction = .true. ! switch to allow ice categories to interact integer :: p3_catdest_contact_n2 = 1 integer :: p3_catdest_contact_n3 = 3 integer :: p3_catdest_contact_n4 = 4 @@ -222,6 +224,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & rssflg, & sssflg, & p3_cat_init_new,& + log_nislf, & + log_iceice_interaction, & p3_catdest_contact_n2, & p3_catdest_contact_n3, & p3_catdest_contact_n4, & @@ -837,6 +841,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(rssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(sssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_cat_init_new,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(log_nislf,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(log_iceice_interaction,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_catdest_contact_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_catdest_contact_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_catdest_contact_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) @@ -4154,6 +4160,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & @@ -4176,6 +4184,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & @@ -4198,6 +4208,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & @@ -4220,6 +4232,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & @@ -4242,6 +4256,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & @@ -4264,6 +4280,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & @@ -4286,6 +4304,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & @@ -4308,6 +4328,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & @@ -4330,6 +4352,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & @@ -4352,6 +4376,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & @@ -4374,6 +4400,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & From cbe54f8c1e0221655521b9b7407d272380f5f91a Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Sun, 19 Jul 2026 19:10:31 -0400 Subject: [PATCH 04/25] Add category-swap divergence diagnostics; document investigation outcome Instrumentation (debug; can be stripped before merging to main code): - p3_chksum: PRE/POST bitwise field checksums per (itimestep, j-slab) to per-rank p3_chksum_NNNN.out (bitsum/bitsum2 + chksum_write in module_mp_p3.F). Covers qv,th,qc,nc,qr,qnr,w,p + all per-category ice fields. Labels use true model j via j_index (now passed at all P3 call sites in mp_driver.F). - p3_chkpts: per-point raw 32-bit patterns with local AND full-grid (i,j,k) to p3_chkpts_NNNN.out, for exact divergent-point isolation (LARGE output; restart-bracketing runs only). Global offsets myi1/myj1 via param.F. - compare_p3_chksum.py: compares two runs' files (both formats auto-detected) under an ice-category permutation (--swap/--map); single rank or whole simulation with earliest-divergence summary. Feature (candidate keeper): - qsum_invariant namelist option: permutation-invariant (sorted) sums of moist scalars in the prognostic dynamics path (solve1, solve2, turb; sortsumq in input.F), for bit-identity testing under category relabeling. Outcome (NOTES.md "RESOLVED"): swap divergence originates inside p3_main via order-of-operations roundoff (audit sec. 3), seeding at the first timestep the swapped slots' contents overlap anywhere -- advection undershoot halos suffice. Host dynamics exonerated; no sec. 2-class bug implicated. Co-Authored-By: Claude Fable 5 --- NOTES.md | 171 ++++++++++++++++++++++++- compare_p3_chksum.py | 296 +++++++++++++++++++++++++++++++++++++++++++ run/namelist.input | 3 + src/input.F | 49 +++++++ src/module_mp_p3.F | 192 ++++++++++++++++++++++++++++ src/mp_driver.F | 9 ++ src/param.F | 19 ++- src/solve1.F | 32 +++++ src/solve2.F | 28 ++++ src/turb.F | 26 ++++ 10 files changed, 817 insertions(+), 8 deletions(-) create mode 100755 compare_p3_chksum.py diff --git a/NOTES.md b/NOTES.md index 9c6fb4f..099367e 100644 --- a/NOTES.md +++ b/NOTES.md @@ -15,6 +15,57 @@ destination category numbers for rime splintering vs. deposition nucleation (3/4 vs. 4/3) should theoretically leave results unchanged, but simulations are identical for several minutes and then diverge. +## RESOLVED — Investigation outcome (2026-07-19) + +The swap-divergence mechanism was isolated with the Phase-1 checksum and +Phase-2 per-point instrumentation (below), using a restart-bracketed swap +pair (IOP12 case, ptype=57: nCat=4, 3-mom; this pair swapped the +homocloud/rimesplinter destinations 3<->4, dirname `..._rs4_dn1_chf3_...`; +ice-ice interaction and merging off; `qsum_invariant=.false.`; restart at +1300 s, dtl=7.5 s). + +**Findings:** + +1. **The seed is inside `p3_main`.** First divergence: itimestep=175 + (1312.5 s), a POST record at global (i,j,k)=(47,19,32) on rank 0003, + flipping all components of ice categories 2 and 3. Every PRE record at + t=175 matched bit-for-bit (earliest PRE divergence is t=176), and the + `w`/`p` checksums never diverged — so both runs handed `p3_main` + bit-identical inputs and got different outputs. Host dynamics exonerated + as the seed (even with `qsum_invariant` off). +2. **The seed point held no physical ice.** Decoding the PRE point-dump at + (47,19,32): all four categories sub-threshold, mostly *negative* + (advection undershoot halo; with `advwenos=2` WENO is applied only on the + final RK stage — `adv.F` line 77 — and WENO is not positive-definite; + undershoots ~1e-5 relative, e.g. nc = -1.2e4 against ~1e9). Both slots 3 + AND 4 were nonzero (-1.7e-12 / -3.8e-9). The first order-sensitive + operation such values meet is the **entry clipping pass** (sequential + per-category qv/th compensation, a §3 site) — the most plausible specific + seed site. +3. **Divergence began at the first timestep the swapped slots' contents + overlapped anywhere.** Coexistence scan (first PRE record with both + qitot_3 and qitot_4 nonzero): t=175, global (46,19,24) — same timestep as + the first divergence; no coexistence earlier in the bracket window. The + scan reports the lowest-k match; the seed point itself was also + coexistent (item 2), and not every coexistence point flips a bit + (reversing a+b changes the rounding only ~half the time), which is why + the first flip sits inside, not at the scan-order corner of, the + coexistence patch. + +**Conclusion:** the category-swap divergence is fully explained by the +report's §3 in-scheme order-of-operations roundoff, triggered at the first +overlap of swapped-slot contents. "Coexistence" requires only nonzero slot +contents — advection undershoot halos qualify — so seeding occurs where the +two species' halos merely overlap, well before (and more extensively than) +physical ice coexistence. No evidence of any residual §2-class bug, and no +host-side seeding was observed. The remaining choice is scientific, not +diagnostic: (a) accept last-bit sensitivity under relabeling and treat swap +pairs as ensemble members, or (b) pursue bit-identity via the +permutation-invariance program — invariant reductions inside `p3_main` +(entry clipping pass, `epsi_tot`, conservation-limiter sums, `iice_loop3`; +see "Permutation-invariance options" below) plus `qsum_invariant=.true.` +host-side. + ## Audit conclusions (see report for full detail and line numbers) Two distinct causes were identified: @@ -121,8 +172,68 @@ irrelevant when both runs use the same binary. ## Diagnostic workflow: checksums + bisection -**Phase 1 — find first divergent timestep.** Bitwise, position-weighted XOR -hash per field per timestep, printed from the wrapper after `p3_main`: +**Phase 1 — find first divergent timestep.** — **IMPLEMENTED (Claude Code +session, 2026-07-19):** + +- `bitsum` / `bitsum2` (rank-2 wrapper) added to `module_mp_p3.F` just after + `mp_p3_wrapper_wrf`. +- Checksum writer (internal subroutine `chksum_write` of `mp_p3_wrapper_wrf`) + called **twice per (itimestep, j)**: a `PRE ` line immediately before + `p3_main` (state entering microphysics) and a `POST` line after it. Each + line: `itimestep, j, tag`, then hex (Z16.16) checksums of + `qv, th, qc, nc_loc, qr, qnr, w, p`, then per ice category + `qitot, qirim, nitot, birim` (+ `zitot` if 3-moment, + `qiliq` if liqFrac), + hashed over the `(its:ite,kts:kte)` tile. Flushed once per timestep. +- **j-labeling fix + w/p fields (2026-07-19, second pass):** CM1 calls this + wrapper once per model j-slab with 2D slabs (`jts=jte=1`), so the wrapper's + internal loop `j` is always 1 — the first version labeled every line + `j=1` (symptom: multiple identical `(itimestep, 1, tag)` records per + timestep). Fixed: lines now use the true model j from the optional + `j_index` argument (DTD's debug arg), which is now passed at **all** P3 + call sites in `mp_driver.F` (previously only ptype 57/63). Same fix + applied to the per-point dump's local/global j columns. In the same + format change, `w` and `p` (inputs to `p3_main`, untouched by it) were + added after `qnr` in both file formats: a divergence in `w`/`p` — even on + a POST line — is host-seeded (buoyancy/pressure path), invisible to the + moisture/theta hashes. Checksum files written by the earlier code are NOT + comparable with the updated script (it aborts on the category-column + count); rerun after rebuilding. +- PRE/POST interpretation when diffing two runs: first divergence appearing on + a `PRE` line → the seed entered between the previous `POST` and this call, + i.e. on the host side (dynamics/advection — with `qsum_invariant=.true.` in + both runs this would implicate a host-side sum the audit missed); `PRE` + still matching while the same step's `POST` diverges → the seed is inside + `p3_main` (the §2/§3 mechanisms). Without `qsum_invariant`, a PRE-first + divergence may just be the buoyancy loading sum flipping a bit first and + does not by itself clear the microphysics (report §4 caveat). +- Output goes to per-rank file `p3_chksum_NNNN.out` (NNNN = MPI rank), + **replaced at the start of each run** (incl. restarts — move files aside + before a restart-based Phase-2 bracket run). +- Runtime switch: new namelist option `p3_chksum = .true.` in `&p3_params` + (default `.false.`; declared/broadcast in `param.F`, which sets the public + module switches `log_chksum` and `chksum_myid` after `p3_init`). +- Usage: run A and B with `p3_chksum=.true.`, then compare with + `compare_p3_chksum.py` (repo root), which applies the category mapping to + run B before comparing and names the first divergent + timestep/j-slab/tag/field. Two files compare a single rank; two run + directories compare every rank pair and add a simulation-wide summary + (earliest divergence across ranks, ordered by itimestep / j / PRE-before- + POST, plus per-tag earliest and totals): + + ``` + ./compare_p3_chksum.py runA/p3_chksum_0000.out runB/p3_chksum_0000.out --swap 3 4 + ./compare_p3_chksum.py runA runB --swap 3 4 # all ranks + summary + ``` + + (`--map 1,2,4,3` for arbitrary permutations, `--ncat` if not 4, `--all` to + list every divergent line; exit 0 = bit-identical under the mapping. + Verified against synthetic files: pure swap → identical under mapping; a + single poisoned value → localized to the exact timestep/j/tag/field.) + A plain `diff` also works for the no-swap validation runs (identity + mapping). + +Original design sketch (bitwise, position-weighted XOR hash per field per +timestep, printed from the wrapper after `p3_main`): ```fortran function bitsum(arr) result(cs) @@ -147,11 +258,30 @@ Caveats: run B for the swapped species); otherwise trivially "divergent." - Same processor count/decomposition both runs; compare rank-to-rank. -**Phase 2 — find first divergent (i,k,j) and field.** Restart both runs just -before the divergent step (CM1 `rstfrq` restarts are bit-reproducible for -identical config/decomposition). Dump raw state **before and after** the -`p3_main` call for the two bracketing timesteps (unformatted stream write). -Compare in Python bitwise: +**Phase 2 — find first divergent (i,k,j) and field.** — **IMPLEMENTED +(Claude Code session, 2026-07-19)** as a per-point dump in the wrapper +(replaces the raw-binary-dump plan below): + +- New namelist option `p3_chkpts = .true.` in `&p3_params` (default + `.false.`), independent of `p3_chksum`. Internal subroutine `chkpts_write` + of `mp_p3_wrapper_wrf` writes, PRE and POST every `p3_main` call, one line + per tile point to per-rank file `p3_chkpts_NNNN.out`: + `itimestep, tag, i j k (local), i j k (full grid)`, then the raw 32-bit + bit patterns (hex Z8.8, no hashing — lossless) of + `qv th qc nc qr qnr` + per category `qitot qirim nitot birim` + (+`zitot`/`qiliq`). Full-grid index = local + (`myi1`-1)/(`myj1`-1), + passed from `param.F` via module vars `chksum_i0`/`chksum_j0`; k is not + decomposed (local k = full-grid k). +- **Large output** (~all points × ~26 fields × 2 tags per step per rank): + enable only for short restart-bracketing runs around the first divergent + timestep found with `p3_chksum`. CM1 `rstfrq` restarts are + bit-reproducible for identical config/decomposition. +- `compare_p3_chksum.py` auto-detects the per-point format (same swap + mapping, same modes) and reports the exact first divergent point with + local and full-grid coordinates; directory mode: + `./compare_p3_chksum.py runA runB --swap 3 4 --pattern 'p3_chkpts_*.out'`. + +Original design sketch (raw unformatted dumps + numpy bitwise compare): ```python import numpy as np @@ -184,6 +314,33 @@ logic bug. loop order → host-side permutation sensitivity independent of P3. Even a fully fixed microphysics will not give bit-identity under the swap unless this is addressed too. + - **IMPLEMENTED (Claude Code session, 2026-07-19):** new namelist option + `qsum_invariant = .true.` in `&p3_params` (default `.false.`) replaces the + order-sensitive moist-scalar sums in the **prognostic** dynamics path with + permutation-invariant sorted sums (new pure function `sortsumq` in the + `input` module, `input.F`: ascending insertion sort then sum — invariant + to which slot holds which value; ties commute). Sites converted: + - `solve2.F` RK-loop misc block: `dum2` (Σ liquid) / `dum3` (Σ solid) → + buoyancy `dum8`, theta_rho `t11`, `thterm`, `t22` (every RK stage); + - `solve1.F` cvm block (`eqtset=2` + `idiss=1`/`rterm=1`): `dum2`/`dum3` + for moist cv in dissipative heating / rterm; + - `turb.F` (GHB 210521 block): `dum7` = Σql + Σqi feeding the subgrid + turbulence buoyancy terms. + Liquid and solid ranges are each sorted internally (sufficient: the swap + permutes only ice slots). **Not** converted (diagnostic-only, cannot feed + back on prognostic fields): `statpack` (`getqli`), `writeout` + (`calccpch`), `domaindiag`, `azimavg`, `hifrq`, `parcel`, `pdcomp`, + `init3d` (runs once, identically), the `qbudget` energy-budget sums in + `solve1.F`, and `getcvm` in `misclibs.F` (called only from non-P3 + microphysics branches: Kessler/Goddard/Morrison/ptype 6). So diagnostic + output files may still differ bitwise between swapped runs; the Phase-1 + checksums and prognostic state will not, once all in-scheme (P3 §3) + sources are also controlled. + - Test interpretation: run the swap pair with `qsum_invariant=.true.` in + both. Any remaining divergence in the Phase-1 checksums is seeded inside + `p3_main` (P3 §2/§3), not by the host dynamics. Combined with a future + P3-internal permutation-invariance pass, this switch is also the host-side + half of full bit-identity. ## MPI reproducibility on laptop (OpenMPI / mpirun) diff --git a/compare_p3_chksum.py b/compare_p3_chksum.py new file mode 100755 index 0000000..9553b19 --- /dev/null +++ b/compare_p3_chksum.py @@ -0,0 +1,296 @@ +#!/usr/bin/env python3 +""" +Compare P3 divergence-diagnosis output files (see NOTES.md), applying an +ice-category permutation to run B before comparing, so a category-swap +experiment can be diffed under the swap mapping. + +Two file formats are auto-detected per line (both from mp_p3_wrapper_wrf in +module_mp_p3.F, tag = 'PRE' entering p3_main / 'POST' after): + + p3_chksum_NNNN.out (Phase 1, slab checksums; namelist p3_chksum): + itimestep j tag + + p3_chkpts_NNNN.out (Phase 2, per-point raw bit patterns; namelist p3_chkpts): + itimestep tag i j k (local) i j k (full grid) + +Field order in both: qv th qc nc qr qnr w p, then per ice category +qitot qirim nitot birim [zitot] [qiliq]. (w and p are inputs to p3_main and +unchanged by it: a divergence in them, even on a POST line, is host-seeded.) + +Modes, chosen by the positional arguments: + + single rank: both arguments are files + ./compare_p3_chksum.py runA/p3_chksum_0000.out runB/p3_chksum_0000.out --swap 3 4 + ./compare_p3_chksum.py runA/p3_chkpts_0000.out runB/p3_chkpts_0000.out --swap 3 4 + + whole simulation: both arguments are directories; every file matching + --pattern in A is paired with the same-named file in B (rank to rank), and + a simulation-wide summary is printed after the per-rank results + ./compare_p3_chksum.py runA runB --swap 3 4 + ./compare_p3_chksum.py runA runB --swap 3 4 --pattern 'p3_chkpts_*.out' + +The mapping means: category 3 of run A is compared against category 4 of run +B, and vice versa (--map 1,2,4,3 for arbitrary permutations; --swap 3 4 is +shorthand for exactly that). + +Output: per rank, the first divergent record (for point files: the exact +local and full-grid i,j,k) and per-tag firsts; in directory mode also the +simulation-wide earliest divergence (chronological order: itimestep, then j, +then PRE before POST, then k, i for point files) and overall counts. +Use --all to list every divergent record. + +Exit status: 0 if identical under the mapping, 1 if divergent, 2 on usage or +format errors. +""" + +import argparse +import glob +import os +import sys + +NSCALAR = 8 +SCALAR_NAMES = ["qv", "th", "qc", "nc", "qr", "qnr", "w", "p"] +CAT_BASE_NAMES = ["qitot", "qirim", "nitot", "birim"] +TAGS = ("PRE", "POST") +TAG_ORDER = {"PRE": 0, "POST": 1} # execution order within one (itimestep, j) + + +def cat_field_names(percat): + """Field names within one category group, by group width.""" + # Written order: base 4, then zitot (if 3-moment ice), then qiliq (if + # liquid-fraction ice). A width of 5 is assumed to be base+zitot (the + # 3-moment configs, e.g. ptype 56/57); base+qiliq-only configs would be + # mislabeled but still compared correctly. + names = list(CAT_BASE_NAMES) + if percat >= 5: + names.append("zitot") + if percat >= 6: + names.append("qiliq") + return names[:percat] + + +def read_records(path): + """Yield (lineno, key, tag, [hex value tokens]). + + key identifies the record and is compared between runs: + slab checksum line: (itimestep, j, tag) [3 tokens] + per-point line: (itimestep, tag, i, j, k, ig, jg, kg) [8 tokens] + """ + with open(path) as f: + for lineno, line in enumerate(f, 1): + line = line.strip() + if not line or line.startswith("#"): + continue + tok = line.split() + if len(tok) > 1 and tok[1] in TAGS: # per-point format + nkey, tag = 8, tok[1] + elif len(tok) > 2 and tok[2] in TAGS: # slab-checksum format + nkey, tag = 3, tok[2] + else: + sys.exit(f"{path}:{lineno}: unrecognized record format") + if len(tok) < nkey + NSCALAR: + sys.exit(f"{path}:{lineno}: too few columns ({len(tok)})") + yield lineno, tuple(tok[:nkey]), tag, tok[nkey:] + + +def describe(key): + """Human-readable location of a record.""" + if len(key) == 3: + it, j, tag = key + return f"itimestep={it} j={j} {tag}" + it, tag, i, j, k, ig, jg, kg = key + return (f"itimestep={it} {tag} local (i,j,k)=({i},{j},{k}) " + f"full grid ({ig},{jg},{kg})") + + +def divergence_key(div): + """Chronological sort key for a divergence (key_tuple, fields).""" + key = div[0] + if len(key) == 3: + it, j, tag = key + return (int(it), int(j), TAG_ORDER.get(tag, 2), 0, 0) + it, tag, i, j, k = key[:5] + return (int(it), int(j), TAG_ORDER.get(tag, 2), int(k), int(i)) + + +def compare_pair(file_a, file_b, mapping, ncat, list_all, label=""): + """Compare one rank's pair of files. Returns a summary dict.""" + percat = None + field_names = None + ndiff = 0 + first = None + first_by_tag = {} + nlines = 0 + prefix = f"rank {label} " if label else "" + + for rec_a, rec_b in zip(read_records(file_a), read_records(file_b)): + lineno_a, key_a, tag_a, vals_a = rec_a + lineno_b, key_b, tag_b, vals_b = rec_b + + if key_a != key_b: + sys.exit(f"record mismatch at {file_a}:{lineno_a} {key_a} vs " + f"{file_b}:{lineno_b} {key_b} -- different " + f"configs/domains?") + if len(vals_a) != len(vals_b): + sys.exit(f"column-count mismatch at line {lineno_a}: " + f"{len(vals_a)} vs {len(vals_b)}") + + if percat is None: + ncatcols = len(vals_a) - NSCALAR + if ncatcols % ncat != 0: + sys.exit(f"{file_a}: {ncatcols} category columns not " + f"divisible by ncat={ncat}; check --ncat") + percat = ncatcols // ncat + field_names = SCALAR_NAMES + [ + f"{name}_{c}" for c in range(1, ncat + 1) + for name in cat_field_names(percat)] + + # reorder run B's category groups under the mapping + vals_b_mapped = vals_b[:NSCALAR] + for c in range(ncat): + src = mapping[c] - 1 + beg = NSCALAR + src * percat + vals_b_mapped += vals_b[beg:beg + percat] + + nlines += 1 + if vals_a != vals_b_mapped: + ndiff += 1 + bad = [field_names[i] for i, (a, b) + in enumerate(zip(vals_a, vals_b_mapped)) if a != b] + info = (key_a, bad) + if first is None: + first = info + first_by_tag.setdefault(tag_a, info) + if list_all: + print(f"DIFF {prefix}{describe(key_a)} " + f"fields: {' '.join(bad)}") + + if nlines == 0: + sys.exit(f"no data records found in {file_a} / {file_b}") + + return {"label": label, "nlines": nlines, "ndiff": ndiff, + "first": first, "first_by_tag": first_by_tag, "percat": percat} + + +def report_pair(res, verbose=True): + """Print the summary for one rank pair. Returns True if divergent.""" + if res["first"] is None: + if verbose: + print(f" {res['nlines']} records: IDENTICAL under the mapping") + return False + key, bad = res["first"] + print(f" first divergence: {describe(key)} fields: {' '.join(bad)}") + for tag in sorted(res["first_by_tag"]): + key, bad = res["first_by_tag"][tag] + print(f" first {tag:<4} divergence: {describe(key)} " + f"fields: {' '.join(bad)}") + print(f" {res['ndiff']} of {res['nlines']} records differ") + return True + + +def rank_files(rundir, pattern): + """Map rank label -> path, for files matching pattern in rundir.""" + out = {} + for path in glob.glob(os.path.join(rundir, pattern)): + base = os.path.basename(path) + label = os.path.splitext(base)[0].rsplit("_", 1)[-1] + out[label] = path + if not out: + sys.exit(f"no files matching {pattern} found in {rundir}") + return out + + +def main(): + ap = argparse.ArgumentParser( + description=__doc__, formatter_class=argparse.RawDescriptionHelpFormatter) + ap.add_argument("a", help="run A: output file, or run directory") + ap.add_argument("b", help="run B: output file, or run directory " + "(gets the mapping)") + ap.add_argument("--ncat", type=int, default=4, + help="number of ice categories (default 4)") + grp = ap.add_mutually_exclusive_group() + grp.add_argument("--swap", nargs=2, type=int, metavar=("C1", "C2"), + help="swap two categories of run B, e.g. --swap 3 4") + grp.add_argument("--map", dest="catmap", + help="full permutation for run B, e.g. --map 1,2,4,3") + ap.add_argument("--all", action="store_true", + help="list every divergent record, not just the first") + ap.add_argument("--pattern", default="p3_chksum_*.out", + help="directory mode: filename glob per rank " + "(default p3_chksum_*.out; use p3_chkpts_*.out " + "for the per-point dumps)") + args = ap.parse_args() + + ncat = args.ncat + mapping = list(range(1, ncat + 1)) # identity: A cat i <-> B cat i + if args.swap: + c1, c2 = args.swap + if not (1 <= c1 <= ncat and 1 <= c2 <= ncat): + sys.exit(f"--swap categories must be in 1..{ncat}") + mapping[c1 - 1], mapping[c2 - 1] = c2, c1 + elif args.catmap: + mapping = [int(x) for x in args.catmap.split(",")] + if sorted(mapping) != list(range(1, ncat + 1)): + sys.exit(f"--map must be a permutation of 1..{ncat}") + + a_isdir, b_isdir = os.path.isdir(args.a), os.path.isdir(args.b) + if a_isdir != b_isdir: + sys.exit("give two files or two directories, not a mix") + + if not a_isdir: + # ----- single-rank mode ----- + res = compare_pair(args.a, args.b, mapping, ncat, args.all) + print(f"compared {res['nlines']} records (ncat={ncat}, " + f"{res['percat']} fields/category, B-mapping {mapping})") + divergent = report_pair(res, verbose=False) + if not divergent: + print("IDENTICAL under the mapping") + sys.exit(1 if divergent else 0) + + # ----- whole-simulation mode: pair up ranks ----- + files_a = rank_files(args.a, args.pattern) + files_b = rank_files(args.b, args.pattern) + only_a = sorted(set(files_a) - set(files_b)) + only_b = sorted(set(files_b) - set(files_a)) + if only_a or only_b: + sys.exit(f"rank sets differ: only in A: {only_a or '-'}, " + f"only in B: {only_b or '-'} -- same decomposition required") + + results = [] + for label in sorted(files_a): + print(f"rank {label}:") + res = compare_pair(files_a[label], files_b[label], + mapping, ncat, args.all, label=label) + report_pair(res) + results.append(res) + + nranks = len(results) + nlines = sum(r["nlines"] for r in results) + ndiff = sum(r["ndiff"] for r in results) + bad_ranks = [r for r in results if r["first"] is not None] + + print(f"\n=== simulation-wide ({nranks} ranks, {nlines} records, " + f"ncat={ncat}, {results[0]['percat']} fields/category, " + f"B-mapping {mapping}) ===") + if not bad_ranks: + print("IDENTICAL under the mapping on every rank") + sys.exit(0) + + earliest = min(bad_ranks, key=lambda r: divergence_key(r["first"])) + key, bad = earliest["first"] + print(f"earliest divergence: rank {earliest['label']} {describe(key)} " + f"fields: {' '.join(bad)}") + # per-tag earliest across ranks + for tag in sorted({t for r in bad_ranks for t in r["first_by_tag"]}): + cand = [(r["label"], r["first_by_tag"][tag]) for r in bad_ranks + if tag in r["first_by_tag"]] + label, (key, bad) = min(cand, key=lambda c: divergence_key(c[1])) + print(f" earliest {tag:<4} divergence: rank {label} " + f"{describe(key)} fields: {' '.join(bad)}") + print(f"{len(bad_ranks)} of {nranks} ranks divergent; " + f"{ndiff} of {nlines} records differ") + sys.exit(1) + + +if __name__ == "__main__": + main() diff --git a/run/namelist.input b/run/namelist.input index 3051d80..eb0f783 100644 --- a/run/namelist.input +++ b/run/namelist.input @@ -454,6 +454,9 @@ rssflg = 1, sssflg = 1, p3_cat_init_new = .true., + p3_chksum = .false., + p3_chkpts = .false., + qsum_invariant = .false., log_nislf = .true., log_iceice_interaction = .true., p3_catdest_contact_n2 = 1, diff --git a/src/input.F b/src/input.F index 40890d0..007efef 100644 --- a/src/input.F +++ b/src/input.F @@ -29,6 +29,17 @@ MODULE input integer ierr + ! Category-swap bit-identity test (see NOTES.md): when .true., the + ! order-sensitive sums of the moist scalars (q3d slots) that feed the + ! prognostic dynamics (buoyancy/loading and moist thermodynamic terms in + ! solve1/solve2, moisture sums in turb) are replaced by permutation- + ! invariant sorted sums (function sortsumq below), so the result does not + ! depend on which scalar slot holds which value. Set via qsum_invariant + ! in the &p3_params namelist (read/broadcast in param.F). Diagnostic-only + ! sums (statpack, writeout, domaindiag, azimavg, parcel, pdcomp) are NOT + ! modified. + logical :: qsum_invariant = .false. + !----------------------------------- logical terrain_flag,procfiles,dowr, & @@ -410,4 +421,42 @@ end function mytime !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + pure real function sortsumq(v) + implicit none + + real, intent(in), dimension(:) :: v + + ! Permutation-invariant sum of moist-scalar values at one grid point: + ! the values are summed in ascending sorted order, so the result does + ! not depend on which scalar slot holds which value (equal values + ! commute, so ties are harmless). Used for the category-swap + ! bit-identity test when qsum_invariant = .true. (see NOTES.md). + ! Insertion sort: slot counts are small (<= a few per phase). + + real, dimension(size(v)) :: w + real :: tmp + integer :: i,j + + w = v + do i=2,size(v) + tmp = w(i) + j = i-1 + do + if( j.lt.1 )exit + if( w(j).le.tmp )exit + w(j+1) = w(j) + j = j-1 + enddo + w(j+1) = tmp + enddo + + sortsumq = 0.0 + do i=1,size(v) + sortsumq = sortsumq + w(i) + enddo + + end function sortsumq + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + END MODULE input diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 48b16b8..6212eef 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -51,6 +51,41 @@ MODULE microphy_p3 integer, parameter, public :: STATUS_OK = 0 integer, save :: global_status = STATUS_OK +! Phase-1 checksum instrumentation for the category-swap divergence diagnosis +! (see NOTES.md / p3_category_swap_audit.md). When log_chksum=.true., +! mp_p3_wrapper_wrf writes a bitwise, position-weighted XOR checksum of each +! prognostic field both immediately BEFORE and immediately AFTER every call +! to p3_main — two tagged lines ('PRE '/'POST') per (itimestep, j-slab) — to +! the per-rank file p3_chksum_NNNN.out (NNNN = chksum_myid). Equal checksums +! <=> bit-identical fields. Diffing two runs: first divergence on a PRE line +! means the seed entered between the previous POST and this call (host +! dynamics/advection); PRE matching while POST diverges means the seed is +! inside p3_main. +! Both switches are set by the host model (CM1: param.F, namelist p3_params, +! option p3_chksum). Note: the output file is replaced at the first write of +! each run (including restarted runs). + logical, public, save :: log_chksum = .false. + integer, public, save :: chksum_myid = 0 ! MPI rank used in checksum filename + integer, save :: chksum_unit = -1 ! output unit from newunit= (negative!) + logical, save :: chksum_opened = .false. ! file opened on first write + +! Per-point dump (log_chkpts=.true., host namelist option p3_chkpts): writes +! the raw 32-bit bit pattern (hex Z8.8, no hashing) of every field at every +! tile point, PRE and POST p3_main, to the per-rank file p3_chkpts_NNNN.out. +! Each line carries the local (i,j,k) AND the full-grid (i,j,k) — global +! index = local + chksum_i0/chksum_j0 (set by the host from its decomposition; +! k is not decomposed in CM1, so local k = global k). This is the Phase-2 +! point-isolation tool: bitwise-comparing two runs' files pinpoints the exact +! first divergent grid point and field. WARNING: output is one line per tile +! point per slab per PRE/POST — orders of magnitude larger than the checksum +! lines. Enable only for short (restart-bracketing) runs around the first +! divergent timestep found with p3_chksum. + logical, public, save :: log_chkpts = .false. + integer, public, save :: chksum_i0 = 0 ! global-i offset of local i=1 (myi1-1) + integer, public, save :: chksum_j0 = 0 ! global-j offset of local j=1 (myj1-1) + integer, save :: chkpts_unit = -1 + logical, save :: chkpts_opened = .false. + ! ice microphysics lookup table array dimensions integer, parameter :: isize = 50 integer, parameter :: iisize = 25 @@ -993,6 +1028,10 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes real, dimension(its:ite) :: pcprt_liq,pcprt_sol real :: dum1,dum2,dum3,dum4 integer :: i,k,j + integer :: j_model ! true model j-slab index for the checksum/point + ! dumps: CM1 calls this wrapper once per j with + ! 2D slabs (jts=jte=1) and the real j in j_index, + ! so the local loop j is always 1 there integer, parameter :: n_diag2d = 2 integer, parameter :: n_diag3d = 3 @@ -1030,6 +1069,9 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes ! End ERM j_loop: do j = jts,jte ! j loop (north-south) + j_model = j + if (present(j_index)) j_model = j_index + if (log_predictNc) then nc_loc(:,:) = nc(:,:,j) else @@ -1084,6 +1126,13 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes if (.not. log_3momIce) zitot = 0. !not used, but avoids passing uninialized values if (.not. log_liqFrac) qiliq = 0. !not used, but avoids passing uninialized values + !--- Phase-1 checksum instrumentation, PRE line (see NOTES.md): state + ! entering p3_main, so a diff of two runs can attribute the first + ! flipped bit to the host (PRE diverges first) or to p3_main + ! (PRE matches, POST diverges). + if (log_chksum) call chksum_write('PRE ') + if (log_chkpts) call chkpts_write('PRE ') + call p3_main( qc(its:ite,kts:kte,j),nc_loc(its:ite,kts:kte),qr(its:ite,kts:kte,j), & qnr(its:ite,kts:kte,j),th_old(its:ite,kts:kte,j),th(its:ite,kts:kte,j), & qv_old(its:ite,kts:kte,j),qv(its:ite,kts:kte,j),dt, & @@ -1115,6 +1164,12 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes endif ! ERM end + !--- Phase-1 checksum instrumentation, POST line (see NOTES.md): state + ! after p3_main. Compare ice categories under the swap mapping when + ! diffing a category-swap experiment. + if (log_chksum) call chksum_write('POST') + if (log_chkpts) call chkpts_write('POST') + !set background effective radii (i.e. with no explicit condensate) to prescribed values: ! where (qc(:,:,j) < 1.e-14) diag_effc(:,:,j) = 10.e-6 ! where (qitot < 1.e-14) diag_effi = 25.e-6 @@ -1221,10 +1276,147 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes stop endif + contains + + subroutine chksum_write(tag) + + !--- Phase-1 checksum instrumentation (see NOTES.md): writes one tagged + ! line of bitwise field checksums for the current (itimestep, j-slab); + ! tag = 'PRE ' (state entering p3_main) or 'POST' (state after). + ! Fields and loop index j are accessed by host association. + + character(len=4), intent(in) :: tag + + character(len=32) :: chksum_fname + integer :: iice_chk + + if (.not. chksum_opened) then + ! note: newunit= assigns a NEGATIVE unit number, so the opened state + ! must be tracked with a separate flag, not a sign test on the unit + write(chksum_fname,'(a,i4.4,a)') 'p3_chksum_', chksum_myid, '.out' + open(newunit=chksum_unit, file=trim(chksum_fname), status='replace', & + form='formatted', action='write') + chksum_opened = .true. + write(chksum_unit,'(a)') '# itimestep j tag qv th qc nc qr qnr w p then per ice '// & + 'category: qitot qirim nitot birim [zitot] [qiliq] (hex Z16.16)' + endif + write(chksum_unit,'(i8,1x,i5,1x,a4)',advance='no') itimestep, j_model, tag + write(chksum_unit,'(8(1x,z16.16))',advance='no') & + bitsum2(qv(its:ite,kts:kte,j)), & + bitsum2(th(its:ite,kts:kte,j)), & + bitsum2(qc(its:ite,kts:kte,j)), & + bitsum2(nc_loc(its:ite,kts:kte)), & + bitsum2(qr(its:ite,kts:kte,j)), & + bitsum2(qnr(its:ite,kts:kte,j)), & + bitsum2(w(its:ite,kts:kte,j)), & + bitsum2(p(its:ite,kts:kte,j)) + do iice_chk = 1,n_iceCat + write(chksum_unit,'(4(1x,z16.16))',advance='no') & + bitsum2(qitot(its:ite,kts:kte,iice_chk)), & + bitsum2(qirim(its:ite,kts:kte,iice_chk)), & + bitsum2(nitot(its:ite,kts:kte,iice_chk)), & + bitsum2(birim(its:ite,kts:kte,iice_chk)) + if (log_3momIce) write(chksum_unit,'(1x,z16.16)',advance='no') & + bitsum2(zitot(its:ite,kts:kte,iice_chk)) + if (log_liqFrac) write(chksum_unit,'(1x,z16.16)',advance='no') & + bitsum2(qiliq(its:ite,kts:kte,iice_chk)) + enddo + write(chksum_unit,'(a)') '' + if (j == jte .and. tag == 'POST') flush(chksum_unit) + + end subroutine chksum_write + + subroutine chkpts_write(tag) + + !--- Per-point dump (see NOTES.md): raw 32-bit bit patterns of every + ! field at every tile point of the current (itimestep, j-slab), with + ! local and full-grid indices, for exact divergent-point isolation. + ! tag = 'PRE ' (state entering p3_main) or 'POST' (state after). + ! Fields and loop index j are accessed by host association. Large + ! output: enable (p3_chkpts) only for short bracketing runs. + + character(len=4), intent(in) :: tag + + character(len=32) :: chkpts_fname + integer :: ii,kk,iice_chk + integer(kind=4) :: i4dum + + i4dum = 0 + + if (.not. chkpts_opened) then + ! newunit= assigns a NEGATIVE unit number; track opened state with a + ! separate flag, not a sign test on the unit + write(chkpts_fname,'(a,i4.4,a)') 'p3_chkpts_', chksum_myid, '.out' + open(newunit=chkpts_unit, file=trim(chkpts_fname), status='replace', & + form='formatted', action='write') + chkpts_opened = .true. + write(chkpts_unit,'(a)') '# itimestep tag i j k (local) i j k (full grid) '// & + 'qv th qc nc qr qnr w p then per ice category: qitot qirim nitot birim '// & + '[zitot] [qiliq] (hex Z8.8 raw bit patterns)' + endif + + do kk = kts,kte + do ii = its,ite + write(chkpts_unit,'(i8,1x,a4,3(1x,i5),3(1x,i6))',advance='no') & + itimestep, tag, ii, j_model, kk, ii+chksum_i0, j_model+chksum_j0, kk + write(chkpts_unit,'(8(1x,z8.8))',advance='no') & + transfer(qv(ii,kk,j),i4dum), & + transfer(th(ii,kk,j),i4dum), & + transfer(qc(ii,kk,j),i4dum), & + transfer(nc_loc(ii,kk),i4dum), & + transfer(qr(ii,kk,j),i4dum), & + transfer(qnr(ii,kk,j),i4dum), & + transfer(w(ii,kk,j),i4dum), & + transfer(p(ii,kk,j),i4dum) + do iice_chk = 1,n_iceCat + write(chkpts_unit,'(4(1x,z8.8))',advance='no') & + transfer(qitot(ii,kk,iice_chk),i4dum), & + transfer(qirim(ii,kk,iice_chk),i4dum), & + transfer(nitot(ii,kk,iice_chk),i4dum), & + transfer(birim(ii,kk,iice_chk),i4dum) + if (log_3momIce) write(chkpts_unit,'(1x,z8.8)',advance='no') & + transfer(zitot(ii,kk,iice_chk),i4dum) + if (log_liqFrac) write(chkpts_unit,'(1x,z8.8)',advance='no') & + transfer(qiliq(ii,kk,iice_chk),i4dum) + enddo + write(chkpts_unit,'(a)') '' + enddo + enddo + if (j == jte .and. tag == 'POST') flush(chkpts_unit) + + end subroutine chkpts_write + END SUBROUTINE mp_p3_wrapper_wrf #endif +!==================================================================================================! + +! Phase-1 checksum instrumentation (see NOTES.md): bitwise, position-weighted +! XOR hash of a field, used to locate the first divergent timestep between two +! runs. The bit patterns are reinterpreted as integers (transfer, no +! rounding), so equal checksums <=> bit-identical field contents. + + function bitsum(arr) result(cs) + implicit none + real, intent(in) :: arr(:) + integer(kind=8) :: cs + integer(kind=4) :: bits(size(arr)) + integer :: n + bits = transfer(arr, bits) ! reinterpret bits; no rounding + cs = 0 + do n = 1, size(arr) + cs = ieor(cs, int(bits(n),8) * int(n,8)) + enddo + end function bitsum + + function bitsum2(arr) result(cs) + implicit none + real, intent(in) :: arr(:,:) + integer(kind=8) :: cs + cs = bitsum(reshape(arr, (/size(arr)/))) + end function bitsum2 + !==================================================================================================! #ifdef ECCCGEM diff --git a/src/mp_driver.F b/src/mp_driver.F index 26e5cb0..904b85d 100644 --- a/src/mp_driver.F +++ b/src/mp_driver.F @@ -1063,6 +1063,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,26), & diag3d_02 = p3a(1,1,27), & diag3d_03 = p3a(1,1,28), & + j_index = j, & ! DTD: added j_index for debugging diagflag = (getdbz .or. dowriteout) ) ! ERM added diagflag (applies to all p3 calls) ! user-specified diagnostic output @@ -1130,6 +1131,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,27), & diag3d_02 = p3a(1,1,28), & diag3d_03 = p3a(1,1,29), & + j_index = j, & ! DTD: added j_index for debugging diagflag = (getdbz .or. dowriteout) ) do k=1,nk @@ -1211,6 +1213,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_02 = p3a(1,1,29), & diag3d_03 = p3a(1,1,30), & cn = p3a(1,1,31), & ! cn added by ERM (applies to other p3 calls with this) + j_index = j, & ! DTD: added j_index for debugging diagflag = (getdbz .or. dowriteout) ) do k=1,nk @@ -1302,6 +1305,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,29), & diag3d_02 = p3a(1,1,30), & diag3d_03 = p3a(1,1,31), & + j_index = j, & ! DTD: added j_index for debugging diagflag = (getdbz .or. dowriteout) ) do k=1,nk @@ -1508,6 +1512,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,35), & diag3d_02 = p3a(1,1,36), & diag3d_03 = p3a(1,1,37), & + j_index = j, & ! DTD: added j_index for debugging diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then @@ -1706,6 +1711,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_02 = p3a(1,1,38), & diag3d_03 = p3a(1,1,39), & cn = p3a(1,1,40), & + j_index = j, & ! DTD: added j_index for debugging diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then @@ -1912,6 +1918,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,46), & diag3d_02 = p3a(1,1,47), & diag3d_03 = p3a(1,1,48), & + j_index = j, & ! DTD: added j_index for debugging diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni @@ -2361,6 +2368,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,39), & diag3d_02 = p3a(1,1,40), & diag3d_03 = p3a(1,1,41), & + j_index = j, & ! DTD: added j_index for debugging diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then @@ -2579,6 +2587,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,49), & diag3d_02 = p3a(1,1,50), & diag3d_03 = p3a(1,1,51), & + j_index = j, & ! DTD: added j_index for debugging diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then diff --git a/src/param.F b/src/param.F index 63151e6..c7f5a92 100644 --- a/src/param.F +++ b/src/param.F @@ -73,7 +73,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & #endif use module_mp_thompson , only : thompson_init use module_mp_graupel - use microphy_p3, only : p3_init + use microphy_p3, only : p3_init, log_chksum, chksum_myid, & + log_chkpts, chksum_i0, chksum_j0 use module_mp_jensen_ishmael, only : jensen_ishmael_init use module_mp_nssl_2mom, only: nssl_2mom_init, rho_qr, cnor, rho_qs, & cnos, rho_qh, rho_qhl, cnoh, ccn, irenuc, infall, alphah, alphahl, & @@ -161,6 +162,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & integer :: rssflg = 1 ! P3: Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value integer :: sssflg = 1 ! P3: As for rain but for ice (all ice) logical :: p3_cat_init_new = .true. ! switch for mechanism-based ice category initialization + logical :: p3_chksum = .false. ! P3: write per-timestep bitwise field checksums to p3_chksum_NNNN.out (divergence diagnosis) + logical :: p3_chkpts = .false. ! P3: write per-point raw bit patterns to p3_chkpts_NNNN.out (LARGE; short bracketing runs only) logical :: log_nislf = .true. ! switch to allow ice self-aggregation logical :: log_iceice_interaction = .true. ! switch to allow ice categories to interact integer :: p3_catdest_contact_n2 = 1 @@ -224,6 +227,9 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & rssflg, & sssflg, & p3_cat_init_new,& + p3_chksum, & + p3_chkpts, & + qsum_invariant, & log_nislf, & log_iceice_interaction, & p3_catdest_contact_n2, & @@ -841,6 +847,9 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(rssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(sssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_cat_init_new,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_chksum,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_chkpts,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(qsum_invariant,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_nislf,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_iceice_interaction,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_catdest_contact_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) @@ -4417,6 +4426,14 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & if(dowr) write(outfile,*) 'Returned from P3_INIT' if(dowr) write(outfile,*) + ! Phase-1/2 checksum instrumentation (category-swap divergence diagnosis): + log_chksum = p3_chksum + log_chkpts = p3_chkpts + chksum_myid = myid + ! global index = local index + offset (k is not decomposed): + chksum_i0 = myi1-1 + chksum_j0 = myj1-1 + if( p3stat.ne.0 )then print *,' there was an error in p3_init ' call stopcm1 diff --git a/src/solve1.F b/src/solve1.F index 4eb670a..80f8ef9 100644 --- a/src/solve1.F +++ b/src/solve1.F @@ -730,6 +730,20 @@ subroutine solve1(nstep,num_soil_layers, & IF( nql1.ge.1 )THEN + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the liquid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,nk + do j=1,nj + do i=1,ni + dum2(i,j,k)=sortsumq(qa(i,j,k,nql1:nql2)) + enddo + enddo + enddo + ELSE + !$omp parallel do default(shared) & !$omp private(i,j,k) do k=1,nk @@ -752,6 +766,8 @@ subroutine solve1(nstep,num_soil_layers, & enddo enddo + ENDIF + ELSE !$omp parallel do default(shared) & @@ -768,6 +784,20 @@ subroutine solve1(nstep,num_soil_layers, & IF(iice.eq.1)THEN + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the solid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,nk + do j=1,nj + do i=1,ni + dum3(i,j,k)=sortsumq(qa(i,j,k,nqs1:nqs2)) + enddo + enddo + enddo + ELSE + !$omp parallel do default(shared) & !$omp private(i,j,k) do k=1,nk @@ -790,6 +820,8 @@ subroutine solve1(nstep,num_soil_layers, & enddo enddo + ENDIF + ELSE !$omp parallel do default(shared) & diff --git a/src/solve2.F b/src/solve2.F index 596dd12..ab74063 100644 --- a/src/solve2.F +++ b/src/solve2.F @@ -331,6 +331,18 @@ subroutine solve2(nstep, & else ifql + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the liquid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + do k=1,nk + do j=1,nj + do i=1,ni + dum2(i,j,k)=sortsumq(q3d(i,j,k,nql1:nql2)) + enddo + enddo + enddo + ELSE + do k=1,nk do j=1,nj do i=1,ni @@ -349,10 +361,24 @@ subroutine solve2(nstep, & enddo enddo + ENDIF + endif ifql IF(iice.eq.1)THEN + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the solid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + do k=1,nk + do j=1,nj + do i=1,ni + dum3(i,j,k)=sortsumq(q3d(i,j,k,nqs1:nqs2)) + enddo + enddo + enddo + ELSE + do k=1,nk do j=1,nj do i=1,ni @@ -371,6 +397,8 @@ subroutine solve2(nstep, & enddo enddo + ENDIF + ELSE do k=1,nk diff --git a/src/turb.F b/src/turb.F index d373e01..a685800 100644 --- a/src/turb.F +++ b/src/turb.F @@ -430,6 +430,18 @@ subroutine sfc_and_turb(getsfc,getpbl,nstep,dt,dosfcflx,cloudvar,qbudget, & enddo ENDDO IF( nql1.gt.0 )THEN + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the liquid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + !$omp parallel do default(shared) private(i,j,k) + DO k=1,nk + do j=1,nj + do i=1,ni + dum7(i,j,k)=dum7(i,j,k)+sortsumq(qa(i,j,k,nql1:nql2)) + enddo + enddo + ENDDO + ELSE do n=nql1,nql2 !$omp parallel do default(shared) private(i,j,k) DO k=1,nk @@ -440,8 +452,21 @@ subroutine sfc_and_turb(getsfc,getpbl,nstep,dt,dosfcflx,cloudvar,qbudget, & enddo ENDDO enddo + ENDIF ENDIF IF(iice.eq.1)THEN + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the solid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + !$omp parallel do default(shared) private(i,j,k) + DO k=1,nk + do j=1,nj + do i=1,ni + dum7(i,j,k)=dum7(i,j,k)+sortsumq(qa(i,j,k,nqs1:nqs2)) + enddo + enddo + ENDDO + ELSE do n=nqs1,nqs2 !$omp parallel do default(shared) private(i,j,k) DO k=1,nk @@ -452,6 +477,7 @@ subroutine sfc_and_turb(getsfc,getpbl,nstep,dt,dosfcflx,cloudvar,qbudget, & enddo ENDDO enddo + ENDIF ENDIF ELSE !$omp parallel do default(shared) private(i,j,k,n) From ba78be7568479fe420dc5f1f8e1cfefeb1b74a2a Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 20 Jul 2026 00:42:12 -0400 Subject: [PATCH 05/25] Add seed-isolation switches p3_clipdp/p3_epsdp/p3_limdp; record onset census findings Three independent A/B switches in &p3_params, each making one candidate order-sensitive category reduction in p3_main (practically) invariant via double-precision accumulation rounded once, default paths untouched: - p3_clipdp: entry clipping pass qv/th add-back (now DEPRIORITIZED -- exonerated by the t=175 onset census: no qv flips at any of the 158 divergent points, and a clip order-flip is necessarily a 1-ulp qv change) - p3_epsdp: epsi_tot/epsiw_tot accumulation over ice categories - p3_limdp: conservation-limiter category sums (sum(qidep)+sum(qinuc), sum(qisub), cloud/rain/vapor sinks/sources) Findings recorded in NOTES.md (HANDOFF section added for session continuity): onset is 158 points in one anvil blob at itimestep=175, ~85 columns seeding independently; source-point PRE decode shows real slot-3/4 coexistence with comparable masses but number concentrations 6 orders apart, putting the category sums in the near-ulp flip-prone regime. Remaining discriminating experiment: p3_epsdp vs p3_limdp, one at a time, both members of the swap pair. Also: decode_point.sh helper (per-point dump record -> named float values) added to repo root. Co-Authored-By: Claude Fable 5 --- NOTES.md | 97 ++++++++++++++++++++++++++++++++++++++ decode_point.sh | 15 ++++++ run/namelist.input | 3 ++ src/module_mp_p3.F | 113 ++++++++++++++++++++++++++++++++++++++++----- src/param.F | 15 +++++- 5 files changed, 230 insertions(+), 13 deletions(-) create mode 100755 decode_point.sh diff --git a/NOTES.md b/NOTES.md index 099367e..5c62533 100644 --- a/NOTES.md +++ b/NOTES.md @@ -6,6 +6,47 @@ Claude Code. --- +## HANDOFF — current status & next steps (2026-07-20) + +**Where things stand:** mechanism identified and narrowed to two candidate +sites; final discriminating experiment is ready to run. Full evidence chain in +"RESOLVED" and "Follow-up: entry-clip seed test" sections below. + +- Swap divergence originates INSIDE `p3_main` (host dynamics cleared; PRE + checksums and `w`/`p` clean at onset). Entry clipping pass also CLEARED + (fires everywhere in the undershoot halo but no `qv` flips at onset — a + clip order-flip is necessarily a visible 1-ulp `qv` change). +- Onset: itimestep=175 (1312.5 s), 158 points in one anvil blob (i=42–50, + j=18–27, k=25–38), ~85 columns seeding near-independently, ≤1 level of + same-call sedimentation smear. Real slot-3/4 ice coexistence first appears + regionally at exactly t=175. Source-point PRE decode: comparable masses + (~4e-11) but number concentrations lopsided by 6 orders (homocloud 3.8e+2 + vs rimesplinter 3.1e-4) → category sums = dominant term + near-ulp small + terms = maximally flip-prone. Flips visible only in small-magnitude ice + fields (sub-ulp in qv/th) — matches the ice-field-only onset census. +- **Next experiment (pending):** A/B the two remaining suspects with the new + namelist switches, ONE at a time, enabled in BOTH members of the swap pair, + restart bracket at 1300 s with `p3_chksum`/`p3_chkpts` on: + `p3_epsdp` (epsi_tot accumulation) vs `p3_limdp` (conservation-limiter + sums). Whichever moves/delays the t=175 onset is the seed (both may + contribute). If neither: next candidate is `sum(nitot)` in deposition + nucleation (deliberately not switched yet). + +**Conventions (do not lose these):** +- Reference run = "runA" = the rs→4/chf→3 destination config + (`.../IOP12_..._rs4_dn1_chf3_rhf2_noii_test/`); ALWAYS the first argument + to `compare_p3_chksum.py` and the file used for decodes. In that numbering: + cat1=depnuc, cat2=rain-freezing, cat3=homocloud, cat4=rime-splinter. +- Compare: `./compare_p3_chksum.py runA runB --swap 3 4 [--pattern + 'p3_chkpts_*.out'] [--all]`. Decode: `./decode_point.sh + ` (both scripts in repo root). +- Onset baseline to compare against: t=175, 158 points, field-pattern + histogram and spatial blob recorded in the Follow-up section. + +--- + +--- + ## Context Testing multi-category P3 (`module_mp_p3.F`, CM1 host, WRF-style wrapper) with @@ -356,6 +397,62 @@ logic bug. confirm checksums match bit-for-bit every timestep. Prefer `-np 1` for the definitive comparison runs if feasible. +## Follow-up: entry-clip seed test (2026-07-19, post-RESOLVED) + +Close reading of the current entry clipping pass (line ~2834) showed its gate +is an `.or.` — `qitot < qsmall` (negative undershoots included) always trips +the qv/th add-back, regardless of the `nitot < nsmall` leg (which *adds* +trigger cases rather than guarding). So the clip runs its order-dependent +per-category qv/th accumulation at every undershoot-halo point, making it the +first operation in `p3_main` able to differ between swap runs. (Also +confirmed: the melt-small-ice block at ~2863 is dead code with qsmall=1e-12 — +`qitot>=qsmall .and. qitot<1.e-12` is unsatisfiable; orphaned by the DTD +threshold change.) + +New namelist option **`p3_clipdp = .true.`** in `&p3_params` (default +`.false.`; module switch `log_clipdp`): the clip's per-category qv/th +increments are accumulated in double precision and applied once after the +category loop — practically order-invariant. Test protocol: enable in BOTH +swap runs, rerun the restart bracket. If the first divergence moves later in +time or to a different site/field pattern, the entry clip was the seed; the +new site identifies the next §3 reduction in line. Note the switch changes +results at roundoff level vs. the default path (fine for A/B use; not +intended as a permanent fix by itself). + +**UPDATE (t=175 onset census, per-point dumps):** the clip is EXONERATED as +the seed — of the 158 divergent points at t=175 (one coherent anvil blob, +i=42–50, j=18–27, k=25–38, ~85 columns seeding near-independently with ≤1 +level of same-call sedimentation smear), none flips `qv`, and a clip +order-flip is by construction a visible 1-ulp `qv` change. `p3_clipdp` rerun +deprioritized. Decoded PRE at a source point (47,19,33): REAL coexistence — +qitot_3 (homocloud) 4.5e-11 with nitot 3.8e+2, qitot_4 (rimesplinter) +3.5e-11 with nitot 3.1e-4, qitot_2 4.3e-12 with nitot 9.3e-5 (cat 1 clipped +via negative nitot). Masses comparable; NUMBERS lopsided by ~6 orders → the +category sums are one dominant (cat-3) term plus small terms at relative +1e-7–1e-6 = exactly the flip-prone near-ulp regime. Remaining suspects: the +`epsi_tot` accumulation and/or the conservation-limiter sums. Flips land +visibly only in small-magnitude fields (ice categories), staying sub-ulp in +qv/th — which is why the onset census shows ice-field-only records. +(Label convention rediscovered the hard way: the compare script's category +numbers follow the FIRST argument (reference run); keep runA = rs4/chf3 +first in every command. In that convention cat1=depnuc, cat2=rainfreeze, +cat3=homocloud, cat4=rimesplinter.) + +**A/B discriminator switches (implemented, compile-checked):** +`p3_epsdp = .true.` — `epsi_tot`/`epsiw_tot` accumulated over categories in +double precision (deferred, applied after `iice_loop1`). +`p3_limdp = .true.` — the conservation-limiter category sums +(`sum(qidep)+sum(qinuc)`, `sum(qisub)`, and the cloud/rain/vapor +sinks/sources expressions) evaluated in double precision, rounded once. +Protocol: enable ONE at a time in BOTH members of the swap pair, rerun the +bracket, compare onset. Whichever switch delays/moves the first divergence +identifies the seeding reduction (both may contribute). NOT converted +(inactive in this config, would matter for other configs): `sum(qlcon)`/ +`sum(qlevp)` in the qv_tmp/t_tmp saturation-adjustment lines (liqFrac-only +arrays, identically zero here), the `qicol` catcoll sums (ice-ice +interaction off), and `sum(nitot)` in deposition nucleation (next candidate +if neither switch moves the onset). + ## Permutation-invariance options (if pursuing full invariance later) (a) accumulate category reductions and shared-field tendencies in double diff --git a/decode_point.sh b/decode_point.sh new file mode 100755 index 0000000..210177d --- /dev/null +++ b/decode_point.sh @@ -0,0 +1,15 @@ +#!/bin/bash +# Decode one record of a p3_chkpts_NNNN.out per-point dump (see NOTES.md) +# into named field values (raw 32-bit patterns -> floats). +# usage: ./decode_point.sh +awk -v it=$2 -v tg=$3 -v i=$4 -v j=$5 -v k=$6 \ + '$1==it && $2==tg && $3==i && $4==j && $5==k' "$1" | python3 -c ' +import struct, sys +names = (["qv","th","qc","nc","qr","qnr","w","p"] + + [f"{n}_{c}" for c in range(1,5) for n in ["qitot","qirim","nitot","birim","zitot"]]) +data = sys.stdin.read().split() +if not data: sys.exit("no matching record") +for n, h in zip(names, data[8:]): + v = struct.unpack(">f", bytes.fromhex(h))[0] + print(f"{n:10s} {v:.9e}") +' diff --git a/run/namelist.input b/run/namelist.input index eb0f783..6012eb0 100644 --- a/run/namelist.input +++ b/run/namelist.input @@ -456,6 +456,9 @@ p3_cat_init_new = .true., p3_chksum = .false., p3_chkpts = .false., + p3_clipdp = .false., + p3_epsdp = .false., + p3_limdp = .false., qsum_invariant = .false., log_nislf = .true., log_iceice_interaction = .true., diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 6212eef..636797b 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -86,6 +86,28 @@ MODULE microphy_p3 integer, save :: chkpts_unit = -1 logical, save :: chkpts_opened = .false. +! Category-swap diagnostic switch (host namelist option p3_clipdp): when +! .true., the entry clipping pass of p3_main accumulates its per-category +! qv/theta increments in double precision and applies them once after the +! category loop, making the clip (practically) invariant to which slot holds +! which value. Used to test whether the clip is the first divergence seed in +! a category-swap experiment: if the first divergence moves later or to a +! different site with this enabled in both runs, the clip was the seed. +! Note: changes results at roundoff level relative to the default path. + logical, public, save :: log_clipdp = .false. + +! Companion switches for the same A/B seed-isolation protocol (host namelist +! options p3_epsdp / p3_limdp): category-order-invariant (double-precision) +! evaluation of, respectively, the epsi_tot/epsiw_tot accumulation over ice +! categories (supersaturation relaxation timescale) and the conservation- +! limiter category sums (the sum(qidep)/sum(qisub)/sinks-sources blocks). +! Enable ONE at a time in BOTH members of a swap pair: whichever switch +! delays/moves the first divergence identifies the seeding reduction. +! Same caveats as log_clipdp (practically, not formally, invariant; changes +! results at roundoff level). + logical, public, save :: log_epsdp = .false. + logical, public, save :: log_limdp = .false. + ! ice microphysics lookup table array dimensions integer, parameter :: isize = 50 integer, parameter :: iisize = 25 @@ -2463,6 +2485,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi timeScaleFactor,dt_left,qv_tmp,t_tmp,dum1z,dum7c,dum7,fluxdiv_qil,epsiw_tot double precision :: tmpdbl1,tmpdbl2,tmpdbl3 + double precision :: clipsum_qv,clipsum_th ! category-order-invariant entry clipping (log_clipdp) + double precision :: epsi_totdp,epsiw_totdp ! category-order-invariant epsi accumulation (log_epsdp) ! ERM begin integer, parameter :: dmrauto = 0 @@ -2830,12 +2854,24 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi log_hydrometeorsPresent = .true. ! updated further down endif + clipsum_qv = 0.d0 + clipsum_th = 0.d0 do iice = 1,nCat if (qitot(i,k,iice).lt.qsmall .or. nitot(i,k,iice).lt.nsmall .or. (qitot(i,k,iice).lt.1.e-12 .and. & supi(i,k).lt.-0.1)) then ! Note that ERM removed second sup criterion for testing. May try later + if (log_clipdp) then + ! category-order-invariant variant (see log_clipdp declaration): + ! defer the qv/th increments; accumulated in double precision and + ! applied once after this loop + clipsum_qv = clipsum_qv + dble(qitot(i,k,iice)) + clipsum_th = clipsum_th & + - dble(invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp) & + - dble(invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp) + else qv(i,k) = qv(i,k) + qitot(i,k,iice) th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp + endif qitot(i,k,iice) = 0. nitot(i,k,iice) = 0. qirim(i,k,iice) = 0. @@ -2874,6 +2910,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo !iice-loop + if (log_clipdp) then + ! apply the deferred clipping increments in one rounded update each + ! (before the q_old conservation diagnostic below, which must see + ! the clipped qv) + qv(i,k) = sngl(dble(qv(i,k)) + clipsum_qv) + th(i,k) = sngl(dble(th(i,k)) + clipsum_th) + endif + ! ERM begin q_old(i,k) = qv(i,k) + qc(i,k) + qr(i,k) + Sum( qitot(i,k,1:nCat) ) qv_old1(i,k) = qv(i,k) @@ -3056,6 +3100,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! initialize inverse supersaturation relaxation timescale for combined ice categories epsi_tot = 0. epsiw_tot = 0. + epsi_totdp = 0.d0 ! (only used when log_epsdp) + epsiw_totdp = 0.d0 ! DTD: turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) @@ -3609,12 +3655,21 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if ((qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then epsi(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* & rho(i,k)*dv)*nitot(i,k,iice) - epsi_tot = epsi_tot + epsi(iice) + if (log_epsdp) then + ! category-order-invariant variant (see log_epsdp declaration) + epsi_totdp = epsi_totdp + dble(epsi(iice)) + else + epsi_tot = epsi_tot + epsi(iice) + endif epsiw(iice) = 0. else epsiw(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* & rho(i,k)*dv)*nitot(i,k,iice) - epsiw_tot = epsiw_tot + epsiw(iice) + if (log_epsdp) then + epsiw_totdp = epsiw_totdp + dble(epsiw(iice)) + else + epsiw_tot = epsiw_tot + epsiw(iice) + endif epsi(iice) = 0. endif @@ -3737,6 +3792,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !-------------------- enddo iice_loop1 + + if (log_epsdp) then + ! apply the deferred category-order-invariant epsi accumulations + epsi_tot = sngl(epsi_totdp) + epsiw_tot = sngl(epsiw_totdp) + endif !-------------------- if (debug_on) then @@ -4769,7 +4830,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dumqvi = qv_sat(t_tmp,pres(i,k),1) qdep_satadj = (qv_tmp-dumqvi)/(1.+xxls(i,k)**2*dumqvi/(cp*rv*t_tmp**2))*odt*SCF(k) - tmp1 = sum(qidep)+sum(qinuc) + if (log_limdp) then + ! category-order-invariant variant (see log_limdp declaration) + tmp1 = sngl(sum(dble(qidep))+sum(dble(qinuc))) + else + tmp1 = sum(qidep)+sum(qinuc) + endif if (tmp1>0. .and. qdep_satadj<0.) then qidep = 0. qinuc = 0. @@ -4782,7 +4848,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qinuc = qinuc*ratio ninuc = ninuc*ratio endif - tmp2 = sum(qisub) ! DTD sum up qisub *before* changing individual category qisub values below + if (log_limdp) then + tmp2 = sngl(sum(dble(qisub))) + else + tmp2 = sum(qisub) ! DTD sum up qisub *before* changing individual category qisub values below + endif do iice = 1,nCat dum = max(qisub(iice),1.e-20) ! DTD: replaced sum(qisub) with tmp2 to avoid repeated summation (and potential order-dependent results) @@ -4795,8 +4865,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! cloud - sinks = (qcaut+qcacc+sum(qccol)+qcevp+sum(qchetc)+sum(qcheti)+sum(qcshd)+sum(qcmul)+ & ! DTD: added qcmul - sum(qccoll)+sum(qwgrth1c))*dt + if (log_limdp) then + sinks = sngl( dble(qcaut)+dble(qcacc)+sum(dble(qccol))+dble(qcevp)+sum(dble(qchetc))+ & + sum(dble(qcheti))+sum(dble(qcshd))+sum(dble(qcmul))+ & + sum(dble(qccoll))+sum(dble(qwgrth1c)) )*dt + else + sinks = (qcaut+qcacc+sum(qccol)+qcevp+sum(qchetc)+sum(qcheti)+sum(qcshd)+sum(qcmul)+ & ! DTD: added qcmul + sum(qccoll)+sum(qwgrth1c))*dt + endif sources = qc(i,k) + (qccon+qcnuc)*dt if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks @@ -4823,10 +4899,17 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! rain - sinks = (qrevp+sum(qrcol)+sum(qrhetc)+sum(qrheti)+sum(qrmul)+ & - sum(qrcoll)+sum(qwgrth1r))*dt - sources = qr(i,k) + (qrcon+qcaut+qcacc+sum(qrmlt)+sum(qcshd)+ & - sum(qlshd))*dt + if (log_limdp) then + sinks = sngl( dble(qrevp)+sum(dble(qrcol))+sum(dble(qrhetc))+sum(dble(qrheti))+ & + sum(dble(qrmul))+sum(dble(qrcoll))+sum(dble(qwgrth1r)) )*dt + sources = qr(i,k) + sngl( dble(qrcon)+dble(qcaut)+dble(qcacc)+sum(dble(qrmlt))+ & + sum(dble(qcshd))+sum(dble(qlshd)) )*dt + else + sinks = (qrevp+sum(qrcol)+sum(qrhetc)+sum(qrheti)+sum(qrmul)+ & + sum(qrcoll)+sum(qwgrth1r))*dt + sources = qr(i,k) + (qrcon+qcaut+qcacc+sum(qrmlt)+sum(qcshd)+ & + sum(qlshd))*dt + endif if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks qrevp = qrevp*ratio @@ -4905,8 +4988,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! vapor - sinks = (qccon+qrcon+qcnuc+sum(qidep)+sum(qinuc)+sum(qlcon))*dt - sources = qv(i,k) + (qcevp+qrevp+sum(qisub)+sum(qlevp))*dt + if (log_limdp) then + sinks = sngl( dble(qccon)+dble(qrcon)+dble(qcnuc)+sum(dble(qidep))+ & + sum(dble(qinuc))+sum(dble(qlcon)) )*dt + sources = qv(i,k) + sngl( dble(qcevp)+dble(qrevp)+sum(dble(qisub))+sum(dble(qlevp)) )*dt + else + sinks = (qccon+qrcon+qcnuc+sum(qidep)+sum(qinuc)+sum(qlcon))*dt + sources = qv(i,k) + (qcevp+qrevp+sum(qisub)+sum(qlevp))*dt + endif if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks qccon = qccon*ratio diff --git a/src/param.F b/src/param.F index c7f5a92..0609adb 100644 --- a/src/param.F +++ b/src/param.F @@ -74,7 +74,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & use module_mp_thompson , only : thompson_init use module_mp_graupel use microphy_p3, only : p3_init, log_chksum, chksum_myid, & - log_chkpts, chksum_i0, chksum_j0 + log_chkpts, chksum_i0, chksum_j0, & + log_clipdp, log_epsdp, log_limdp use module_mp_jensen_ishmael, only : jensen_ishmael_init use module_mp_nssl_2mom, only: nssl_2mom_init, rho_qr, cnor, rho_qs, & cnos, rho_qh, rho_qhl, cnoh, ccn, irenuc, infall, alphah, alphahl, & @@ -164,6 +165,9 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & logical :: p3_cat_init_new = .true. ! switch for mechanism-based ice category initialization logical :: p3_chksum = .false. ! P3: write per-timestep bitwise field checksums to p3_chksum_NNNN.out (divergence diagnosis) logical :: p3_chkpts = .false. ! P3: write per-point raw bit patterns to p3_chkpts_NNNN.out (LARGE; short bracketing runs only) + logical :: p3_clipdp = .false. ! P3: category-order-invariant entry clipping (double-precision accumulation; divergence diagnosis) + logical :: p3_epsdp = .false. ! P3: category-order-invariant epsi_tot accumulation (divergence diagnosis) + logical :: p3_limdp = .false. ! P3: category-order-invariant conservation-limiter sums (divergence diagnosis) logical :: log_nislf = .true. ! switch to allow ice self-aggregation logical :: log_iceice_interaction = .true. ! switch to allow ice categories to interact integer :: p3_catdest_contact_n2 = 1 @@ -229,6 +233,9 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_cat_init_new,& p3_chksum, & p3_chkpts, & + p3_clipdp, & + p3_epsdp, & + p3_limdp, & qsum_invariant, & log_nislf, & log_iceice_interaction, & @@ -849,6 +856,9 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(p3_cat_init_new,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_chksum,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_chkpts,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_clipdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_epsdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_limdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(qsum_invariant,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_nislf,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_iceice_interaction,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) @@ -4429,6 +4439,9 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! Phase-1/2 checksum instrumentation (category-swap divergence diagnosis): log_chksum = p3_chksum log_chkpts = p3_chkpts + log_clipdp = p3_clipdp + log_epsdp = p3_epsdp + log_limdp = p3_limdp chksum_myid = myid ! global index = local index + offset (k is not decomposed): chksum_i0 = myi1-1 From fa352243b4511f20a8eeb337a3ba96a0fae1bbf2 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 20 Jul 2026 11:46:28 -0400 Subject: [PATCH 06/25] Add p3_nucdp switch; document combined-run protocol after single-switch nulls Single-switch A/B runs (p3_epsdp alone, p3_limdp alone) left the divergence onset unchanged (same timestep/point/fields; only downstream counts differ). Two lessons recorded in NOTES.md: the one-at-a-time protocol cannot isolate the seed when multiple reductions flip the same points, and sum(nitot) in deposition nucleation (live: Cooper, dest cat 1) was unswitched in all runs -- its flip propagates to all categories through the binding satadj limiter ratio, which p3_limdp does not protect against. p3_nucdp makes that sum order-invariant (computed once, double precision). Next experiment: ALL four invariance switches enabled together in both members of the swap pair; onset unchanged would exclude all known order-of-operations sites and leave stale per-category state (NaN-poison + FP-trap hunt) as the remaining explanation. Also noted in NOTES.md: latent p3_init bug -- optional iparamice_in is unconditionally overwritten by the default (iparamice=1) set after it. Co-Authored-By: Claude Fable 5 --- NOTES.md | 39 ++++++++++++++++++++++++++++++++------- run/namelist.input | 1 + src/module_mp_p3.F | 22 ++++++++++++++++++++-- src/param.F | 6 +++++- 4 files changed, 58 insertions(+), 10 deletions(-) diff --git a/NOTES.md b/NOTES.md index 5c62533..e7e2bd1 100644 --- a/NOTES.md +++ b/NOTES.md @@ -24,13 +24,38 @@ sites; final discriminating experiment is ready to run. Full evidence chain in vs rimesplinter 3.1e-4) → category sums = dominant term + near-ulp small terms = maximally flip-prone. Flips visible only in small-magnitude ice fields (sub-ulp in qv/th) — matches the ice-field-only onset census. -- **Next experiment (pending):** A/B the two remaining suspects with the new - namelist switches, ONE at a time, enabled in BOTH members of the swap pair, - restart bracket at 1300 s with `p3_chksum`/`p3_chkpts` on: - `p3_epsdp` (epsi_tot accumulation) vs `p3_limdp` (conservation-limiter - sums). Whichever moves/delays the t=175 onset is the seed (both may - contribute). If neither: next candidate is `sum(nitot)` in deposition - nucleation (deliberately not switched yet). +- **Single-switch A/B results (2026-07-20): onset UNCHANGED under `p3_epsdp` + alone and `p3_limdp` alone** — same first timestep/point/fields; only the + downstream divergent-record counts differ (expected: different roundoff + growth paths). Interpretation caveats discovered afterward: + (1) the one-at-a-time protocol is FLAWED if multiple reductions flip the + same points — each single-switch run leaves the other mechanisms live, so + an unchanged onset does not exonerate the switched site; + (2) `sum(nitot)` in deposition nucleation was unswitched in ALL runs, is + live in this config (iparamice=1 Cooper, T<258.15 K, supi>=0.05, + destination cat 1 via dn1), and its flip propagates to ALL categories' + qidep through the satadj limiter ratio when it binds — `p3_limdp` does NOT + protect against this (invariant summation of already-flipped qinuc inputs); + (3) the k=33 topmost source record of the dry decoded column flips cats + 2+4 (all components), locally, where nucleation cannot fire (RH_i≈35%) — + so at least that column is NOT nucleation-seeded. +- **Next experiment (pending): the combined run.** New switch `p3_nucdp` + (order-invariant sum(nitot) in dep. nucleation, module_mp_p3.F ~4352). + Enable ALL FOUR invariance switches together in BOTH members of the pair + (`p3_clipdp/p3_epsdp/p3_limdp/p3_nucdp = .true.`), rerun the bracket: + - onset moves/delays → seed was (a combination of) the known §3 sums; can + then bisect by re-disabling switches one at a time if the specific site + matters; + - onset STILL unchanged → all known §3 reductions excluded → §2-class + stale per-category state is the remaining explanation → NaN-poisoning + + FP-trap hunt (set f1pr01–f1pr38 and per-category scratch to signaling + NaNs at top of iice_loop1; build with -g -fbacktrace -ffpe-trap=invalid; + serial bracket run; trap backtrace names the guilty line). +- **Latent bug found in passing (unrelated to divergence, fix someday):** + `p3_init` line ~328 applies optional `iparamice_in`, then line ~360 + unconditionally overwrites `iparamice = 1` — a host-passed Meyers + selection would be silently ignored (CM1 never passes it, so currently + benign). **Conventions (do not lose these):** - Reference run = "runA" = the rs→4/chf→3 destination config diff --git a/run/namelist.input b/run/namelist.input index 6012eb0..1afde13 100644 --- a/run/namelist.input +++ b/run/namelist.input @@ -459,6 +459,7 @@ p3_clipdp = .false., p3_epsdp = .false., p3_limdp = .false., + p3_nucdp = .false., qsum_invariant = .false., log_nislf = .true., log_iceice_interaction = .true., diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 636797b..a7eb6c9 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -107,6 +107,12 @@ MODULE microphy_p3 ! results at roundoff level). logical, public, save :: log_epsdp = .false. logical, public, save :: log_limdp = .false. +! p3_nucdp: category-order-invariant sum(nitot) in deposition nucleation +! (N_nuc/Q_nuc); computed once in double precision. NOTE: single-switch +! A/B runs cannot isolate the seed if multiple reductions flip the same +! points -- the decisive test is ALL log_*dp switches enabled together in +! both members of a swap pair. + logical, public, save :: log_nucdp = .false. ! ice microphysics lookup table array dimensions integer, parameter :: isize = 50 @@ -2487,6 +2493,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi double precision :: tmpdbl1,tmpdbl2,tmpdbl3 double precision :: clipsum_qv,clipsum_th ! category-order-invariant entry clipping (log_clipdp) double precision :: epsi_totdp,epsiw_totdp ! category-order-invariant epsi accumulation (log_epsdp) + double precision :: nitotsum_dp ! category-order-invariant sum(nitot) in dep. nucleation (log_nucdp) ! ERM begin integer, parameter :: dmrauto = 0 @@ -4349,10 +4356,21 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! dum = 0.005*dexp(dble(0.304*(273.15-t(i,k))))*1000.*inv_rho(i,k) !Cooper (1986) dum = min(dum,100.e3*inv_rho(i,k)*SCF(k)) - N_nuc = max(0.,(dum-sum(nitot(i,k,:)))*odt) + if (log_nucdp) then + ! category-order-invariant variant (see log_nucdp declaration): + ! total ice number computed once, in double precision + nitotsum_dp = sum(dble(nitot(i,k,:))) + N_nuc = max(0.,(dum-sngl(nitotsum_dp))*odt) + else + N_nuc = max(0.,(dum-sum(nitot(i,k,:)))*odt) + endif if (N_nuc.ge.1.e-20) then - Q_nuc = max(0.,(dum-sum(nitot(i,k,:)))*mi0*odt) + if (log_nucdp) then + Q_nuc = max(0.,(dum-sngl(nitotsum_dp))*mi0*odt) + else + Q_nuc = max(0.,(dum-sum(nitot(i,k,:)))*mi0*odt) + endif if (nCat>1) then !determine destination ice-phase category: if (.not. cat_init_new) then diff --git a/src/param.F b/src/param.F index 0609adb..bc13f66 100644 --- a/src/param.F +++ b/src/param.F @@ -75,7 +75,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & use module_mp_graupel use microphy_p3, only : p3_init, log_chksum, chksum_myid, & log_chkpts, chksum_i0, chksum_j0, & - log_clipdp, log_epsdp, log_limdp + log_clipdp, log_epsdp, log_limdp, log_nucdp use module_mp_jensen_ishmael, only : jensen_ishmael_init use module_mp_nssl_2mom, only: nssl_2mom_init, rho_qr, cnor, rho_qs, & cnos, rho_qh, rho_qhl, cnoh, ccn, irenuc, infall, alphah, alphahl, & @@ -168,6 +168,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & logical :: p3_clipdp = .false. ! P3: category-order-invariant entry clipping (double-precision accumulation; divergence diagnosis) logical :: p3_epsdp = .false. ! P3: category-order-invariant epsi_tot accumulation (divergence diagnosis) logical :: p3_limdp = .false. ! P3: category-order-invariant conservation-limiter sums (divergence diagnosis) + logical :: p3_nucdp = .false. ! P3: category-order-invariant sum(nitot) in deposition nucleation (divergence diagnosis) logical :: log_nislf = .true. ! switch to allow ice self-aggregation logical :: log_iceice_interaction = .true. ! switch to allow ice categories to interact integer :: p3_catdest_contact_n2 = 1 @@ -236,6 +237,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_clipdp, & p3_epsdp, & p3_limdp, & + p3_nucdp, & qsum_invariant, & log_nislf, & log_iceice_interaction, & @@ -859,6 +861,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(p3_clipdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_epsdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_limdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_nucdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(qsum_invariant,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_nislf,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_iceice_interaction,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) @@ -4442,6 +4445,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & log_clipdp = p3_clipdp log_epsdp = p3_epsdp log_limdp = p3_limdp + log_nucdp = p3_nucdp chksum_myid = myid ! global index = local index + offset (k is not decomposed): chksum_i0 = myi1-1 From 4441c73f541572a5a62c7a36502114c1419597eb Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 20 Jul 2026 12:26:13 -0400 Subject: [PATCH 07/25] Add p3_nanpoison stale-state hunt after combined-run null excludes all known sums The combined run (all four order-invariance switches enabled in both swap members) left the divergence onset unchanged -- every known sec.-3 order-of-operations reduction is excluded as the seed. Remaining explanation: sec.-2-class stale per-category state inherited across iice_loop1 iterations. p3_nanpoison poisons all per-category work variables at the top of every iice_loop1 iteration: f1pr01-38 lookup values, interpolation weights (dum1/3/4/5/6/7), rhop, mu_i as signaling NaNs (bit pattern via transfer, set in p3_init), and lookup indices (dumi/dumj/dumii/dumjj/dumll/dumzz) as huge sentinels. Consumption before being set in the same iteration traps under -ffpe-trap=invalid / -fcheck=bounds. Deliberate per-iteration defaults (Eii_fact, tmp1) are not poisoned. Verified on this machine (arm64 macOS): gfortran's -ffpe-trap fires (EXC_BAD_INSTRUCTION) but its handler loops instead of terminating; running under lldb stops at the exact consuming line. Debug-build recipe and lldb workflow documented in NOTES.md; single serial run suffices (no A/B). Co-Authored-By: Claude Fable 5 --- NOTES.md | 49 ++++++++++++++++++++++++++++++++++------------ run/namelist.input | 1 + src/module_mp_p3.F | 42 +++++++++++++++++++++++++++++++++++++++ src/param.F | 7 ++++++- 4 files changed, 86 insertions(+), 13 deletions(-) diff --git a/NOTES.md b/NOTES.md index e7e2bd1..6ee8037 100644 --- a/NOTES.md +++ b/NOTES.md @@ -39,18 +39,43 @@ sites; final discriminating experiment is ready to run. Full evidence chain in (3) the k=33 topmost source record of the dry decoded column flips cats 2+4 (all components), locally, where nucleation cannot fire (RH_i≈35%) — so at least that column is NOT nucleation-seeded. -- **Next experiment (pending): the combined run.** New switch `p3_nucdp` - (order-invariant sum(nitot) in dep. nucleation, module_mp_p3.F ~4352). - Enable ALL FOUR invariance switches together in BOTH members of the pair - (`p3_clipdp/p3_epsdp/p3_limdp/p3_nucdp = .true.`), rerun the bracket: - - onset moves/delays → seed was (a combination of) the known §3 sums; can - then bisect by re-disabling switches one at a time if the specific site - matters; - - onset STILL unchanged → all known §3 reductions excluded → §2-class - stale per-category state is the remaining explanation → NaN-poisoning + - FP-trap hunt (set f1pr01–f1pr38 and per-category scratch to signaling - NaNs at top of iice_loop1; build with -g -fbacktrace -ffpe-trap=invalid; - serial bracket run; trap backtrace names the guilty line). +- **COMBINED-RUN RESULT (2026-07-20): onset STILL unchanged with ALL FOUR + invariance switches enabled** (`p3_clipdp/p3_epsdp/p3_limdp/p3_nucdp`) in + both members of the pair — same first timestep/point/fields. Every known + §3 order-of-operations reduction is now excluded as the seed. Remaining + explanation: §2-class stale per-category state (a work variable inherited + across iice_loop1 iterations, making a species' physics depend on which + category slot preceded it — exactly what a slot swap changes). +- **Next experiment (pending): the NaN-poison stale-state hunt.** New switch + `p3_nanpoison = .true.` in `&p3_params`: at the top of EVERY iice_loop1 + iteration, all per-category work variables are poisoned — f1pr01–f1pr10, + f1pr13–f1pr19, f1pr22–f1pr38 (reals, signaling NaN via bit pattern), + lookup interpolation weights dum1/dum3/dum4/dum5/dum6/dum7, rhop, mu_i + (signaling NaN), and lookup indices dumi/dumj/dumii/dumjj/dumll/dumzz + (huge sentinel). Any consumption before being set in that same category + iteration traps. Deliberate per-iteration defaults (Eii_fact=1, tmp1=0) + are NOT poisoned. + **Run recipe (single run, no A/B needed — the stale path executes + regardless of destination namelist):** + 1. Debug build: in the Makefile set + `OPTS = -ffree-form -ffree-line-length-none -O0 -g -ffpe-trap=invalid -fcheck=bounds` + (drop -O2/-finline; rebuild everything). + 2. `p3_nanpoison = .true.` in the namelist (bracket restart config is + fine and fastest; full run also works). + 3. Run SERIALLY under lldb (macOS/arm64: gfortran's trap handler loops + instead of terminating, but lldb stops at the exact line): + `lldb -- ./cm1.exe` then `run`; at each stop lldb shows file:line + (verified working on this machine: EXC_BAD_INSTRUCTION at the exact + consuming statement). `bt` for the call stack, `process continue` to + resume past stops judged benign, `frame variable iice` etc. to inspect. + 4. Integer-index stale use surfaces as a -fcheck=bounds error (aborts + with file:line) rather than an FP trap. + Interpretation: a stop inside process-rate code consuming a poisoned + value = the stale path, and the backtrace names the guilty line. If the + run completes with NO stops, the poisoned set is exonerated and the next + tier of scratch (tmp*/dum2/etc.) gets poisoned. Note other CM1 modules + may trap benignly with global -ffpe-trap; only stops in module_mp_p3 + category code are of interest — continue past others. - **Latent bug found in passing (unrelated to divergence, fix someday):** `p3_init` line ~328 applies optional `iparamice_in`, then line ~360 unconditionally overwrites `iparamice = 1` — a host-passed Meyers diff --git a/run/namelist.input b/run/namelist.input index 1afde13..be16072 100644 --- a/run/namelist.input +++ b/run/namelist.input @@ -460,6 +460,7 @@ p3_epsdp = .false., p3_limdp = .false., p3_nucdp = .false., + p3_nanpoison = .false., qsum_invariant = .false., log_nislf = .true., log_iceice_interaction = .true., diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index a7eb6c9..e77007b 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -114,6 +114,23 @@ MODULE microphy_p3 ! both members of a swap pair. logical, public, save :: log_nucdp = .false. +! p3_nanpoison: stale-state hunt (audit sec. 2 class). When .true., all +! per-category work variables (f1pr* lookup values, lookup-table indices and +! interpolation weights, rhop, mu_i) are poisoned at the top of EVERY +! iice_loop1 iteration: reals with a signaling NaN, integer indices with a +! huge sentinel. Any consumption before being set in that same category +! iteration then traps, identifying a slot-order-dependent stale path. +! Build requirements: -ffpe-trap=invalid -fcheck=bounds -g -O0 and run +! serially under a debugger (on macOS/arm64 the gfortran trap handler loops +! instead of terminating, but lldb stops at the exact line: lldb -- ./cm1.exe +! then 'run'; each stop shows file:line; 'process continue' to resume past +! stops judged benign). Deliberate per-iteration defaults (Eii_fact, tmp1) +! are NOT poisoned. A single run suffices (no A/B): the stale path executes +! regardless of the category-destination namelist. + logical, public, save :: log_nanpoison = .false. + real, save :: snan_r4 = 0. ! signaling NaN; set in p3_init + integer, parameter :: int_poison = -2000000000 ! index poison (traps via -fcheck=bounds) + ! ice microphysics lookup table array dimensions integer, parameter :: isize = 50 integer, parameter :: iisize = 25 @@ -310,6 +327,10 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err n_iceCat = nCat !used for GEM interface +! signaling NaN for the p3_nanpoison stale-state hunt (bit pattern via +! transfer: no floating-point operation, so this never traps itself) + snan_r4 = transfer(int(z'7FA00000',kind=4),1.0) + ! mathematical/optimization constants pi = 3.14159265 !pi = acos(-1.) @@ -3115,6 +3136,27 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_loop1: do iice = 1,nCat Eii_fact(iice) = 1.0 ! DTD: set default value of ice-ice collection efficiency factor to 1.0 to avoid potential stale value issue + if (log_nanpoison) then + !--- stale-state hunt (see log_nanpoison declaration): poison the + ! per-category work variables; any consumption before being set + ! in THIS category iteration traps (reals via -ffpe-trap=invalid, + ! integer table indices via -fcheck=bounds) + f1pr01 = snan_r4; f1pr02 = snan_r4; f1pr03 = snan_r4; f1pr04 = snan_r4 + f1pr05 = snan_r4; f1pr06 = snan_r4; f1pr07 = snan_r4; f1pr08 = snan_r4 + f1pr09 = snan_r4; f1pr10 = snan_r4; f1pr13 = snan_r4; f1pr14 = snan_r4 + f1pr15 = snan_r4; f1pr16 = snan_r4; f1pr17 = snan_r4; f1pr18 = snan_r4 + f1pr19 = snan_r4; f1pr22 = snan_r4; f1pr23 = snan_r4; f1pr24 = snan_r4 + f1pr25 = snan_r4; f1pr26 = snan_r4; f1pr27 = snan_r4; f1pr28 = snan_r4 + f1pr29 = snan_r4; f1pr30 = snan_r4; f1pr31 = snan_r4; f1pr32 = snan_r4 + f1pr33 = snan_r4; f1pr34 = snan_r4; f1pr35 = snan_r4; f1pr36 = snan_r4 + f1pr37 = snan_r4; f1pr38 = snan_r4 + dum1 = snan_r4; dum3 = snan_r4; dum4 = snan_r4; dum5 = snan_r4 + dum6 = snan_r4; dum7 = snan_r4 + rhop = snan_r4; mu_i = snan_r4 + dumi = int_poison; dumj = int_poison; dumii = int_poison + dumjj = int_poison; dumll = int_poison; dumzz = int_poison + endif + qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check ! DTD changed to .ge. from > to ensure case where nitot = nsmall is included !impose lower limits to prevent taking log of # < 0 diff --git a/src/param.F b/src/param.F index bc13f66..bc62b9e 100644 --- a/src/param.F +++ b/src/param.F @@ -75,7 +75,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & use module_mp_graupel use microphy_p3, only : p3_init, log_chksum, chksum_myid, & log_chkpts, chksum_i0, chksum_j0, & - log_clipdp, log_epsdp, log_limdp, log_nucdp + log_clipdp, log_epsdp, log_limdp, log_nucdp, & + log_nanpoison use module_mp_jensen_ishmael, only : jensen_ishmael_init use module_mp_nssl_2mom, only: nssl_2mom_init, rho_qr, cnor, rho_qs, & cnos, rho_qh, rho_qhl, cnoh, ccn, irenuc, infall, alphah, alphahl, & @@ -169,6 +170,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & logical :: p3_epsdp = .false. ! P3: category-order-invariant epsi_tot accumulation (divergence diagnosis) logical :: p3_limdp = .false. ! P3: category-order-invariant conservation-limiter sums (divergence diagnosis) logical :: p3_nucdp = .false. ! P3: category-order-invariant sum(nitot) in deposition nucleation (divergence diagnosis) + logical :: p3_nanpoison = .false. ! P3: NaN-poison per-category work vars for stale-state hunt (debug build + lldb required) logical :: log_nislf = .true. ! switch to allow ice self-aggregation logical :: log_iceice_interaction = .true. ! switch to allow ice categories to interact integer :: p3_catdest_contact_n2 = 1 @@ -238,6 +240,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_epsdp, & p3_limdp, & p3_nucdp, & + p3_nanpoison, & qsum_invariant, & log_nislf, & log_iceice_interaction, & @@ -862,6 +865,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(p3_epsdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_limdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_nucdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_nanpoison,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(qsum_invariant,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_nislf,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_iceice_interaction,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) @@ -4446,6 +4450,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & log_epsdp = p3_epsdp log_limdp = p3_limdp log_nucdp = p3_nucdp + log_nanpoison = p3_nanpoison chksum_myid = myid ! global index = local index + offset (k is not decomposed): chksum_i0 = myi1-1 From ee440aeb3ed65d7735a237545760a6db533817e4 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 20 Jul 2026 12:43:04 -0400 Subject: [PATCH 08/25] Guard 0/0 in diag_effi_ave at ice-free points (found by p3_nanpoison FP-trap run) The mass/area-weighted effective-radius average in mp_p3_wrapper_wrf divided unconditionally; at ice-free points all weights are zero, so diag_effi_ave has been silently NaN there in every nCat>=2 run (harmless with radopt=0, garbage in output, would poison radiation if enabled). The division is now guarded and the 25-micron default retained where no ice contributes. First find of the stale-state hunt; benign for the divergence question but had to be silenced for the trap run to proceed past the first call. Co-Authored-By: Claude Fable 5 --- src/Makefile | 23 ++++++++++++----------- src/module_mp_p3.F | 12 +++++++++--- 2 files changed, 21 insertions(+), 14 deletions(-) diff --git a/src/Makefile b/src/Makefile index 6505a14..f5daf08 100644 --- a/src/Makefile +++ b/src/Makefile @@ -22,23 +22,23 @@ LINKOPTS = -lnetcdf -lnetcdff #----------------------------------------------------------------------------- # HARDWARE SECTION -#-- Choose the appropriate architecture, and uncomment all lines +#-- Choose the appropriate architecture, and uncomment all lines #-- in that section. See "README.compile" for more information. #----------------------------------------------------------------------------- -# single processor, Intel compiler +# single processor, Intel compiler # (eg, NCAR's yellowstone/caldera/cheyenne) #FC = ifort #OPTS = -O3 -xHost -ip -assume byterecl -fp-model precise -ftz -no-fma #CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding #----------------------------------------------------------------------------- -# multiple processors, distributed memory (MPI), Intel compiler +# multiple processors, distributed memory (MPI), Intel compiler # (eg, NCAR's yellowstone/cheyenne) #FC = mpif90 #OPTS = -O3 -xHost -ip -assume byterecl -fp-model precise -ftz -no-fma #CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding #DM = -DMPI #----------------------------------------------------------------------------- -# multiple processors, shared memory (OpenMP), Intel compiler +# multiple processors, shared memory (OpenMP), Intel compiler # (eg, NCAR's yellowstone/cheyenne) #FC = mpif90 #OPTS = -O3 -xHost -ip -assume byterecl -fp-model precise -ftz -no-fma -qopenmp @@ -76,15 +76,16 @@ LINKOPTS = -lnetcdf -lnetcdff #OMP = -DOPENMP #----------------------------------------------------------------------------- # single processor, GNU compiler -# FC = gfortran +FC = gfortran # OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -# CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding +OPTS = -ffree-form -ffree-line-length-none -O0 -g -ffpe-trap=invalid -fcheck=bounds +CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding #----------------------------------------------------------------------------- # multiple processors, distributed memory (MPI), GNU compiler -FC = mpif90 -OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding -DM = -DMPI +# FC = mpif90 +# OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions +# CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding +# DM = -DMPI # multiple processors, distributed memory (MPI), GNU compiler, double precision # DTD TODO: this doesn't seem to work on my Macbook at least. Run stalls somewhere before starting # the main time loop. @@ -262,7 +263,7 @@ hifrq.o: input.o constants.o cm1libs.o adv.o adv_routines.o bc.o ib_module.o wri ib_module.o: input.o constants.o bc.o comm.o init3d.o: constants.o input.o misclibs.o cm1libs.o bc.o comm.o module_mp_nssl_2mom.o poiss.o parcel.o ib_module.o turb.o init_physics.o: constants.o input.o sfclay.o sfclayrev.o slab.o radtrns3d.o irrad3d.o goddard.o module_ra_rrtmg_lw.o module_ra_rrtmg_sw.o module_sf_gfdl.o module_sf_mynn.o module_bl_mynn.o module_sf_myjsfc.o -init_surface.o: constants.o input.o oml.o +init_surface.o: constants.o input.o oml.o init_terrain.o: constants.o input.o bc.o comm.o adv_routines.o interp_routines.o: constants.o input.o irrad3d.o: radlib3d.o diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index e77007b..9a06604 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -1296,15 +1296,21 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes endif endif + !guard against 0/0 at ice-free points (division previously ran + !unconditionally, silently filling diag_effi_ave with NaNs there; + !the 25-micron default set above is retained instead) select case (n_iceCat) case (1) diag_effi_ave(i,k,j) = diag_effi(i,k,1) case (2) - diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2))/(dum1+dum2) + if (dum1+dum2.gt.0.) & + diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2))/(dum1+dum2) case (3) - diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2)+qitot(i,k,3))/(dum1+dum2+dum3) + if (dum1+dum2+dum3.gt.0.) & + diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2)+qitot(i,k,3))/(dum1+dum2+dum3) case (4) - diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2)+qitot(i,k,3)+qitot(i,k,4))/(dum1+dum2+dum3+dum4) + if (dum1+dum2+dum3+dum4.gt.0.) & + diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2)+qitot(i,k,3)+qitot(i,k,4))/(dum1+dum2+dum3+dum4) end select enddo !k-loop From 7bf16001ef589ba9fa3725b497d242689e9ae284 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 20 Jul 2026 12:48:26 -0400 Subject: [PATCH 09/25] Split non-short-circuiting conditional: 0/0 qiliq/qitot at empty categories Second find of the p3_nanpoison FP-trap run: the zidep compound conditional evaluated qiliq/qitot even when epsiw(iice)=0 (Fortran .and. does not short-circuit), giving 0/0 at empty categories -- NaN in a comparison, benign in effect (compares false, matching intent) but an invalid op every time. Nested the ifs, same pattern as the existing ERM splits. Co-Authored-By: Claude Fable 5 --- src/module_mp_p3.F | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 9a06604..492a8b0 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -4309,8 +4309,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi else qlcon(iice) = min(qlcon(iice), qv(i,k)*odt) - if (log_3momentIce.and.epsiw(iice).gt.0..and.(qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then - zidep(iice) = epsiz(iice)/epsiw(iice)*qlcon(iice) + if (log_3momentIce.and.epsiw(iice).gt.0.) then ! split conditional: .and. does not + if ((qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then ! short-circuit, so the division + zidep(iice) = epsiz(iice)/epsiw(iice)*qlcon(iice) ! was 0/0 at empty categories + endif endif endif From 32f7eb644dc31300cbd3ac2709a7b8bf42b16be6 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 20 Jul 2026 12:56:01 -0400 Subject: [PATCH 10/25] Fix stale f1pr16 in iice_loop2: the category-swap divergence seed Found by the p3_nanpoison FP-trap hunt (trap at the dumden=f1pr16 consumption): iice_loop2 computed the pre-update 3-moment mu_i for every category using the scalar f1pr16 -- the mass-weighted mean density of whichever category LAST ran the lookup in iice_loop1. Wrong species' density for all but one category, and which species leaked depends on category slot order: precisely what the destination-category swap changes, seeding divergence wherever two ice categories coexist. mu_i_s feeds the post-update zitot adjustment, matching the observed onset (ice-moment-only flips, incl. a pure-zitot record; immune to all order-invariance switches). Fix: per-category f1pr16_s(nCat), saved inside each category's own lookup block (-1 = lookup not accessed this step); iice_loop2 uses f1pr16_s(iice) and retains mu_i_initial when this category's lookup did not run. This is a physics fix affecting all 3-moment nCat>1 runs, not merely a reproducibility fix. Co-Authored-By: Claude Fable 5 --- NOTES.md | 28 +++++++++++++++++++++++++--- src/module_mp_p3.F | 20 ++++++++++++++++++-- 2 files changed, 43 insertions(+), 5 deletions(-) diff --git a/NOTES.md b/NOTES.md index 6ee8037..36efdf6 100644 --- a/NOTES.md +++ b/NOTES.md @@ -8,9 +8,31 @@ Claude Code. ## HANDOFF — current status & next steps (2026-07-20) -**Where things stand:** mechanism identified and narrowed to two candidate -sites; final discriminating experiment is ready to run. Full evidence chain in -"RESOLVED" and "Follow-up: entry-clip seed test" sections below. +**BUG FOUND AND FIXED (2026-07-20, p3_nanpoison FP-trap hunt):** the seed of +the category-swap divergence is a **stale-scalar bug**: `iice_loop2` +(pre-update mu_i for 3-moment ice, module_mp_p3.F ~5122) read the plain +scalar `f1pr16` (mass-weighted mean particle density) for EVERY category — +but a scalar only retains the value of whichever category LAST ran the +lookup in `iice_loop1`. So `mu_i_s(iice)` (feeds the post-update `zitot` +adjustment via `calculate_mu_change`/`G_of_mu`) used the wrong species' +density for all but one category, and *which* species leaked depended on +category slot order — exactly what the destination swap changes. Consistent +with every observation: onset where two categories first coexist, flips in +ice moments only (incl. the lone pure-zitot onset record), immune to all +four §3 order-invariance switches. FIX: per-category `f1pr16_s(nCat)` array +saved inside each category's own lookup block (-1 sentinel = no lookup this +step); `iice_loop2` consumes `f1pr16_s(iice)` and keeps `mu_i_initial` +when the category's lookup did not run. Affects all 3-moment nCat>1 runs +(physics fix, not just bit-reproducibility). Trap-hunt should CONTINUE +after this fix (rebuild debug, rerun) until the bracket runs clean, then +rerun the swap A/B with production build to confirm the onset moves. +Two benign latent bugs also found and fixed by the trap: 0/0 in +`diag_effi_ave` at ice-free points (wrapper), and a non-short-circuit +`qiliq/qitot` 0/0 in the zidep conditional. + +**Where things stand (superseded by the above):** mechanism was narrowed via +elimination; full evidence chain in "RESOLVED" and "Follow-up" sections +below. - Swap divergence originates INSIDE `p3_main` (host dynamics cleared; PRE checksums and `w`/`p` clean at onset). Entry clipping pass also CLEARED diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 492a8b0..3172cf6 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -2601,6 +2601,13 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real :: mu_i !shape parameter for ice real :: mu_i_new !shape parameter for processes that specify mu_i real, dimension(nCat) :: dumm0,dumm3,mu_i_s + real, dimension(nCat) :: f1pr16_s ! per-category copy of f1pr16 (mass-weighted mean density) from + ! THIS category's lookup this step; -1 = lookup not accessed. + ! Fixes stale-scalar bug: iice_loop2 formerly read the plain + ! scalar f1pr16, i.e. the density of whichever category last + ! ran the lookup in iice_loop1 (wrong species for all others, + ! and dependent on category slot order -- the seed of the + ! category-swap divergence; found by the p3_nanpoison FP trap) ! add integers for mu_i index integer :: imu @@ -3141,6 +3148,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_loop1: do iice = 1,nCat Eii_fact(iice) = 1.0 ! DTD: set default value of ice-ice collection efficiency factor to 1.0 to avoid potential stale value issue + f1pr16_s(iice) = -1. ! no lookup accessed for this category yet this step (see declaration) if (log_nanpoison) then !--- stale-state hunt (see log_nanpoison declaration): poison the @@ -3330,6 +3338,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif !if log_3momentIce + ! save this category's mean density for consumers outside iice_loop1 + ! (f1pr16 itself is a scalar and only retains the LAST category's value) + f1pr16_s(iice) = f1pr16 + ! Compute ice diameter (volume equivalent -- for multi-cat) diam_ice(i,k,iice) = ((qitot(i,k,iice)*6.)/(nitot(i,k,iice)*f1pr16*pi))**thrd @@ -5116,10 +5128,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi mu_i_s(iice)=mu_i_initial - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nsmall check + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall & + .and. f1pr16_s(iice).gt.0.) then ! DTD added nsmall check + ! f1pr16_s check: use THIS category's density from its own lookup + ! this step; if the lookup did not run, keep mu_i_initial rather + ! than consuming another category's stale density (former bug) dumqi=qitot(i,k,iice) dumni=nitot(i,k,iice) - dumden=f1pr16 + dumden=f1pr16_s(iice) dum1 = dumqi*6./(dumden*pi) mu_i = compute_mu_3moment(dumni,dum1,zitot(i,k,iice),mu_i_max) From 31fafbd785bf1ababd80dc23f7fa0d44209d6cd7 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 20 Jul 2026 13:19:50 -0400 Subject: [PATCH 11/25] Record clean p3_nanpoison rerun: stale f1pr16 was the only trap Co-Authored-By: Claude Fable 5 --- NOTES.md | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/NOTES.md b/NOTES.md index 36efdf6..7702323 100644 --- a/NOTES.md +++ b/NOTES.md @@ -23,9 +23,12 @@ four §3 order-invariance switches. FIX: per-category `f1pr16_s(nCat)` array saved inside each category's own lookup block (-1 sentinel = no lookup this step); `iice_loop2` consumes `f1pr16_s(iice)` and keeps `mu_i_initial` when the category's lookup did not run. Affects all 3-moment nCat>1 runs -(physics fix, not just bit-reproducibility). Trap-hunt should CONTINUE -after this fix (rebuild debug, rerun) until the bracket runs clean, then -rerun the swap A/B with production build to confirm the onset moves. +(physics fix, not just bit-reproducibility). **Trap-hunt COMPLETE: the post-fix rerun traps nothing** — the full +poisoned set (f1pr01–38, lookup weights/indices, rhop, mu_i) has exactly +one stale consumer, now fixed. Next: confirmation swap A/B with the +production build (debug flags reverted, p3_nanpoison off, dp switches off) +— expect the t=175 onset to disappear, with any later first divergence +attributable to the §3 sums at real-coexistence points. Two benign latent bugs also found and fixed by the trap: 0/0 in `diag_effi_ave` at ice-free points (wrapper), and a non-short-circuit `qiliq/qitot` 0/0 in the zidep conditional. From a9e23eaa37f4805247dc1492a08c542d9c61cef8 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 20 Jul 2026 14:21:32 -0400 Subject: [PATCH 12/25] Close the category-swap investigation; spec the tendency-application restructure Confirmation runs complete the empirical hierarchy: (1) stale f1pr16 bug (fixed) was the dominant seed; (2) with it fixed, the category-sum reductions seed at first coexistence (suppressed by the dp switches); (3) with those invariant too, the onset finally moves (t=175 -> t=176) and lands as a lone-qr flip -- the iice_loop3 sequential shared-field update fingerprint, the remaining inherent floor. NOTES.md now carries the closed investigation record, the upstream-reportable bug list, and a NEXT PROJECT spec (scope, approach, acceptance tests, opening prompt) for implementing permutation-invariant tendency application in a fresh session. Co-Authored-By: Claude Fable 5 --- NOTES.md | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 71 insertions(+), 4 deletions(-) diff --git a/NOTES.md b/NOTES.md index 7702323..8ddc100 100644 --- a/NOTES.md +++ b/NOTES.md @@ -25,10 +25,77 @@ step); `iice_loop2` consumes `f1pr16_s(iice)` and keeps `mu_i_initial` when the category's lookup did not run. Affects all 3-moment nCat>1 runs (physics fix, not just bit-reproducibility). **Trap-hunt COMPLETE: the post-fix rerun traps nothing** — the full poisoned set (f1pr01–38, lookup weights/indices, rhop, mu_i) has exactly -one stale consumer, now fixed. Next: confirmation swap A/B with the -production build (debug flags reverted, p3_nanpoison off, dp switches off) -— expect the t=175 onset to disappear, with any later first divergence -attributable to the §3 sums at real-coexistence points. +one stale consumer, now fixed. + +**CONFIRMATION RUNS (2026-07-20) — INVESTIGATION CLOSED:** + +1. *Fix only, all switches off:* onset still itimestep=175 (physics-pinned: + first coexistence of the swapped slots' contents) but at a DIFFERENT + point with a different, sparser signature — (49,19,32), fields + `qitot_1 zitot_1 zitot_4` (zitot-first = finest-ulp fields; magnitude + masking). Old seed gone; new seed = the §3 category-sum reductions, + as predicted. +2. *Fix + all four dp switches:* onset MOVED for the first time — t=176, + lone `qr` POST flip at (46,22,23) in the riming levels, PRE clean. + Lone-shared-field flip = the fingerprint of the `iice_loop3` sequential + per-category shared-field updates (the audit's "largest §3 contributor", + deliberately unswitched). + +**Final mechanism hierarchy of the category-swap divergence** (each layer +isolated empirically by eliminating the one above it): +1. Stale `f1pr16` scalar in iice_loop2's 3-moment mu_i computation — + GENUINE BUG, fixed (commit 32f7eb6). Affects the physics of all + 3-moment nCat>1 runs. Report upstream. +2. Category-sum reductions (`epsi_tot`, conservation-limiter sums, + `sum(nitot)` in dep. nucleation, entry-clip accumulation) — inherent + roundoff; suppressible via p3_clipdp/epsdp/limdp/nucdp. +3. Sequential per-category updates of shared fields (`iice_loop3`, + post-update clip loops) — inherent roundoff; the remaining floor. + +**Upstream-reportable finds from this investigation:** (a) the stale +f1pr16/mu_i bug; (b) `iparamice_in` silently overwritten by the default in +p3_init; (c) 0/0 NaNs in `diag_effi_ave` at ice-free points (wrapper); +(d) 0/0 in the zidep compound conditional (non-short-circuiting .and.). + +--- + +## NEXT PROJECT — permutation-invariant tendency application (fresh session) + +Goal: audit §4 option (c) — restructure so per-category tendencies are +applied to shared fields in ONE fused, category-order-invariant update per +grid point, making p3_main bit-identical under category relabeling (given +the diagnostic switches' sites are also made invariant permanently). + +Scope (in module_mp_p3.F, p3_main): +- `iice_loop3` (~line 5155): qc/nc/qr/nr/qv/th each updated once per + category in slot order → accumulate all per-category increments (they + are already computed into per-category rate arrays) in double precision + and apply each shared field once after the loop. This is the main item. +- The post-update clipping loops after iice_loop3 (liquid-fraction shed + clip, small-value clip, final-diagnostics clip near end of p3_main) — + same qv/th sequential-accumulation pattern as the entry clip. +- Decide the fate of the diagnostic switches: recommend converting + p3_clipdp/epsdp/limdp/nucdp code paths into the permanent (always-on) + implementation and retiring the namelist switches, so invariance is not + config-dependent. (Formal invariance would need value-sorted sums — + audit option (b); dp-accumulate-round-once is the pragmatic standard.) +- NOT in scope: host-side sums (qsum_invariant switch already exists), + per-category-independent code (sedimentation per category, lookups). + +Acceptance tests (all tooling in repo root, conventions in HANDOFF above): +1. No-swap pair (identical namelists) still bit-identical every step + (p3_chksum diff clean). +2. Swap pair with restructured code: NO divergence originating in p3_main + (PRE lines may eventually diverge via the host unless + qsum_invariant=.true.; with it on, expect bit-identity or a dramatic + onset delay). +3. Physics sanity: no-swap run vs pre-restructure run differs only at + roundoff (solutions statistically indistinguishable). + +Suggested opening prompt for the new session: +> Read NOTES.md (HANDOFF and "NEXT PROJECT" sections) and +> p3_category_swap_audit.md §3-4. Implement the permutation-invariant +> tendency application described in NEXT PROJECT. Two benign latent bugs also found and fixed by the trap: 0/0 in `diag_effi_ave` at ice-free points (wrapper), and a non-short-circuit `qiliq/qitot` 0/0 in the zidep conditional. From ad03ca78b823399deb5afc221a104ebb3a021ba1 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 20 Jul 2026 14:22:34 -0400 Subject: [PATCH 13/25] Restore production MPI build configuration after the trap-hunt debug builds Co-Authored-By: Claude Fable 5 --- src/Makefile | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Makefile b/src/Makefile index f5daf08..f52e3d0 100644 --- a/src/Makefile +++ b/src/Makefile @@ -76,16 +76,16 @@ LINKOPTS = -lnetcdf -lnetcdff #OMP = -DOPENMP #----------------------------------------------------------------------------- # single processor, GNU compiler -FC = gfortran -# OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -OPTS = -ffree-form -ffree-line-length-none -O0 -g -ffpe-trap=invalid -fcheck=bounds -CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding +# FC = gfortran +# # OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions +# OPTS = -ffree-form -ffree-line-length-none -O0 -g -ffpe-trap=invalid -fcheck=bounds +# CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding #----------------------------------------------------------------------------- # multiple processors, distributed memory (MPI), GNU compiler -# FC = mpif90 -# OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -# CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding -# DM = -DMPI +FC = mpif90 +OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions +CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding +DM = -DMPI # multiple processors, distributed memory (MPI), GNU compiler, double precision # DTD TODO: this doesn't seem to work on my Macbook at least. Run stalls somewhere before starting # the main time loop. From 11300ba65d36ac84fa1b91f1d8e1ca84510355d8 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 20 Jul 2026 20:05:34 -0400 Subject: [PATCH 14/25] Achieve P3 category-swap bit-identity; remove diagnostic switches MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Swapping ice-category destinations (cats 3<->4) now produces bit-identical results (swap pair identical every step through t=200, matching the no-swap control). Completes the permutation-invariance program by eliminating the remaining fixed-slot-order category reductions: - module_mp_p3.F: §4(c) restructure of p3_main -- iice_loop3 shared-field tendencies (qc/nc/qr/nr/qv/th) and the post-loop3 clip loops now accumulate per-category increments in double precision and apply once; the former clipdp/epsdp/limdp/nucdp double-precision paths are made permanent (unconditional). Ice-ice interaction transfers + clip/densify restructured to be invariant-ready (exact no-op while disabled). - turb.F (calcnm): total-water qt sum made category-order-invariant via sortsumq (host turbulence seed: qt -> thv -> N^2 -> subgrid TKE -> khh/khv -> tendency). - module_mp_p3.F: Hallett-Mossop nimul/qrmul accumulation into the (swapped) destination category now summed in double precision, applied once. Cleanup: removed the obsolete diagnostic switches p3_clipdp/epsdp/limdp/nucdp (now permanent) and p3_nanpoison (stale-state hunt complete) from module_mp_p3.F, param.F and run/namelist.input. Kept qsum_invariant and the p3_chksum/p3_chkpts checksum instrumentation. All temporary debug probes removed. Requires qsum_invariant=.true. for full host-side invariance. Full seed list, upstream-reportable bugs, and the divergence-diagnosis workflow are recorded in NOTES.md. Co-Authored-By: Claude Opus 4.8 --- NOTES.md | 192 +++++++++++++++++++++ run/namelist.input | 5 - src/module_mp_p3.F | 421 ++++++++++++++++++++++----------------------- src/param.F | 24 +-- src/turb.F | 51 ++++-- 5 files changed, 437 insertions(+), 256 deletions(-) diff --git a/NOTES.md b/NOTES.md index 8ddc100..faf068a 100644 --- a/NOTES.md +++ b/NOTES.md @@ -59,8 +59,200 @@ p3_init; (c) 0/0 NaNs in `diag_effi_ave` at ice-free points (wrapper); --- +## SWAP-DIVERGENCE SEED #2 — turbulence total-water sum (FOUND & FIXED, 2026-07-20) + +After the §4(c) restructure below AND `qsum_invariant=.true.`, a swap pair (cats +3↔4, IOP12 ptype-57, 8 ranks) still diverged — but far later (first divergence +t=179 vs the old t=175) and in a single field: **`birim_3` (rime volume)** on a +PRE line, host-side, at coexistence onset. A long instrumented bisection (temp +debug in solve1/solve2, since removed) walked it down: + +- first divergence is a ~1-ULP difference in `qten(birim)` (the subgrid + turbulence tendency), NOT advection — `advs` was transparent; +- with the full birim field column bit-identical and `rho`/`rr` clean, the + differing input was the **eddy diffusivity `khh`/`khv`** at the point (dumped + directly: `khh(26)`,`khv(26)`,`dum7(26)` differed ~1–2 ULP; `rho`,`rr`, + `khh(27)`,`khv(27)` identical); +- config is `cm1setup=1` LES, `sgsmodel=1` (prognostic-TKE closure), so + `kmh=cme·√tk·lenscl` and the diffusivity rides on the subgrid TKE, whose + buoyancy production uses N² from `calcnm`. + +**ROOT CAUSE:** `calcnm` (turb.F ~5026) built total water `qt` with a **raw +slot-order sum** `do n: qt=qt+qa(...,n)` over `nqv + nql1:nql2 + nqs1:nqs2`. The +solid range `nqs1:nqs2 = 4:7` is the four ice masses; the swap exchanges the +*contents* of slots 6/7, so the fixed-order FP sum differs by 1 ULP → +`qt`→`thv`→`nm`(N²)→TKE→`khh/khv`→`turbs`→`qten(birim)`→divergence. This is the +SAME class `qsum_invariant` fixes, but a **second, independent moisture sum the +prior agent's conversion missed** — it had only converted the turb *driver*'s +`dum7 = Σql+Σqi` (turb.F 432–488), not `calcnm`'s own `qt`. + +Explains every observation: it's the diffusivity (not density); at k=26 (ice +level); at t=179 (first coexistence of the swapped ice masses — before that one +slot is 0 and order is moot); birim is just the canary (smallest field reveals +the ~1-ULP diffusivity error first while qitot's larger `qten` masks it). + +**FIX (turb.F, calcnm ~5026):** `qt` now uses `sortsumq` for the liquid and +solid ranges when `qsum_invariant` (matching the `dum7` treatment): `qt = qa(nqv) ++ sortsumq(qa(nql1:nql2)) + sortsumq(qa(nqs1:nqs2))`, guarded `if(nql1.gt.0)` / +`if(nqs1.gt.0 .and. iice.eq.1)`; raw loop retained for `qsum_invariant=.false.`. +Compiles + links clean. **To verify: rerun the swap pair** (with +`qsum_invariant=.true.`) — expect the t=179 birim divergence to vanish and the +pair to go bit-identical (or onset to jump dramatically later, exposing the next +seed if any). All temporary solve1/solve2 debug probes have been removed. + +**RESULT of the calcnm fix (verified):** the t=179 `birim_3` seed is GONE. +Onset moved to **t=185 POST, `nitot_4`** (back inside p3_main), PRE trailing at +t=186 — i.e. host turbulence cleared, next seed is microphysics-internal. + +## SWAP-DIVERGENCE SEED #3 — Hallett-Mossop accumulation (FOUND & FIXED) + +The t=185 `nitot_4` POST seed is the **Hallett-Mossop rime-splintering** block +(module_mp_p3.F `iice_loop_HM`, ~line 4020): it loops over SOURCE categories and +accumulates splinter production into the fixed destination slot in slot order — +`qrmul(iice_dest)=qrmul(iice_dest)+dum2` / `nimul(iice_dest)=…+dum1`. `iice_dest` +is `catdest_rimesplinter_n4` = cat 4 (runA) / cat 3 (runB, swapped), and the +source cats 3/4 contributions are exchanged by the swap, so the fixed-order FP +sum differs by 1 ULP. `nimul` feeds `nitot` (iice_loop3) → `nitot(iice_dest)` +diverges = `nitot_4`(A)/`nitot_3`(B). Same category-sum class; my §4(c) +restructure missed it because it accumulates into a *destination* index, not a +shared field. **FIX:** accumulate `qrmul_dp`/`nimul_dp` in double precision over +the source loop, apply to `iice_dest` once after (always-on). Compiles + links +clean. + +## RESULT — BIT-IDENTITY ACHIEVED (2026-07-20) + +After the HM fix, the swap pair (cats 3↔4, `qsum_invariant=.true.`) is +**bit-identical every step out to t=200** (as far as run). Combined with the +earlier no-swap control (also bit-identical), both acceptance tests #1 and #2 +pass. The full set of category-relabeling seeds, peeled in order: +1. stale `f1pr16` scalar in iice_loop2 (genuine physics bug) — prior session. +2. §3 in-scheme category sums + sequential shared-field updates — §4(c) + restructure of `iice_loop3` + clip loops; `clipdp/epsdp/limdp/nucdp` made + permanent (this session, module_mp_p3.F). +3. host buoyancy/theta_rho sums — `qsum_invariant` (prior session). +4. host turbulence total water `qt` in `calcnm` (turb.F) — this session. +5. Hallett-Mossop `nimul`/`qrmul` accumulation into `iice_dest` (module_mp_p3.F) + — this session. + +Each is an FP-non-associative category reduction; the fix pattern throughout is +double-precision accumulate + round once (or value-sorted `sortsumq` host-side). +**Upstream-reportable order-dependencies found:** the stale `f1pr16`/mu_i bug +(#1), the `calcnm` qt sum (#4), and the HM destination accumulation (#5). + +Remaining (not needed for this config, would matter elsewhere): `compute_SCPF` +`sum(Qitot)` if SCPF active; `sum(qlcon)/sum(qlevp)` liqFrac satadj lines; +diagnostic-only host sums (statpack/writeout/etc.). Ice-ice interaction is +restructured to be invariant-ready but remains disabled by default. + +## SESSION WRAP-UP / HANDOFF (2026-07-20) + +**Diagnostic switches removed** (committed cleanup): `p3_clipdp / p3_epsdp / +p3_limdp / p3_nucdp` (their dp paths are now permanent/unconditional) and +`p3_nanpoison` (stale-state hunt complete) — deleted from `module_mp_p3.F`, +`param.F` (decl / `use` / namelist group / MPI_BCAST / assignment) and +`run/namelist.input`. **KEPT:** `qsum_invariant` (needed for host-side +invariance; runtime default still `.false.` in namelist — set `.true.` for +invariant/swap runs) and the `p3_chksum` / `p3_chkpts` checksum + per-point-dump +instrumentation (+ `compare_p3_chksum.py`, `decode_point.sh`) for future +divergence hunts. + +**Physics-sanity check (acceptance test #3) — DEFERRED, do later if wanted:** +build a pre-restructure binary from commit `ad03ca7`, run one no-swap case each +(this-branch vs pre-restructure), confirm they differ only at roundoff. Verifies +the dp-restructuring didn't change the science. Not done this session. + +**If swap divergence returns (e.g. when you enable `log_iceice_interaction`):** +the method that worked, in order — +1. `p3_chksum=.true.` both runs, `compare_p3_chksum.py runA runB --swap 3 4` → + first divergent timestep/tag/field. PRE-first = host-side; POST-first = + inside p3_main. +2. `p3_chkpts=.true.` on a short restart bracket around that step → + `--pattern 'p3_chkpts_*.out'` → exact (i,j,k)+field. `decode_point.sh` to see + magnitudes (1 ULP = roundoff/order-dependence). +3. If it's a tendency (not a field) that first differs, instrument the tendency + array at that global point and walk it *backwards* through its contributors + /coefficients until you hit the array that differs — that names the guilty + reduction (this is how the `calcnm` khh/khv seed was found; temp probes went + in solve1/solve2, all since removed). +4. The fix is almost always: replace a fixed-slot-order category sum with a + double-precision accumulate-then-round, or host-side `sortsumq`. + +For **ice-ice interaction specifically**: the `iice_loop3` cross-category +transfer + clip/densify is already restructured to dp-accumulate (invariant- +ready, exact no-op while disabled), and the two conservation-limiter `qicol` +`sources`/`sinks` sums were made dp. If divergence still appears with it on, the +prime suspects are any remaining `qicol`/`nicol` category sums or the `icecat_ +destination` selection — start the checksum bisection there. + +--- + ## NEXT PROJECT — permutation-invariant tendency application (fresh session) +**IMPLEMENTED (2026-07-20, Claude Code):** the §4(c) restructure below is done +in `src/module_mp_p3.F` (compiles + links clean with the production +`-O2 -finline-functions` MPI build). What changed: + +- **`iice_loop3` (main item, ~line 5141):** the six SHARED prognostic fields + updated once per category in slot order — `qc, nc, qr, nr, qv, th` — are now + accumulated over ice categories in double precision (`dqc_dp … dth_dp`, new + declarations near line 2524) and applied to each field ONCE after the loop + (`field = sngl(dble(field) + dfield_dp)`). Each category's increment is still + formed in single precision exactly as before, so only the cross-category + accumulation changed → result is now independent of category slot order. The + per-category array fields (`qitot/qirim/birim/qiliq/nitot`, and the disabled + ice-ice interaction block) are slot-local and stayed in the loop. Verified no + statement reads any of the six shared fields mid-loop, so deferral is a + roundoff-level change only. +- **Post-`iice_loop3` clip loops:** same dp-accumulate-apply-once treatment for + (a) the liquid-fraction shed clip (`clipsum_qr/nr/th`), (b) the small-value + clip (`clipsum_qv/th`), and (c) the ice clip in `iice_loop_final_diagnostics` + (`clipsum_qv/th`, applied right after the loop). The non-per-category qc/qr + single clips between them were already order-independent and left as-is. +- **Diagnostic switches `p3_clipdp/epsdp/limdp/nucdp` made PERMANENT:** every + `if (log_*dp) … else … endif` in `p3_main` was collapsed to the + double-precision (invariant) branch unconditionally — entry clip, epsi_tot/ + epsiw_tot accumulation, all five conservation-limiter sums, and the + `sum(nitot)` in deposition nucleation. Per the user's decision, the four + `log_*dp` module vars + their `param.F`/`namelist.input` plumbing are KEPT as + **readable no-ops** (documented at the declarations, ~line 89) so existing + namelists still load; setting them now has no effect. Full retirement (delete + from `param.F` + `namelist.input`) deferred until run-dir namelists are cleaned. + +- **Ice-ice interaction block made READY for invariance (2026-07-20, currently + still disabled via `log_iceice_interaction=.false.`):** the cross-category + collection transfers inside `iice_loop3` used to update `qitot/qirim/birim/ + qiliq/nitot` of both collector and collectee in slot order, and the + per-category clipping (`qirim<0`) and wet-growth/melt densification ran + mid-loop on *partially*-transferred fields — an order dependence that is NOT + just roundoff. Restructured so the transfers accumulate into per-category + double-precision accumulators (`qitot_col_dp … nitot_col_dp`, dimension nCat), + applied once after the loop, and the clipping/densification moved to a single + post-loop pass over categories that sees the fully-accumulated fields. Also + made the two conservation-limiter `qicol`/`nicol` `catcoll` sums (the "ice" + and "qiliq" `sources`/`sinks` blocks) double-precision. **All of these are + exact no-ops when `log_iceice_interaction=.false.`** (every `*_col_dp` and the + `qicol` sums are zero, and `sngl(dble(x)+0.d0)==x`), so the current + ice-off runs are byte-identical to before this change; when interaction is + enabled they are category-order-invariant. The `qicol/nicol` rates themselves + are computed per category-pair (slot-covariant), so no change was needed + there. Runtime default left disabled per request. + +Residual (deliberately out of scope, per the plan): host-side sums (covered by +`qsum_invariant`); the `sum(qlcon)/sum(qlevp)` in the qv_tmp/t_tmp +saturation-adjustment lines (liqFrac-only, identically zero in this config — +not part of the `log_limdp` coverage that was converted); `ze_ice` reflectivity +accumulation in the final-diagnostics loop (diagnostic output only, not +prognostic); the ice-ice interaction cross-category updates (feature disabled). +Any one surviving order-sensitive prognostic reduction would still eventually +diverge — these are believed inert for the swap config but should be confirmed +by the acceptance tests before declaring bit-identity. + +**Not yet run:** the three acceptance tests below (no-swap identity, swap +no-p3_main-divergence, physics-sanity vs pre-restructure). Build the pre-change +binary from git (commit `ad03ca7`) for test 3. + +--- + Goal: audit §4 option (c) — restructure so per-category tendencies are applied to shared fields in ONE fused, category-order-invariant update per grid point, making p3_main bit-identical under category relabeling (given diff --git a/run/namelist.input b/run/namelist.input index be16072..eb0f783 100644 --- a/run/namelist.input +++ b/run/namelist.input @@ -456,11 +456,6 @@ p3_cat_init_new = .true., p3_chksum = .false., p3_chkpts = .false., - p3_clipdp = .false., - p3_epsdp = .false., - p3_limdp = .false., - p3_nucdp = .false., - p3_nanpoison = .false., qsum_invariant = .false., log_nislf = .true., log_iceice_interaction = .true., diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 3172cf6..45c98e6 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -86,51 +86,6 @@ MODULE microphy_p3 integer, save :: chkpts_unit = -1 logical, save :: chkpts_opened = .false. -! Category-swap diagnostic switch (host namelist option p3_clipdp): when -! .true., the entry clipping pass of p3_main accumulates its per-category -! qv/theta increments in double precision and applies them once after the -! category loop, making the clip (practically) invariant to which slot holds -! which value. Used to test whether the clip is the first divergence seed in -! a category-swap experiment: if the first divergence moves later or to a -! different site with this enabled in both runs, the clip was the seed. -! Note: changes results at roundoff level relative to the default path. - logical, public, save :: log_clipdp = .false. - -! Companion switches for the same A/B seed-isolation protocol (host namelist -! options p3_epsdp / p3_limdp): category-order-invariant (double-precision) -! evaluation of, respectively, the epsi_tot/epsiw_tot accumulation over ice -! categories (supersaturation relaxation timescale) and the conservation- -! limiter category sums (the sum(qidep)/sum(qisub)/sinks-sources blocks). -! Enable ONE at a time in BOTH members of a swap pair: whichever switch -! delays/moves the first divergence identifies the seeding reduction. -! Same caveats as log_clipdp (practically, not formally, invariant; changes -! results at roundoff level). - logical, public, save :: log_epsdp = .false. - logical, public, save :: log_limdp = .false. -! p3_nucdp: category-order-invariant sum(nitot) in deposition nucleation -! (N_nuc/Q_nuc); computed once in double precision. NOTE: single-switch -! A/B runs cannot isolate the seed if multiple reductions flip the same -! points -- the decisive test is ALL log_*dp switches enabled together in -! both members of a swap pair. - logical, public, save :: log_nucdp = .false. - -! p3_nanpoison: stale-state hunt (audit sec. 2 class). When .true., all -! per-category work variables (f1pr* lookup values, lookup-table indices and -! interpolation weights, rhop, mu_i) are poisoned at the top of EVERY -! iice_loop1 iteration: reals with a signaling NaN, integer indices with a -! huge sentinel. Any consumption before being set in that same category -! iteration then traps, identifying a slot-order-dependent stale path. -! Build requirements: -ffpe-trap=invalid -fcheck=bounds -g -O0 and run -! serially under a debugger (on macOS/arm64 the gfortran trap handler loops -! instead of terminating, but lldb stops at the exact line: lldb -- ./cm1.exe -! then 'run'; each stop shows file:line; 'process continue' to resume past -! stops judged benign). Deliberate per-iteration defaults (Eii_fact, tmp1) -! are NOT poisoned. A single run suffices (no A/B): the stale path executes -! regardless of the category-destination namelist. - logical, public, save :: log_nanpoison = .false. - real, save :: snan_r4 = 0. ! signaling NaN; set in p3_init - integer, parameter :: int_poison = -2000000000 ! index poison (traps via -fcheck=bounds) - ! ice microphysics lookup table array dimensions integer, parameter :: isize = 50 integer, parameter :: iisize = 25 @@ -327,10 +282,6 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err n_iceCat = nCat !used for GEM interface -! signaling NaN for the p3_nanpoison stale-state hunt (bit pattern via -! transfer: no floating-point operation, so this never traps itself) - snan_r4 = transfer(int(z'7FA00000',kind=4),1.0) - ! mathematical/optimization constants pi = 3.14159265 !pi = acos(-1.) @@ -2518,9 +2469,23 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi timeScaleFactor,dt_left,qv_tmp,t_tmp,dum1z,dum7c,dum7,fluxdiv_qil,epsiw_tot double precision :: tmpdbl1,tmpdbl2,tmpdbl3 - double precision :: clipsum_qv,clipsum_th ! category-order-invariant entry clipping (log_clipdp) - double precision :: epsi_totdp,epsiw_totdp ! category-order-invariant epsi accumulation (log_epsdp) - double precision :: nitotsum_dp ! category-order-invariant sum(nitot) in dep. nucleation (log_nucdp) + double precision :: clipsum_qv,clipsum_th ! category-order-invariant entry clipping (permanent) + double precision :: epsi_totdp,epsiw_totdp ! category-order-invariant epsi accumulation (permanent) + double precision :: nitotsum_dp ! category-order-invariant sum(nitot) in dep. nucleation (permanent) + ! category-order-invariant (permutation-invariant) fused tendency application: + ! per-category increments to the SHARED prognostic fields are accumulated over + ! ice categories in double precision inside the category loop, then applied to + ! each shared field once (rounded once) after the loop, so the result is + ! independent of which slot holds which species (NEXT PROJECT / audit sec. 4(c)). + double precision :: dqc_dp,dnc_dp,dqr_dp,dnr_dp,dqv_dp,dth_dp ! iice_loop3 shared-field tendencies + double precision :: clipsum_qr,clipsum_nr ! post-loop3 liquid-fraction shed clip (qr/nr/th deferred) + double precision :: nimul_dp,qrmul_dp ! category-order-invariant Hallett-Mossop accumulation into iice_dest + ! deferred ice-ice interaction cross-category contributions to the per-category + ! ice fields, accumulated in double precision so the result is invariant to + ! category slot order (applied once, after iice_loop3, before the per-category + ! clipping/densification). All zero when log_iceice_interaction=.false., in + ! which case the application is an exact no-op (behavior identical to before). + double precision, dimension(nCat) :: qitot_col_dp,qirim_col_dp,birim_col_dp,qiliq_col_dp,nitot_col_dp ! ERM begin integer, parameter :: dmrauto = 0 @@ -2607,7 +2572,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! scalar f1pr16, i.e. the density of whichever category last ! ran the lookup in iice_loop1 (wrong species for all others, ! and dependent on category slot order -- the seed of the - ! category-swap divergence; found by the p3_nanpoison FP trap) + ! category-swap divergence; found by an FP-trap stale-state hunt) ! add integers for mu_i index integer :: imu @@ -2900,19 +2865,13 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi do iice = 1,nCat if (qitot(i,k,iice).lt.qsmall .or. nitot(i,k,iice).lt.nsmall .or. (qitot(i,k,iice).lt.1.e-12 .and. & supi(i,k).lt.-0.1)) then ! Note that ERM removed second sup criterion for testing. May try later - if (log_clipdp) then - ! category-order-invariant variant (see log_clipdp declaration): + ! category-order-invariant (permanent): ! defer the qv/th increments; accumulated in double precision and ! applied once after this loop clipsum_qv = clipsum_qv + dble(qitot(i,k,iice)) clipsum_th = clipsum_th & - dble(invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp) & - dble(invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp) - else - qv(i,k) = qv(i,k) + qitot(i,k,iice) - th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp - th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp - endif qitot(i,k,iice) = 0. nitot(i,k,iice) = 0. qirim(i,k,iice) = 0. @@ -2951,13 +2910,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo !iice-loop - if (log_clipdp) then - ! apply the deferred clipping increments in one rounded update each - ! (before the q_old conservation diagnostic below, which must see - ! the clipped qv) - qv(i,k) = sngl(dble(qv(i,k)) + clipsum_qv) - th(i,k) = sngl(dble(th(i,k)) + clipsum_th) - endif + ! apply the deferred clipping increments in one rounded update each + ! (before the q_old conservation diagnostic below, which must see + ! the clipped qv) + qv(i,k) = sngl(dble(qv(i,k)) + clipsum_qv) + th(i,k) = sngl(dble(th(i,k)) + clipsum_th) ! ERM begin q_old(i,k) = qv(i,k) + qc(i,k) + qr(i,k) + Sum( qitot(i,k,1:nCat) ) @@ -3141,7 +3098,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! initialize inverse supersaturation relaxation timescale for combined ice categories epsi_tot = 0. epsiw_tot = 0. - epsi_totdp = 0.d0 ! (only used when log_epsdp) + epsi_totdp = 0.d0 ! category-order-invariant epsi accumulation (permanent) epsiw_totdp = 0.d0 ! DTD: turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) @@ -3150,27 +3107,6 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi Eii_fact(iice) = 1.0 ! DTD: set default value of ice-ice collection efficiency factor to 1.0 to avoid potential stale value issue f1pr16_s(iice) = -1. ! no lookup accessed for this category yet this step (see declaration) - if (log_nanpoison) then - !--- stale-state hunt (see log_nanpoison declaration): poison the - ! per-category work variables; any consumption before being set - ! in THIS category iteration traps (reals via -ffpe-trap=invalid, - ! integer table indices via -fcheck=bounds) - f1pr01 = snan_r4; f1pr02 = snan_r4; f1pr03 = snan_r4; f1pr04 = snan_r4 - f1pr05 = snan_r4; f1pr06 = snan_r4; f1pr07 = snan_r4; f1pr08 = snan_r4 - f1pr09 = snan_r4; f1pr10 = snan_r4; f1pr13 = snan_r4; f1pr14 = snan_r4 - f1pr15 = snan_r4; f1pr16 = snan_r4; f1pr17 = snan_r4; f1pr18 = snan_r4 - f1pr19 = snan_r4; f1pr22 = snan_r4; f1pr23 = snan_r4; f1pr24 = snan_r4 - f1pr25 = snan_r4; f1pr26 = snan_r4; f1pr27 = snan_r4; f1pr28 = snan_r4 - f1pr29 = snan_r4; f1pr30 = snan_r4; f1pr31 = snan_r4; f1pr32 = snan_r4 - f1pr33 = snan_r4; f1pr34 = snan_r4; f1pr35 = snan_r4; f1pr36 = snan_r4 - f1pr37 = snan_r4; f1pr38 = snan_r4 - dum1 = snan_r4; dum3 = snan_r4; dum4 = snan_r4; dum5 = snan_r4 - dum6 = snan_r4; dum7 = snan_r4 - rhop = snan_r4; mu_i = snan_r4 - dumi = int_poison; dumj = int_poison; dumii = int_poison - dumjj = int_poison; dumll = int_poison; dumzz = int_poison - endif - qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check ! DTD changed to .ge. from > to ensure case where nitot = nsmall is included !impose lower limits to prevent taking log of # < 0 @@ -3722,21 +3658,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if ((qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then epsi(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* & rho(i,k)*dv)*nitot(i,k,iice) - if (log_epsdp) then - ! category-order-invariant variant (see log_epsdp declaration) - epsi_totdp = epsi_totdp + dble(epsi(iice)) - else - epsi_tot = epsi_tot + epsi(iice) - endif + ! category-order-invariant (permanent; category-order-invariant) + epsi_totdp = epsi_totdp + dble(epsi(iice)) epsiw(iice) = 0. else epsiw(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* & rho(i,k)*dv)*nitot(i,k,iice) - if (log_epsdp) then - epsiw_totdp = epsiw_totdp + dble(epsiw(iice)) - else - epsiw_tot = epsiw_tot + epsiw(iice) - endif + ! category-order-invariant (permanent; category-order-invariant) + epsiw_totdp = epsiw_totdp + dble(epsiw(iice)) epsi(iice) = 0. endif @@ -3860,11 +3789,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !-------------------- enddo iice_loop1 - if (log_epsdp) then - ! apply the deferred category-order-invariant epsi accumulations - epsi_tot = sngl(epsi_totdp) - epsiw_tot = sngl(epsiw_totdp) - endif + ! apply the deferred category-order-invariant epsi accumulations + ! (permanent; category-order-invariant) + epsi_tot = sngl(epsi_totdp) + epsiw_tot = sngl(epsiw_totdp) !-------------------- if (debug_on) then @@ -4027,6 +3955,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_dest = 1 endif + ! category-order-invariant Hallett-Mossop accumulation: sum the + ! per-source-category splinter production in double precision and apply + ! it to the destination category once after the loop. iice_dest is the + ! (swapped) rimesplinter destination, so the original fixed-slot-order + ! sum over source categories was a category-relabeling roundoff seed. + qrmul_dp = 0.d0 + nimul_dp = 0.d0 + iice_loop_HM: do iice = 1,nCat ice_present: if (qitot(i,k,iice)-qiliq(i,k,iice) .ge. qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check @@ -4075,8 +4011,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum2 = qrcol(iice) + dum2 qrcol(iice) = 0. endif - qrmul(iice_dest) = qrmul(iice_dest) + dum2 - nimul(iice_dest) = nimul(iice_dest) + dum1 + qrmul_dp = qrmul_dp + dble(dum2) + nimul_dp = nimul_dp + dble(dum1) endif HM_conditions_met @@ -4084,6 +4020,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop_HM + ! apply the deferred, category-order-invariant HM accumulation once + qrmul(iice_dest) = qrmul(iice_dest) + sngl(qrmul_dp) + nimul(iice_dest) = nimul(iice_dest) + sngl(nimul_dp) + endif calc_HM @@ -4418,21 +4358,13 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! dum = 0.005*dexp(dble(0.304*(273.15-t(i,k))))*1000.*inv_rho(i,k) !Cooper (1986) dum = min(dum,100.e3*inv_rho(i,k)*SCF(k)) - if (log_nucdp) then - ! category-order-invariant variant (see log_nucdp declaration): - ! total ice number computed once, in double precision - nitotsum_dp = sum(dble(nitot(i,k,:))) - N_nuc = max(0.,(dum-sngl(nitotsum_dp))*odt) - else - N_nuc = max(0.,(dum-sum(nitot(i,k,:)))*odt) - endif + ! category-order-invariant (permanent): + ! total ice number computed once, in double precision + nitotsum_dp = sum(dble(nitot(i,k,:))) + N_nuc = max(0.,(dum-sngl(nitotsum_dp))*odt) if (N_nuc.ge.1.e-20) then - if (log_nucdp) then - Q_nuc = max(0.,(dum-sngl(nitotsum_dp))*mi0*odt) - else - Q_nuc = max(0.,(dum-sum(nitot(i,k,:)))*mi0*odt) - endif + Q_nuc = max(0.,(dum-sngl(nitotsum_dp))*mi0*odt) if (nCat>1) then !determine destination ice-phase category: if (.not. cat_init_new) then @@ -4910,12 +4842,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dumqvi = qv_sat(t_tmp,pres(i,k),1) qdep_satadj = (qv_tmp-dumqvi)/(1.+xxls(i,k)**2*dumqvi/(cp*rv*t_tmp**2))*odt*SCF(k) - if (log_limdp) then - ! category-order-invariant variant (see log_limdp declaration) - tmp1 = sngl(sum(dble(qidep))+sum(dble(qinuc))) - else - tmp1 = sum(qidep)+sum(qinuc) - endif + ! category-order-invariant (permanent; category-order-invariant) + tmp1 = sngl(sum(dble(qidep))+sum(dble(qinuc))) if (tmp1>0. .and. qdep_satadj<0.) then qidep = 0. qinuc = 0. @@ -4928,11 +4856,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qinuc = qinuc*ratio ninuc = ninuc*ratio endif - if (log_limdp) then - tmp2 = sngl(sum(dble(qisub))) - else - tmp2 = sum(qisub) ! DTD sum up qisub *before* changing individual category qisub values below - endif + ! category-order-invariant (permanent; category-order-invariant) + tmp2 = sngl(sum(dble(qisub))) ! DTD sum up qisub *before* changing individual category qisub values below do iice = 1,nCat dum = max(qisub(iice),1.e-20) ! DTD: replaced sum(qisub) with tmp2 to avoid repeated summation (and potential order-dependent results) @@ -4945,14 +4870,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! cloud - if (log_limdp) then - sinks = sngl( dble(qcaut)+dble(qcacc)+sum(dble(qccol))+dble(qcevp)+sum(dble(qchetc))+ & - sum(dble(qcheti))+sum(dble(qcshd))+sum(dble(qcmul))+ & - sum(dble(qccoll))+sum(dble(qwgrth1c)) )*dt - else - sinks = (qcaut+qcacc+sum(qccol)+qcevp+sum(qchetc)+sum(qcheti)+sum(qcshd)+sum(qcmul)+ & ! DTD: added qcmul - sum(qccoll)+sum(qwgrth1c))*dt - endif + ! category-order-invariant (permanent; category-order-invariant) + sinks = sngl( dble(qcaut)+dble(qcacc)+sum(dble(qccol))+dble(qcevp)+sum(dble(qchetc))+ & + sum(dble(qcheti))+sum(dble(qcshd))+sum(dble(qcmul))+ & + sum(dble(qccoll))+sum(dble(qwgrth1c)) )*dt sources = qc(i,k) + (qccon+qcnuc)*dt if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks @@ -4979,17 +4900,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! rain - if (log_limdp) then - sinks = sngl( dble(qrevp)+sum(dble(qrcol))+sum(dble(qrhetc))+sum(dble(qrheti))+ & - sum(dble(qrmul))+sum(dble(qrcoll))+sum(dble(qwgrth1r)) )*dt - sources = qr(i,k) + sngl( dble(qrcon)+dble(qcaut)+dble(qcacc)+sum(dble(qrmlt))+ & - sum(dble(qcshd))+sum(dble(qlshd)) )*dt - else - sinks = (qrevp+sum(qrcol)+sum(qrhetc)+sum(qrheti)+sum(qrmul)+ & - sum(qrcoll)+sum(qwgrth1r))*dt - sources = qr(i,k) + (qrcon+qcaut+qcacc+sum(qrmlt)+sum(qcshd)+ & - sum(qlshd))*dt - endif + ! category-order-invariant (permanent; category-order-invariant) + sinks = sngl( dble(qrevp)+sum(dble(qrcol))+sum(dble(qrhetc))+sum(dble(qrheti))+ & + sum(dble(qrmul))+sum(dble(qrcoll))+sum(dble(qwgrth1r)) )*dt + sources = qr(i,k) + sngl( dble(qrcon)+dble(qcaut)+dble(qcacc)+sum(dble(qrmlt))+ & + sum(dble(qcshd))+sum(dble(qlshd)) )*dt if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks qrevp = qrevp*ratio @@ -5013,13 +4928,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sources = qitot(i,k,iice) + (qidep(iice)+qinuc(iice)+qrcol(iice)+qccol(iice)+ & qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qcmul(iice)+qrmul(iice)+ & !DTD: added qcmul qrcoll(iice)+qccoll(iice)+qlcon(iice)+qwgrth1c(iice)+qwgrth1r(iice))*dt + ! category-order-invariant qicol summation (exact no-op when + ! log_iceice_interaction=.false., i.e. qicol=0) + tmpdbl1 = 0.d0 + tmpdbl2 = 0.d0 do catcoll = 1,nCat !Note: qicol = 0 if iice=catcoll, optimised to not insert an if (catcoll.ne.iice) !category interaction leading to source for iice category - sources = sources + qicol(catcoll,iice)*dt + tmpdbl1 = tmpdbl1 + dble(qicol(catcoll,iice)*dt) !category interaction leading to sink for iice category - sinks = sinks + qicol(iice,catcoll)*dt + tmpdbl2 = tmpdbl2 + dble(qicol(iice,catcoll)*dt) enddo + sources = sngl(dble(sources) + tmpdbl1) + sinks = sngl(dble(sinks) + tmpdbl2) if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks qisub(iice) = qisub(iice)*ratio @@ -5044,13 +4965,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sinks = (qifrz(iice)+qlshd(iice)+qlevp(iice))*dt sources = qiliq(i,k,iice) + (qimlt(iice)+qrcoll(iice)+qccoll(iice)+qlcon(iice)+ & qwgrth1c(iice)+qwgrth1r(iice))*dt + ! category-order-invariant qicol summation (exact no-op when + ! log_iceice_interaction=.false., i.e. qicol=0) + tmpdbl1 = 0.d0 + tmpdbl2 = 0.d0 do catcoll = 1,nCat !Note: qicol = 0 if iice=catcoll, optimised to not insert an if (catcoll.ne.iice) !category interaction leading to source for iice category - sources = sources + qicol(catcoll,iice)*dt + tmpdbl1 = tmpdbl1 + dble(qicol(catcoll,iice)*dt) !category interaction leading to sink for iice category - sinks = sinks + qicol(iice,catcoll)*dt + tmpdbl2 = tmpdbl2 + dble(qicol(iice,catcoll)*dt) enddo + sources = sngl(dble(sources) + tmpdbl1) + sinks = sngl(dble(sinks) + tmpdbl2) if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks qifrz(iice) = qifrz(iice)*ratio @@ -5068,14 +4995,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! vapor - if (log_limdp) then - sinks = sngl( dble(qccon)+dble(qrcon)+dble(qcnuc)+sum(dble(qidep))+ & - sum(dble(qinuc))+sum(dble(qlcon)) )*dt - sources = qv(i,k) + sngl( dble(qcevp)+dble(qrevp)+sum(dble(qisub))+sum(dble(qlevp)) )*dt - else - sinks = (qccon+qrcon+qcnuc+sum(qidep)+sum(qinuc)+sum(qlcon))*dt - sources = qv(i,k) + (qcevp+qrevp+sum(qisub)+sum(qlevp))*dt - endif + ! category-order-invariant (permanent; category-order-invariant) + sinks = sngl( dble(qccon)+dble(qrcon)+dble(qcnuc)+sum(dble(qidep))+ & + sum(dble(qinuc))+sum(dble(qlcon)) )*dt + sources = qv(i,k) + sngl( dble(qcevp)+dble(qrevp)+sum(dble(qisub))+sum(dble(qlevp)) )*dt if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks qccon = qccon*ratio @@ -5168,26 +5091,48 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif + ! Permutation-invariant fused tendency application (audit sec. 4(c)): + ! accumulate the per-category increments to the SHARED prognostic fields + ! (qc, nc, qr, nr, qv, th) over ice categories in double precision, then + ! apply each shared field once after the loop. The per-category array + ! fields (qitot, qirim, birim, qiliq, nitot) are slot-local and stay in + ! the loop. Each category's increment is formed in single precision + ! exactly as before, so only the cross-category accumulation changes + ! (result now independent of category slot order). + dqc_dp = 0.d0 + dnc_dp = 0.d0 + dqr_dp = 0.d0 + dnr_dp = 0.d0 + dqv_dp = 0.d0 + dth_dp = 0.d0 + ! deferred ice-ice interaction cross-category contributions (all zero, hence + ! an exact no-op, when log_iceice_interaction=.false.) + qitot_col_dp(:) = 0.d0 + qirim_col_dp(:) = 0.d0 + birim_col_dp(:) = 0.d0 + qiliq_col_dp(:) = 0.d0 + nitot_col_dp(:) = 0.d0 + iice_loop3: do iice = 1,nCat - qc(i,k) = qc(i,k) + (-qchetc(iice)-qcheti(iice)-qccol(iice)-qcshd(iice)-qcmul(iice)- & !DTD: added qcmul - qccoll(iice)-qwgrth1c(iice))*dt + dqc_dp = dqc_dp + dble((-qchetc(iice)-qcheti(iice)-qccol(iice)-qcshd(iice)-qcmul(iice)- & !DTD: added qcmul + qccoll(iice)-qwgrth1c(iice))*dt) if (log_predictNc) then - nc(i,k) = nc(i,k) + (-nccol(iice)-nchetc(iice)-ncheti(iice)-nccoll(iice))*dt + dnc_dp = dnc_dp + dble((-nccol(iice)-nchetc(iice)-ncheti(iice)-nccoll(iice))*dt) endif - qr(i,k) = qr(i,k) + (-qrcol(iice)+qrmlt(iice)-qrhetc(iice)-qrheti(iice)+ & - qcshd(iice)-qrmul(iice)-qrcoll(iice)+qlshd(iice)-qwgrth1r(iice))*dt + dqr_dp = dqr_dp + dble((-qrcol(iice)+qrmlt(iice)-qrhetc(iice)-qrheti(iice)+ & + qcshd(iice)-qrmul(iice)-qrcoll(iice)+qlshd(iice)-qwgrth1r(iice))*dt) ! apply factor to source for rain number from melting of ice, (ad-hoc ! but accounts for rapid evaporation of small melting ice particles) if (log_LiquidFrac) then - nr(i,k) = nr(i,k) + (-nrcol(iice)-nrhetc(iice)-nrheti(iice)+nimlt(iice)+ & - nrshdr(iice)+ncshdc(iice)-nrcoll(iice)+nlshd(iice))*dt + dnr_dp = dnr_dp + dble((-nrcol(iice)-nrhetc(iice)-nrheti(iice)+nimlt(iice)+ & + nrshdr(iice)+ncshdc(iice)-nrcoll(iice)+nlshd(iice))*dt) else - nr(i,k) = nr(i,k) + (-nrcol(iice)-nrhetc(iice)-nrheti(iice)+nmltratio*nimlt(iice)+ & - nrshdr(iice)+ncshdc(iice))*dt + dnr_dp = dnr_dp + dble((-nrcol(iice)-nrhetc(iice)-nrheti(iice)+nmltratio*nimlt(iice)+ & + nrshdr(iice)+ncshdc(iice))*dt) endif ! if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall) then ! not needed in 5.1.1.4.1 @@ -5222,34 +5167,69 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi diff_categories: if (iice.ne.catcoll) then ! add ice-ice category interaction collection tendencies ! note: nicol is a sink for the collectee category, but NOT a source for collector + ! + ! category-order-invariant: accumulate the cross-category transfers into + ! per-category double-precision accumulators instead of updating the + ! fields in slot order. qicol/nicol and the rime/volume/liquid + ! fractions are all precomputed (read-only here), so every increment is + ! bit-identical to the original; only the cross-category summation + ! becomes order-invariant. The accumulators are applied once, and the + ! per-category clipping/densification is likewise deferred, to a single + ! pass after iice_loop3 that sees the fully-accumulated fields (so its + ! result no longer depends on which category slot ran first). ! now modify rime mass and density, assume collection does not modify rime or liquid mass ! fractions or density of the collectee, consistent with the assumption that ! these are constant over the PSD - ! if ((qitot(i,k,catcoll)-qiliq(i,k,catcoll)).ge.qsmall) then ! not needed in 5.1.1.4.1 - !source for collector category - qirim(i,k,iice) = qirim(i,k,iice)+qicol(catcoll,iice)*dt* & - rimefraction(i,k,catcoll) - birim(i,k,iice) = birim(i,k,iice)+qicol(catcoll,iice)*dt* & - rimevolume(i,k,catcoll) - qiliq(i,k,iice) = qiliq(i,k,iice)+qicol(catcoll,iice)*dt* & - liquidfraction(i,k,catcoll) - !sink for collectee category - qirim(i,k,catcoll) = qirim(i,k,catcoll)-qicol(catcoll,iice)*dt* & - rimefraction(i,k,catcoll) - birim(i,k,catcoll) = birim(i,k,catcoll)-qicol(catcoll,iice)*dt* & - rimevolume(i,k,catcoll) - qiliq(i,k,catcoll) = qiliq(i,k,catcoll)-qicol(catcoll,iice)*dt* & - liquidfraction(i,k,catcoll) - ! endif - qitot(i,k,catcoll) = qitot(i,k,catcoll) - qicol(catcoll,iice)*dt - nitot(i,k,catcoll) = nitot(i,k,catcoll) - nicol(catcoll,iice)*dt - qitot(i,k,iice) = qitot(i,k,iice) + qicol(catcoll,iice)*dt + !source for collector category (iice) + qirim_col_dp(iice) = qirim_col_dp(iice) + dble(qicol(catcoll,iice)*dt*rimefraction(i,k,catcoll)) + birim_col_dp(iice) = birim_col_dp(iice) + dble(qicol(catcoll,iice)*dt*rimevolume(i,k,catcoll)) + qiliq_col_dp(iice) = qiliq_col_dp(iice) + dble(qicol(catcoll,iice)*dt*liquidfraction(i,k,catcoll)) + !sink for collectee category (catcoll) + qirim_col_dp(catcoll) = qirim_col_dp(catcoll) - dble(qicol(catcoll,iice)*dt*rimefraction(i,k,catcoll)) + birim_col_dp(catcoll) = birim_col_dp(catcoll) - dble(qicol(catcoll,iice)*dt*rimevolume(i,k,catcoll)) + qiliq_col_dp(catcoll) = qiliq_col_dp(catcoll) - dble(qicol(catcoll,iice)*dt*liquidfraction(i,k,catcoll)) + qitot_col_dp(catcoll) = qitot_col_dp(catcoll) - dble(qicol(catcoll,iice)*dt) + nitot_col_dp(catcoll) = nitot_col_dp(catcoll) - dble(nicol(catcoll,iice)*dt) + qitot_col_dp(iice) = qitot_col_dp(iice) + dble(qicol(catcoll,iice)*dt) endif diff_categories enddo interactions_loop ! catcoll loop endif + ! NOTE: the per-category clipping (qirim<0) and wet-growth / melt + ! densification formerly here are deferred to the post-loop pass below, + ! so they act on the fully-accumulated ice-ice interaction fields. + + dqv_dp = dqv_dp + dble((-qidep(iice)+qisub(iice)-qinuc(iice)-qlcon(iice)+ & + qlevp(iice))*dt) + + ! Update theta. Note temperature is not updated here even though it is used below for + ! the homogeneous freezing threshold. This is done for simplicity - the error will be + ! very small and the homogeneous temp. freezing threshold is approximate anyway. + dth_dp = dth_dp + dble(invexn(i,k)*((qidep(iice)-qisub(iice)+qinuc(iice))* & + xxls(i,k)*inv_cp +(qrcol(iice)+qccol(iice)+qchetc(iice)+ & + qcheti(iice)+qrhetc(iice)+qrheti(iice)+qcmul(iice)+ & ! DTD: added qcmul + qrmul(iice)-qrmlt(iice)-qimlt(iice)+qifrz(iice))* & + xlf(i,k)*inv_cp+(qlcon(iice)-qlevp(iice))*xxlv(i,k)* & + inv_cp)*dt) + + enddo iice_loop3 + + ! Apply the deferred ice-ice interaction cross-category contributions (one + ! rounded update per field per category), then do the per-category clipping + ! and wet-growth / melt densification on the fully-accumulated fields. When + ! log_iceice_interaction=.false. every accumulator is zero, so the apply is + ! an exact no-op and this pass is byte-identical to doing the clipping inside + ! iice_loop3. When it is .true., the fields are complete before clipping, so + ! both the transfers and the clipping are invariant to category slot order. + do iice = 1,nCat + qitot(i,k,iice) = sngl(dble(qitot(i,k,iice)) + qitot_col_dp(iice)) + qirim(i,k,iice) = sngl(dble(qirim(i,k,iice)) + qirim_col_dp(iice)) + birim(i,k,iice) = sngl(dble(birim(i,k,iice)) + birim_col_dp(iice)) + qiliq(i,k,iice) = sngl(dble(qiliq(i,k,iice)) + qiliq_col_dp(iice)) + nitot(i,k,iice) = sngl(dble(nitot(i,k,iice)) + nitot_col_dp(iice)) + if (qirim(i,k,iice).lt.0.) then qirim(i,k,iice) = 0. birim(i,k,iice) = 0. @@ -5268,21 +5248,16 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi tmp2 = qitot(i,k,iice) + qrmlt(iice)*dt ! qitot before melting (but after all other updates) birim(i,k,iice) = qirim(i,k,iice)/(tmp1+(917.-tmp1)*qrmlt(iice)*dt/tmp2) endif + enddo - qv(i,k) = qv(i,k) + (-qidep(iice)+qisub(iice)-qinuc(iice)-qlcon(iice)+ & - qlevp(iice))*dt - - ! Update theta. Note temperature is not updated here even though it is used below for - ! the homogeneous freezing threshold. This is done for simplicity - the error will be - ! very small and the homogeneous temp. freezing threshold is approximate anyway. - th(i,k) = th(i,k) + invexn(i,k)*((qidep(iice)-qisub(iice)+qinuc(iice))* & - xxls(i,k)*inv_cp +(qrcol(iice)+qccol(iice)+qchetc(iice)+ & - qcheti(iice)+qrhetc(iice)+qrheti(iice)+qcmul(iice)+ & ! DTD: added qcmul - qrmul(iice)-qrmlt(iice)-qimlt(iice)+qifrz(iice))* & - xlf(i,k)*inv_cp+(qlcon(iice)-qlevp(iice))*xxlv(i,k)* & - inv_cp)*dt - - enddo iice_loop3 + ! apply the fused, category-order-invariant shared-field tendencies (one + ! rounded update each) before any subsequent read of these fields + qc(i,k) = sngl(dble(qc(i,k)) + dqc_dp) + if (log_predictNc) nc(i,k) = sngl(dble(nc(i,k)) + dnc_dp) + qr(i,k) = sngl(dble(qr(i,k)) + dqr_dp) + nr(i,k) = sngl(dble(nr(i,k)) + dnr_dp) + qv(i,k) = sngl(dble(qv(i,k)) + dqv_dp) + th(i,k) = sngl(dble(th(i,k)) + dth_dp) !== if (debug_on) then @@ -5334,13 +5309,18 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !== ! clipping for Filiq > 0.99 (transfer unmelted ice to rain) + ! (category-order-invariant: defer the shared qr/nr/th increments, + ! accumulate in double precision, apply once after the loop) if (log_LiquidFrac) then + clipsum_qr = 0.d0 + clipsum_nr = 0.d0 + clipsum_th = 0.d0 do iice = 1,nCat if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nsmall check if ((qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then ! ERM split conditional to avoid div by zero - qr(i,k) = qr(i,k) + qitot(i,k,iice) - nr(i,k) = nr(i,k) + nitot(i,k,iice) - th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xlf(i,k)*inv_cp + clipsum_qr = clipsum_qr + dble(qitot(i,k,iice)) + clipsum_nr = clipsum_nr + dble(nitot(i,k,iice)) + clipsum_th = clipsum_th - dble(invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xlf(i,k)*inv_cp) qitot(i,k,iice) = 0. nitot(i,k,iice) = 0. qirim(i,k,iice) = 0. @@ -5349,6 +5329,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif enddo !iice-loop + qr(i,k) = sngl(dble(qr(i,k)) + clipsum_qr) + nr(i,k) = sngl(dble(nr(i,k)) + clipsum_nr) + th(i,k) = sngl(dble(th(i,k)) + clipsum_th) endif ! clipping for small hydrometeor values @@ -5370,11 +5353,15 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi log_hydrometeorsPresent = .true. endif + ! (category-order-invariant: defer the shared qv/th increments, + ! accumulate in double precision, apply once after the loop) + clipsum_qv = 0.d0 + clipsum_th = 0.d0 do iice = 1,nCat if (qitot(i,k,iice).lt.qsmall .or. nitot(i,k,iice) .lt. nsmall) then ! DTD added nsmall check - qv(i,k) = qv(i,k) + qitot(i,k,iice) - th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp - th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp + clipsum_qv = clipsum_qv + dble(qitot(i,k,iice)) + clipsum_th = clipsum_th - dble(invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp) + clipsum_th = clipsum_th - dble(invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp) qitot(i,k,iice) = 0. nitot(i,k,iice) = 0. qirim(i,k,iice) = 0. @@ -5384,6 +5371,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi log_hydrometeorsPresent = .true. endif enddo !iice-loop + qv(i,k) = sngl(dble(qv(i,k)) + clipsum_qv) + th(i,k) = sngl(dble(th(i,k)) + clipsum_th) qv(i,k) = max(0., qv(i,k)) ! DTD turned off for testing @@ -6826,6 +6815,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! DTD turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) + ! (category-order-invariant: defer the shared qv/th increments from the + ! ice clip, accumulate in double precision, apply once after the loop) + clipsum_qv = 0.d0 + clipsum_th = 0.d0 iice_loop_final_diagnostics: do iice = 1,nCat qi_not_small: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then ! ERM added nitot check @@ -6984,9 +6977,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi else - qv(i,k) = qv(i,k) + qitot(i,k,iice) - th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp - th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp + clipsum_qv = clipsum_qv + dble(qitot(i,k,iice)) + clipsum_th = clipsum_th - dble(invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp) + clipsum_th = clipsum_th - dble(invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp) qitot(i,k,iice) = 0. nitot(i,k,iice) = 0. qirim(i,k,iice) = 0. @@ -6998,6 +6991,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif qi_not_small enddo iice_loop_final_diagnostics + qv(i,k) = sngl(dble(qv(i,k)) + clipsum_qv) + th(i,k) = sngl(dble(th(i,k)) + clipsum_th) ! sum ze components and convert to dBZ ! for reflectivity paper diff --git a/src/param.F b/src/param.F index bc62b9e..c7f5a92 100644 --- a/src/param.F +++ b/src/param.F @@ -74,9 +74,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & use module_mp_thompson , only : thompson_init use module_mp_graupel use microphy_p3, only : p3_init, log_chksum, chksum_myid, & - log_chkpts, chksum_i0, chksum_j0, & - log_clipdp, log_epsdp, log_limdp, log_nucdp, & - log_nanpoison + log_chkpts, chksum_i0, chksum_j0 use module_mp_jensen_ishmael, only : jensen_ishmael_init use module_mp_nssl_2mom, only: nssl_2mom_init, rho_qr, cnor, rho_qs, & cnos, rho_qh, rho_qhl, cnoh, ccn, irenuc, infall, alphah, alphahl, & @@ -166,11 +164,6 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & logical :: p3_cat_init_new = .true. ! switch for mechanism-based ice category initialization logical :: p3_chksum = .false. ! P3: write per-timestep bitwise field checksums to p3_chksum_NNNN.out (divergence diagnosis) logical :: p3_chkpts = .false. ! P3: write per-point raw bit patterns to p3_chkpts_NNNN.out (LARGE; short bracketing runs only) - logical :: p3_clipdp = .false. ! P3: category-order-invariant entry clipping (double-precision accumulation; divergence diagnosis) - logical :: p3_epsdp = .false. ! P3: category-order-invariant epsi_tot accumulation (divergence diagnosis) - logical :: p3_limdp = .false. ! P3: category-order-invariant conservation-limiter sums (divergence diagnosis) - logical :: p3_nucdp = .false. ! P3: category-order-invariant sum(nitot) in deposition nucleation (divergence diagnosis) - logical :: p3_nanpoison = .false. ! P3: NaN-poison per-category work vars for stale-state hunt (debug build + lldb required) logical :: log_nislf = .true. ! switch to allow ice self-aggregation logical :: log_iceice_interaction = .true. ! switch to allow ice categories to interact integer :: p3_catdest_contact_n2 = 1 @@ -236,11 +229,6 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_cat_init_new,& p3_chksum, & p3_chkpts, & - p3_clipdp, & - p3_epsdp, & - p3_limdp, & - p3_nucdp, & - p3_nanpoison, & qsum_invariant, & log_nislf, & log_iceice_interaction, & @@ -861,11 +849,6 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(p3_cat_init_new,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_chksum,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_chkpts,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(p3_clipdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(p3_epsdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(p3_limdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(p3_nucdp,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(p3_nanpoison,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(qsum_invariant,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_nislf,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_iceice_interaction,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) @@ -4446,11 +4429,6 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! Phase-1/2 checksum instrumentation (category-swap divergence diagnosis): log_chksum = p3_chksum log_chkpts = p3_chkpts - log_clipdp = p3_clipdp - log_epsdp = p3_epsdp - log_limdp = p3_limdp - log_nucdp = p3_nucdp - log_nanpoison = p3_nanpoison chksum_myid = myid ! global index = local index + offset (k is not decomposed): chksum_i0 = myi1-1 diff --git a/src/turb.F b/src/turb.F index a685800..dbd4cbc 100644 --- a/src/turb.F +++ b/src/turb.F @@ -5023,21 +5023,42 @@ subroutine calcnm(c1,c2,mf,pi0,thv0,th0,cloudvar,nm,t,qt,thv,cloud,rh,qvci, & enddo ENDIF - DO n=1,numq - IF( (n.eq.nqv) .or. & - (n.ge.nql1.and.n.le.nql2) .or. & - (n.ge.nqs1.and.n.le.nqs2.and.iice.eq.1) )THEN - !$omp parallel do default(shared) & - !$omp private(i,j,k) - do k=1,nk - do j=1,nj - do i=1,ni - qt(i,j,k)=qt(i,j,k)+qa(i,j,k,n) - enddo - enddo - enddo - ENDIF - ENDDO + IF( qsum_invariant )THEN + ! category-order-invariant total water (matches the dum7 = Sql+Sqi + ! treatment in the turb driver; see qsum_invariant). qv + a value-sorted + ! liquid sum + a value-sorted solid sum, so qt -- and hence thv, N^2, the + ! subgrid TKE and the eddy diffusivities -- is independent of which + ! category slot holds which value. (Without this, the fixed slot-order + ! accumulation of the swapped ice masses seeds a ~1-ULP difference in the + ! diffusivity that breaks bit-identity under a category relabeling.) + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,nk + do j=1,nj + do i=1,ni + qt(i,j,k) = qt(i,j,k) + qa(i,j,k,nqv) + if( nql1.gt.0 ) qt(i,j,k) = qt(i,j,k) + sortsumq(qa(i,j,k,nql1:nql2)) + if( nqs1.gt.0 .and. iice.eq.1 ) qt(i,j,k) = qt(i,j,k) + sortsumq(qa(i,j,k,nqs1:nqs2)) + enddo + enddo + enddo + ELSE + DO n=1,numq + IF( (n.eq.nqv) .or. & + (n.ge.nql1.and.n.le.nql2) .or. & + (n.ge.nqs1.and.n.le.nqs2.and.iice.eq.1) )THEN + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,nk + do j=1,nj + do i=1,ni + qt(i,j,k)=qt(i,j,k)+qa(i,j,k,n) + enddo + enddo + enddo + ENDIF + ENDDO + ENDIF k = 1 From 137e4391394338bb9fc47f064b74ee12f98d9691 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Tue, 21 Jul 2026 13:04:35 -0400 Subject: [PATCH 15/25] Updated Makefile for Bell --- src/Makefile_bell | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Makefile_bell b/src/Makefile_bell index 16fc54d..a7d5da4 100644 --- a/src/Makefile_bell +++ b/src/Makefile_bell @@ -82,9 +82,17 @@ LINKOPTS = -lnetcdf -lnetcdff #----------------------------------------------------------------------------- # multiple processors, distributed memory (MPI), GNU compiler FC = mpif90 -OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -march=znver2 +OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding DM = -DMPI +# multiple processors, distributed memory (MPI), GNU compiler, double precision +# DTD TODO: this doesn't seem to work on my Macbook at least. Run stalls somewhere before starting +# the main time loop. +# FC = mpif90 +# OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -fdefault-real-8 -fdefault-double-8 +# CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding +# DM = -DMPI +# DP = -DDP #----------------------------------------------------------------------------- # multiple processors, shared memory (OpenMP), GNU compiler #FC = gfortran From 84b472ec0ae75f3c160b6138ad800e6799cd24ab Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Wed, 22 Jul 2026 16:24:56 -0400 Subject: [PATCH 16/25] Turned log_maxnsmall back to true by default --- src/module_mp_p3.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 45c98e6..1e7103c 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -330,7 +330,7 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err IF ( present( catdest_homorain_n2_in ) ) catdest_homorain_n2 = min(2,max(1,catdest_homorain_n2_in)) IF ( present( catdest_homorain_n3_in ) ) catdest_homorain_n3 = min(3,max(1,catdest_homorain_n3_in)) IF ( present( catdest_homorain_n4_in ) ) catdest_homorain_n4 = min(4,max(1,catdest_homorain_n4_in)) - log_maxnsmall = .false. !flag for resetting n up to nsmall + log_maxnsmall = .true. !flag for resetting n up to nsmall ! Primary ice nucleation ! 1 = Cooper From b7dcda3824ceec87a87345c55248d2f70a26c006 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Wed, 22 Jul 2026 22:11:05 -0400 Subject: [PATCH 17/25] Updated to manually merge in changes from NSSL3M_Feb_2025 branch --- src/cm1.F | 12 +- src/init3d.F | 5 +- src/input.F | 5 +- src/module_mp_nssl_2mom.F | 4050 ++++++++++++++++++++++++++++++------- src/module_mp_p3.F | 6 +- src/mp_driver.F | 56 +- src/param.F | 17 +- src/solve3.F | 15 +- src/writeout.F | 54 +- 9 files changed, 3484 insertions(+), 736 deletions(-) diff --git a/src/cm1.F b/src/cm1.F index 32c77b1..c793b88 100644 --- a/src/cm1.F +++ b/src/cm1.F @@ -99,7 +99,7 @@ program cm1 real, dimension(:,:,:), allocatable :: dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8,dum9 real, dimension(:,:), allocatable :: zs,gz,rgz,gzu,rgzu,gzv,rgzv,dzdx,dzdy real, dimension(:,:,:), allocatable :: gx,gxu,gy,gyv - real, dimension(:,:,:), allocatable :: rain,sws,svs,sps,srs,sgs,sus,shs + real, dimension(:,:,:), allocatable :: rain,hail,sws,svs,sps,srs,sgs,sus,shs real, dimension(:,:), allocatable :: tsk,znt,rznt,zntmp,ust,ustbase,stau,tst,qst,z0t,z0q,thflux,qvflux, & !Qin add ustbase for WC cd,ch,cq,u1,u1base,v1,v1base,s1,s1base,t1,xland,psfc,tlh,f2d,psmth,prate,ustt,ut,vt,st,cm0 !Qin add u1base,v1base,s1base for WC real, dimension(:,:), allocatable :: radbcw,radbce @@ -1484,6 +1484,8 @@ program cm1 #endif allocate( rain(ib:ie,jb:je,nrain) ) rain = 0.0 + allocate( hail(ib:ie,jb:je,nrain) ) + hail = 0.0 allocate( sws(ib:ie,jb:je,nrain) ) sws = 0.0 allocate( svs(ib:ie,jb:je,nrain) ) @@ -2386,7 +2388,7 @@ program cm1 zh,mh,rmh,zf,mf,rmf,rho0s,pi0s,prs0s, & pi0,prs0,rho0,thv0,th0,rth0,qv0, & u0,v0,qc0,qi0,rr0,rf0,rrf0, & - rain,sws,svs,sps,srs,sgs,sus,shs, & + rain,hail,sws,svs,sps,srs,sgs,sus,shs, & thflux,qvflux,cd,ch,cq,f2d, & dum1,dum2,dum3,dum4,divx,rho,prs, & rru,ua,u3d,uten,uten1,rrv,va,v3d,vten,vten1, & @@ -3383,7 +3385,7 @@ program cm1 call pdefq( 0.0,asq(1),ruh,rvh,rmh,rho,q3d(ib,jb,kb,1)) else call mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & - mh,rmh,c1,c2,zh,mf,rmf,zf,rain,prate,pi0,th0,rho0,prs0,qv0, & + mh,rmh,c1,c2,zh,mf,rmf,zf,rain,hail,prate,pi0,th0,rho0,prs0,qv0, & rho,prs,dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8, & w3d,ppi,pp3d,ppten,sten,tha,th3d,thten,qa,q3d,qten, & p3a,p3o,dum2d1,dum2d2,dum2d3,dum2d4,dum2d5, & @@ -3407,7 +3409,7 @@ program cm1 pi0,rho0,prs0,thv0,th0,rth0,qv0,qc0, & qi0,rr0,rf0,rrf0, & zs,gz,rgz,gzu,rgzu,gzv,rgzv,dzdx,dzdy, & - rain,sws,svs,sps,srs,sgs,sus,shs, & + rain,hail,sws,svs,sps,srs,sgs,sus,shs, & dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8, & divx,rho,rr,rf,prs, & u0,rru,ua,u3d,uten,uten1, & @@ -3912,7 +3914,7 @@ program cm1 xh,xf,uf,yh,yf,vf,xfref,yfref, & rds,sigma,rdsf,sigmaf,zh,zf,mf,gx,gy,wprof, & pi0,prs0,rho0,rr0,rf0,rrf0,th0,qv0,u0,v0,thv0,rth0,qc0,qi0, & - zs,rgzu,rgzv,rain,sws,svs,sps,srs,sgs,sus,shs,thflux,qvflux,psfc, & + zs,rgzu,rgzv,rain,hail,sws,svs,sps,srs,sgs,sus,shs,thflux,qvflux,psfc, & rxh,arh1,arh2,uh,ruh,rxf,arf1,arf2,vh,rvh,mh,rmh,rmf,rr,rf, & gz,rgz,gzu,gzv,gxu,gyv,dzdx,dzdy,c1,c2, & cd,ch,cq,tlh,f2d,psmth,prate,ustt,cm0, & diff --git a/src/init3d.F b/src/init3d.F index c5fe20b..a79141b 100644 --- a/src/init3d.F +++ b/src/init3d.F @@ -62,7 +62,7 @@ subroutine init3d(xh,rxh,uh,ruh,xf,rxf,uf,ruf,yh,vh,rvh,yf,vf,rvf, & zh,mh,rmh,zf,mf,rmf,rho0s,pi0s,prs0s, & pi0,prs0,rho0,thv0,th0,rth0,qv0, & u0,v0,qc0,qi0,rr0,rf0,rrf0, & - rain,sws,svs,sps,srs,sgs,sus,shs, & + rain,hail,sws,svs,sps,srs,sgs,sus,shs, & thflux,qvflux,cd,ch,cq,f2d, & dum1,dum2,dum3,dum4,divx,rho,prs, & rru,ua,u3d,uten,uten1,rrv,va,v3d,vten,vten1, & @@ -101,7 +101,7 @@ subroutine init3d(xh,rxh,uh,ruh,xf,rxf,uf,ruf,yh,vh,rvh,yf,vf,rvf, & real, dimension(ib:ie,jb:je) :: rho0s,pi0s,prs0s real, dimension(ib:ie,jb:je,kb:ke) :: pi0,prs0,rho0,thv0,th0,rth0,qv0 real, dimension(ib:ie,jb:je,kb:ke) :: qc0,qi0,rr0,rf0,rrf0 - real, dimension(ib:ie,jb:je,nrain) :: rain,sws,svs,sps,srs,sgs,sus,shs + real, dimension(ib:ie,jb:je,nrain) :: rain,hail,sws,svs,sps,srs,sgs,sus,shs real, dimension(ib:ie,jb:je) :: thflux,qvflux,cd,ch,cq,f2d real, dimension(ib:ie,jb:je,kb:ke) :: dum1,dum2,dum3,dum4 real, dimension(ib:ie,jb:je,kb:ke) :: divx,rho,prs @@ -185,6 +185,7 @@ subroutine init3d(xh,rxh,uh,ruh,xf,rxf,uf,ruf,yh,vh,rvh,yf,vf,rvf, & do i=ib,ie ! these are all positive-definite, so set initial value to zero: rain(i,j,n)=0.0 + hail(i,j,n)=0.0 sws(i,j,n)=0.0 srs(i,j,n)=0.0 sgs(i,j,n)=0.0 diff --git a/src/input.F b/src/input.F index 007efef..34818ad 100644 --- a/src/input.F +++ b/src/input.F @@ -64,7 +64,7 @@ MODULE input !----------------------------------------------------------------------- integer :: nodex=0,nodey=0 - integer nx,ny,nz,ppnode,timeformat,timestats,outunits, & + integer :: nx,ny,nz,ppnode,timeformat,timestats,outunits, & ni,nj,nk,nkp1,ngxy,ngz, & ib,ie,jb,je,kb,ke, & ibm,iem,jbm,jem,kbm,kem, & @@ -126,6 +126,7 @@ MODULE input output_format,output_filetype,output_interp, & restart_format,restart_filetype, & output_rain,output_sws,output_svs,output_sps,output_srs, & + output_hail=1, & output_sgs,output_sus,output_shs,output_coldpool,output_zs, & output_psfc, & output_basestate,output_sfcflx,output_sfcparams,output_sfcdiags,& @@ -318,7 +319,7 @@ MODULE input xradbub,yradbub,zradbub namelist /param9/ & output_format,output_filetype, & - output_interp, & + output_interp,output_hail, & output_rain,output_sws,output_svs,output_sps,output_srs, & output_sgs,output_sus,output_shs,output_coldpool, & output_sfcflx,output_sfcparams,output_sfcdiags, & diff --git a/src/module_mp_nssl_2mom.F b/src/module_mp_nssl_2mom.F index 5e52d07..b0166f5 100644 --- a/src/module_mp_nssl_2mom.F +++ b/src/module_mp_nssl_2mom.F @@ -1,15 +1,11 @@ !COMMAS/1:MODEL_LAYER:PHYSICS -! prepocessed on "Jun 9 2024" at "15:06:19" - - - - +! prepocessed on "Jul 3 2026" at "14:37:53" !--------------------------------------------------------------------- -! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: +! IMPORTANT (WRF ONLY): Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: ! moist_adv_opt = 4, ! scalar_adv_opt = 4, (can also use option 3, which is WENO without the positive definite filter) ! The WENO-5 scheme provides a 5th-order (horizontal and vertical) adaptive weighting of components that @@ -23,7 +19,8 @@ ! ! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; ! -!! This module provides a 1/2/3-moment bulk microphysics scheme based on a combination of + +!> 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. @@ -70,8 +67,22 @@ ! Note: Some parameters below apply to unreleased features. ! ! + !--------------------------------------------------------------------- -! Apr. 2023 +! Feb. 2025 +! - More accurate saturation mixing ratio calculation (iqvsopt=1) +! - Changed default droplet renucleation to irenuc=5, which allows extra nucleation at high supersaturation +! - Default explicit rain breakup for 3-moment (irainbreak=2) +! - Imposed reflectivity conservation in graupel->hail conversion (ihlcnh=3) and Bigg +! freezing (both 2- and 3-moment) +! - Option (nsplinter=1001) for ice crystal production by drop freezing/shattering (Sullivan et al. 2018) +! - Option (incwet = 1) to treat wet growth only for D > Dwet rather than all or nothing; results in +! slightly greater hail production due to maintaining dry growth at D < Dwet +! - Improved logic for sedimentation +! - Separated flushing of small masses into its own subroutine (smallvalues) +! - Some syntax fixes for issues with old versions of gfortran +!--------------------------------------------------------------------- +! Apr. 2023 (WRF-4.6) ! - 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. @@ -172,15 +183,26 @@ + + + MODULE module_mp_nssl_2mom IMPLICIT NONE public nssl_2mom_driver public nssl_2mom_init + + public nssl_qtodbz + public nssl_column_dbz + + private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis private gamma_dp, gamxinfdp, gamma_dpr private delbk, delabk private gammadp + private galpha, dgalpha + private zraten,zrateq,zrateqn + logical, private :: cleardiag = .false. PRIVATE @@ -192,10 +214,13 @@ MODULE module_mp_nssl_2mom #endif LOGICAL, PRIVATE:: is_aerosol_aware = .false. + logical, private :: turn_on_cin = .false. +! #if defined(1) && !defined(COMMAS) integer, private :: myrankcm1 = 0 +! #endif integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates) ! value of > 2 invokes the equivalent version of eqtset=2 that applies updates to both theta and Pi. double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10 @@ -216,7 +241,13 @@ MODULE module_mp_nssl_2mom integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) ! =2 turn on for graupel density less than 300. only integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband + + integer,public :: icorrecthaildbz = 1 ! =1 to adjust hail number conc. from gr->hl conversion to keep correct Z + integer,public :: icorrectfddbz = 1 ! =1 to adjust graupel/FD number conc. from rain freezing to keep correct Z + real ,public :: zxmincorr = 1.e-15 ! minimum Z to run correction to C + real ,public :: cxmincorr = 1.e-3 ! minimum C to run correction to C ! microphysics real, public :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params @@ -236,8 +267,11 @@ MODULE module_mp_nssl_2mom 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 , public :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , public :: ccn_co = 0.05e+09 ! set in namelist!! Central plains CCN value + real , public :: ccn_nu = 1.6e+09 ! set in namelist!! Central plains CCN value real , public :: ccnuf = 0 ! set in namelist!! Central plains CCN value real , public :: qccn, qccnuf ! ccn "mixing ratio" + real , public :: qccnco, qccnnu ! ccn "mixing ratio" for coarse and nu modes real , private :: old_qccn = -1.0 integer, private :: iauttim = 1 ! 10-ice rain delay flag real , private :: auttim = 300. ! 10-ice rain delay time @@ -259,6 +293,7 @@ MODULE module_mp_nssl_2mom 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) ! iscfall, infall -> fallout options for charge and number concentration, respectively @@ -266,21 +301,27 @@ MODULE module_mp_nssl_2mom integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, public :: irfall = -1 - integer, public :: isfall = 2 ! default limit with method II (more restrictive) + integer, public :: iifall = 0 + integer, public :: isfall = 4 ! default limit with method II (more restrictive) + logical, public :: do_accurate_sedimentation = .false. ! 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. + integer, public :: interval_sedi_vt = 1 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.) + integer, public :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) ! 1 -> uses mass-weighted fallspeed for N ALWAYS ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) ! 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, public :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) + real, public :: icefallfac = 1.0 ! factor to adjust ice fall speed real, public :: snowfallfac = 1.0 ! factor to adjust snow fall speed + real, public :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed real, public :: hailfallfac = 1.0 ! factor to adjust hail fall speed integer, public :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) @@ -337,17 +378,24 @@ MODULE module_mp_nssl_2mom integer, public :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data; =2 for Geoffroy et al. (2010, ACP) integer, private :: iccwflg = 1 ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid) ! (first nucleation is done with a KW sat. adj. step) - integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field + integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field (obsolete) + integer, private :: isscheck = 0 ! flag to check max condensation from droplet nucleation (experimental -- do not use!) + real , private :: dcritcheck = 2.*3.17e-6 ! diameter of newly nucleated droplets (isscheck = 1) integer, public :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) + integer, public :: icondlimit = 0 ! Check if condensation exceeds sat adj. (1=on, 0 = off unless dt>dtcond) + real , private :: dtcond = 10. ! timestep above which icondlimit is enabled + integer, public :: irenuc = 7 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete) + ! =2 renucleation following Twomey/Cohard&Pinty + ! =5 Similar to 7 but can produce extra activated nuclei from the 'smaller' CCN at higher SS ! =7 New renucleation that requires prediction of the number of activated nuclei ! i.e., not only at cloud base integer, private :: irenuc3d = 0 ! =1 to include horizontal gradient in renucleation of droplets within the cloud - real :: renucfrac = 0.0 ! = 0 : cnuc = cwccn + real , private :: renucfrac = 0.0 ! = 0 : cnuc = cwccn ! = 1 : cnuc = actual available CCN ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac - real :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5 + real , private :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5 real , private :: cck = 0.6 ! exponent in Twomey expression real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation @@ -363,7 +411,9 @@ MODULE module_mp_nssl_2mom integer, public :: 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, public :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) - real, public :: naer = 1.0e6 ! background large aerosol conc. for DeMott + integer, public :: inactopt = 2 ! 1=old IN activation using cmassin; 2=activate IN by depleting droplets + real, public :: naer = 1.0e6 ! background large aerosol conc. for DeMott (per standard m^3) + real, public :: naerdust = 1.0e6 ! background mineral dust for DeMott 2015 (per standard m^3) integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version integer, private :: ihrn = 0 ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only) integer, public :: ibfc = 1 ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on) @@ -401,9 +451,13 @@ MODULE module_mp_nssl_2mom integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) integer, public :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C integer, public :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + + real , public :: eiw0 = 0.5 ! constant or max assumed ice-crystal-droplet collection efficiency + real , public :: esw0 = 0.5 ! constant or max assumed snow-droplet collection efficiency real , public :: ehw0 = 0.9 ! 0.5 ! constant or max assumed graupel-droplet collection efficiency real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency real , public :: ehlw0 = 0.9 ! 0.75 ! constant or max assumed hail-droplet collection efficiency + real , public :: efw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency @@ -441,8 +495,10 @@ MODULE module_mp_nssl_2mom ! 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 , public :: esstem1 = -25. ! lower temperature where snow aggregation turns on - real , public :: esstem2 = -20. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + + real , public :: esstem1 = -15. ! lower temperature where snow aggregation turns on + real , public :: esstem2 = -10. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + real , public :: essrmax = 0.02 ! maximum snow radius (meters) for csacs real , public :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off real , public :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off @@ -458,7 +514,7 @@ MODULE module_mp_nssl_2mom real , private :: rz ! reflectivity conservation factor for graupel/rain ! now calculated in icezvd_dr.F from alphah and rnu ! currently only used for graupel melting to rain - real , private :: rzhl ! reflectivity conservation factor for hail/rain + real , private :: rzhl, rzhlh ! reflectivity conservation factor for hail/rain, hail/graupel ! now calculated in icezvd_dr.F from alphahl and rnu real , private :: rzs ! reflectivity conservation factor for snow(imusnow=3) with rain (imurain=1) @@ -483,18 +539,22 @@ MODULE module_mp_nssl_2mom integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets integer, public :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail - integer, public :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail + integer, public :: imltshddmr = 1 ! Options: + ! 0=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail ! and max mean diameter of rain) - ! 1=new method where mean diameter of rain during melting is adjusted linearly downward + ! 1 (default) =new method where mean diameter of rain during melting is adjusted linearly downward ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of ! smaller drops. sheddiam0 controls the size of graupel/hail above which the assumed ! mean diameter of rain is set to 3 mm ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M - ! 2 = method that sets the resulting rain size ( vshdgs ) according to the mass-weighted diameter of the ice + ! 2 = method that sets the resulting rain size ( vshdgs ) according to the max-mass diameter + ! of the ice; tends to cause smaller rain drops in forward flank real :: mltdiam1 = 9.0e-3, mltdiam2 = 16.0e-3, mltdiam3 = 19.0e-3, mltdiam4 = 200.0e-3, mltdiam05 = 4.5e-3 integer, public :: nsplinter = 0 ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle + ! Set nslpinter >= 1000 to turn on Lawson 2015 splintering option + ! nslpinter = 1001 (NSSL) applies temperature-based factor from Sullivan et al. 2018 real, private :: lawson_splinter_fac = 2.5e-11 ! constant in Lawson et al. (2015, JAS) for ice particle production from freezing drops integer, private :: isnwfrac = 0 ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000) @@ -504,8 +564,13 @@ MODULE module_mp_nssl_2mom real, public :: qhacidn = -1. integer, private :: iraintypes = 0 + integer, private :: nraintypes = 3 ! number of rain source types + integer, parameter :: maxraintypes = 5 ! number of rain source types logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel integer, private :: imixedphase = 0 + logical, private :: slowfreeze = .false. ! .false.=off, true=on to partially freeze rain at higher temp + real, private :: rainfreeztemplow = -25.0, rainfreeztemphigh = -10.0 ! temperature (low) at which rain freezes instantly + real, private :: rainfreezefrac0 = 0.15 ! starting rain freezing fraction for T > rainfreeztemphigh logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density logical, private :: qhdenmod = .false. ! true = modify graupel density by linear interpolation of graupel and rain density logical, private :: qsvtmod = .false. ! true = modify snow fall speed by linear interpolation of snow and rain vt @@ -513,6 +578,8 @@ MODULE module_mp_nssl_2mom real :: sheddiamlg = 10.0e-03 ! diameter of hail to use fwmlarge real :: sheddiam0 = 20.0e-03 ! diameter of hail at which all water is shed + real :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles + integer :: ifwmhtmptemopt = 1 ! option to use fwmhtmptem (1) or dwet (2) for max liquid at T < 0. integer :: ifwmhopt = 2 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1 ! 1 = maximum based on size of maximum mass diameter ! 2 = integrate over spectrum for maximum liquid (experimental) @@ -530,8 +597,8 @@ MODULE module_mp_nssl_2mom logical :: rescale_high_alpha = .false. ! whether to rescale number. conc. when alpha = alphamax (3-moment only) logical :: rescale_low_alpha = .true. ! whether to rescale Z (graupel/hail) when alpha = alphamin (3-moment only) logical :: rescale_low_alphar = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) - logical :: rescale_low_alphah = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) - logical :: rescale_low_alphahl = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphah = .false. ! whether to rescale Z for graupel/FD when alpha = alphamin (3-moment only) + logical :: rescale_low_alphahl = .false. ! whether to rescale Z for hail when alpha = alphamin (3-moment only) real, parameter :: alpharmax = 8. ! limited for rwvent calculation @@ -550,6 +617,8 @@ MODULE module_mp_nssl_2mom real , public :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail real , public :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) real , public :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + real , private :: wetgrthtoffset = -1. ! maximum temperature (Celcius) for wet growth (shedding) + real , private :: hailcnvtoffset = -2. ! maximum temperature (Celcius) for hail conversion 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 @@ -564,13 +633,18 @@ MODULE module_mp_nssl_2mom integer, public :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) integer, public :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3) integer :: iresetmoments = 0 ! if >0, then set all moments to zero when one of them is zero (3-moment only) - integer, public :: imaxdiaopt = 3 - ! = 1 use mean diameter for breakup - ! = 2 use maximum mass diameter for breakup - ! = 3 use mass-weighted diameter for breakup - integer :: irainbreak = 0 ! 1 = on; Active rain breakup (use for 3-moment rain) + integer, public :: imaxdiaopt = -1 + ! = 1 use mean diameter for rain breakup (default for 3-moment) + ! = 2 use maximum mass diameter for rain breakup + ! = 3 use mass-weighted diameter for rain breakup (default for 2-moment) + integer :: irainbreak = -1 ! -1 : auto sets off for 2-moment and on (=2) for 3-moment + ! 0 = off + ! 1 = on (no diameter dependence) (recommend using option 2) + ! 2 = (recommended) as for 1, but apply factor of 1-ec0 to turn off a smaller diameter (ec0 is rain self-coll factor) + ! 10 = as for 1, but sets ec0=1 for rain self-collection (i.e., no passive breakup); set higher rainbreakfac for this option + ! 11 = breakup for DSD tail only; uses draintail etc. integer :: ibincracr = 0 - real :: rainbreakfac = 1.0e6 ! 1.e6 for irainbreak=2 (reduce double counting); 2.0e6 for lower hand fit for irainbreak=10; 2.542e6 for 'best' fit + real :: rainbreakfac = 2.5e6 ! 1.e6 for irainbreak=2 (reduce double counting); 2.0e6 for lower hand fit for irainbreak=10; 2.542e6 for 'best' fit real :: draintail = 10.e-3 ! starting size for rain breakup (irainbreak = 11) real :: drsmall = 1.e-3 ! size of small drops from breakup (irainbreak = 11) real :: qrbrthresh1 = 0.1e-3 ! lower threshold rain content (kg/m^3) for large drop breakup (irainbreak=11) @@ -671,6 +745,7 @@ MODULE module_mp_nssl_2mom integer, private :: lccnaco = 0 integer, private :: lccnanu = 0 integer, private :: lcina = 0 + integer, private :: lcinda = 0 integer, private :: lcin = 0 integer, private :: lnc = 9 integer, private :: lnr = 10 @@ -795,10 +870,14 @@ MODULE module_mp_nssl_2mom integer :: ichge = 3 integer :: ichgw = 2 real :: charging_border = 4000. ! width of no-charging zone from boundary + real, private :: delqnw = -1.0e-10!-1.0e-12 ! real, private :: delqxw = 1.0e-10! 1.0e-12 ! real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed + integer, private :: imorrgdnglimit = 0 ! flag to impose limit on graupel slope parameter + real, private :: morrdnglimit = 2000.E-6 + ! ! gamma function lookup table ! @@ -819,7 +898,7 @@ MODULE module_mp_nssl_2mom real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha) real :: qiacrratio(0:nqiacrratio,ialpstart:nqiacralpha) real :: ziacrratio(0:nqiacrratio,ialpstart:nqiacralpha) - double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) + double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,13,2) ! last index for graupel (1) or hail (2) ! real :: ciacrratio(0:nqiacrratio,0:nqiacralpha) ! real :: qiacrratio(0:nqiacrratio,0:nqiacralpha) ! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) @@ -842,6 +921,8 @@ MODULE module_mp_nssl_2mom integer lvol(lc:lqmx) integer lz(lc:lqmx) integer lliq(li:lqmx) + integer lrain(maxraintypes) + integer linfall(lc:lqmx) integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion) integer ido(lc:lqmx) @@ -880,10 +961,12 @@ MODULE module_mp_nssl_2mom ! new values for cs and ds real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient + real, parameter :: cp608 = 0.608 ! constant used in conversion of T to Tv real, parameter :: gr = 9.8 + real, parameter :: pi = 3.141592653589793 real, parameter :: piinv = 1./pi real, parameter :: pid4 = pi/4.0 @@ -896,11 +979,11 @@ MODULE module_mp_nssl_2mom real xvfmn, xvfmx ! min, max frozen drop volumes real xvgmn, xvgmx ! min, max graupel volumes real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes - real xvhlmn, xvhlmx ! min, max lg hail volumes + real xvhlmn, xvhlmx, xvhlmx0 ! min, max lg hail volumes - real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3 + real, parameter :: dhlmn = 0.3e-3 real, parameter :: dhmn0 = 0.3e-3 - real, public :: dhmn = dhmn0, dhmx = -1. + real, public :: dhmn = dhmn0, dhmx = -1., dhlmx = -1. ! 40.e-3 real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn ! minimum radius real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius @@ -922,8 +1005,10 @@ MODULE module_mp_nssl_2mom parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 ) ! mks parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 - parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx0=0.523599*(40.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + ! ! electrical permitivity of air C / (N m**2) - check the units @@ -952,6 +1037,7 @@ MODULE module_mp_nssl_2mom real, parameter :: esbolton = 6.112e2 real, parameter :: tfrh = 233.15 + real, parameter :: tfr = 273.15 real, parameter :: cp = 1004.0, rd = 287.04 @@ -963,7 +1049,9 @@ MODULE module_mp_nssl_2mom real, parameter :: tfrcbw = tfr - cbw real, parameter :: tfrcbi = tfr - cbi real, parameter :: rovcp = rd/cp + 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 @@ -981,8 +1069,11 @@ MODULE module_mp_nssl_2mom real :: cckm,ccne,ccnefac,cnexp,CCNE0 + integer :: na = 9 + integer :: nxtra = 1 + real gf4p5, gf4ds, gf4br real gsnow1, gsnow53, gsnow73 real gfcinu1, gfcinu1p47, gfcinu2p47 @@ -1001,22 +1092,60 @@ 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) + integer, private :: lcn_nu = 0 ! 27 ! need to check no conflict with other variables + integer, private :: lcn_ac = 0 ! 28 + integer, private :: lcn_co = 0 ! 29 + integer, private :: lcinp = 0 ! 30 + integer, public :: ac_opt = 0 ! option flag for: (1 and 2 currently for NUWRF only) + ! 0 : normal NSSL CCN physics + ! 1 : accumulation mode CN following Fridland et al. (2012, 2017), + ! where CCN number is sum of unactivated CCN and droplet concentrations + ! 2 : As for 1 but have three modes (but does not partition activated CCN) + ! 11: As for 1 but track activated CCN as a separate category (CN category advects only) + ! 22: As for 11 but 3 modes, each with its own activation tracer + real, public :: ac_wthresh = 10.0 ! for W < ac_wthresh, use max of sswater and diagnosed SS; otherwise use sswater logical, private :: nuaccoinp = .false. +! T.Iguchi Y2021 Update +! logical :: ac_only = .true. ! flag for considering ac_mode of CN only, or all nu,ac,co modes (still under construction) + + logical, public :: arg_para = .true. ! flag for Abdul-Razzak_and_Ghan parameterization works similarly to flag_qndrop, and neglects irenuc, ccna(mgs), and cnuc(mgs) + real, public :: nu_pmr = 7.5 * 1.e-3 * 1.e-6 ! aerosol radius (meter); these parameter values follow Cheng et al. (2007QJ) + real, public :: nu_pgw = 0.53 ! Unlike original Abdul-Razzak_and_Ghan, this value is used without log (Cheng et al. 2007QJ) + real, public :: nu_kappa = 0.07 ! ammonium sulfate as CCN (Petters and Kreidenweis, 2007ACP) + real, public :: ac_pmr = 3.8 * 1.e-2 * 1.e-6 ! aerosol radius (meter) + real, public :: ac_pgw = 0.69 + real, public :: ac_kappa = 0.61 ! ammonium sulfate as CCN (Petters and Kreidenweis, 2007ACP) + real, public :: co_pmr = 0.51 * 1.e-6 ! aerosol radius (meter) + real, public :: co_pgw = 0.77 + real, public :: co_kappa = 0.61 ! ammonium sulfate as CCN (Petters and Kreidenweis, 2007ACP) + + real, parameter :: cn_minlimit = 1.e3 ! 1.e3 m-3 = 0.001 cm-3 + + logical :: dm15_para = .false. ! flag for DeMott et al. (2015) parameterization for heterogenous freezing, regardless of "ibfc" + + ! 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 Ted Mansell if you have questions ! in that regard. NAMELIST /nssl_mp_params/ & +! nuwrf 3-mode params + ac_opt,arg_para, & + ac_kappa, ac_pmr, ac_pgw, & + nu_kappa, nu_pmr, nu_pgw, & + co_kappa, co_pmr, co_pgw, & + ccn_co, ccn_nu, & +! --- ndebug, ncdebug,& iusewetgraupel, & iusewethail, & iusewetsnow, & + icorrecthaildbz, icorrectfddbz, zxmincorr, cxmincorr, & idbzci, & vtmaxsed, & itfall,iscfall, & - infall,irfall,isfall, & + infall,irfall,isfall,iifall, & rssflg, & sssflg, & hssflg, & @@ -1025,15 +1154,15 @@ MODULE module_mp_nssl_2mom irimdenopt,rimdenvwgt, & rimc1, rimc2, rimc3, rimc4, & idiagnosecnu, & - icnuclimit, & - irenuc, & + icnuclimit,icondlimit, & + irenuc, ccn, & restoreccn, ccntimeconst, cck, & decayufccn, ufccntimeconst, & switchccn, old_cccn, & ciintmx, & itype1, itype2, & - icenucopt, in_freeze_rain_first, & - naer, & + icenucopt, inactopt, in_freeze_rain_first, & + naer,naerdust, & icfn, & ibfc, iacr, icracr, & icracrthresh, & @@ -1088,6 +1217,7 @@ MODULE module_mp_nssl_2mom ehimax, & ehsmax, & ecollmx, & + eiw0, esw0, & ehw0, ehlw0, & ehr0, ehlr0, & erw0, & @@ -1097,7 +1227,7 @@ MODULE module_mp_nssl_2mom iqcinit, & ssmxinit, & xvdmx, & - dhmn, dhmx, & + dhmn, dhmx, dhlmx, & fwms,fwmh,fwmhl, & ifwmhopt, & ihxw2rain, & @@ -1113,7 +1243,8 @@ MODULE module_mp_nssl_2mom rescale_low_alphah, & rescale_low_alphahl, & rescale_high_alpha, & - ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, incwet, & + wetgrthtoffset, hailcnvtoffset, & icvhl2h, hldnmn,hdnmn, & hlcnhdia, hlcnhqmin, & isedonly, & @@ -1146,6 +1277,7 @@ MODULE module_mp_nssl_2mom delta_alphamlr, & iqvsopt, & maxsupersat, & + do_accurate_sedimentation, interval_sedi_vt ! ##################################################################### ! ##################################################################### @@ -1156,12 +1288,15 @@ MODULE module_mp_nssl_2mom ! ##################################################################### + + REAL FUNCTION fqvs(t) implicit none real :: t fqvs = exp(caw*(t-273.15)/(t-cbw)) END FUNCTION fqvs + REAL FUNCTION fqis(t) implicit none real :: t @@ -1175,11 +1310,18 @@ END FUNCTION fqis + + + + ! ##################################################################### ! ##################################################################### + SUBROUTINE nssl_2mom_init( & + & ipctmp, mixphase,ihvol,idoniconlytmp,eqtset_tmp, index_ccna, index_cina, outfile, & - & namelist_filename, & + + & namelist_filename, internal_nml, & & nssl_graupelfallfac, & & nssl_hailfallfac, & & nssl_ehw0, & @@ -1194,10 +1336,17 @@ SUBROUTINE nssl_2mom_init( & & nssl_alphahl, & & nssl_alphar, & & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, & + & nssl_cina_on, & + & nssl_cinda_on, & + & nssl_ccn_opt, & + & nssl_icenucopt, & + & infileunit, & + & compute_dualpol, & & myrank, mpiroot & ) + implicit none real, intent(in), optional :: & @@ -1212,33 +1361,51 @@ SUBROUTINE nssl_2mom_init( & & nssl_alphahl, & & nssl_alphar integer, intent(in), optional :: & - & nssl_icdx, & + & nssl_icdx, & & nssl_icdxhl, myrank, mpiroot, & - & nssl_ufccn - logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on + & nssl_ufccn, & + & nssl_ccn_opt + integer, optional, intent(in) :: compute_dualpol, nssl_icenucopt + logical, intent(in), optional :: nssl_density_on, nssl_ccn_on, nssl_hail_on, nssl_icecrystals_on, & + nssl_cina_on,nssl_cinda_on integer, intent(inout), optional :: ccn_is_ccna integer, intent(in),optional :: infileunit + integer,parameter::strsize=512 - character(len=strsize), intent(in), optional :: namelist_filename - character(len=strsize) :: namelist_inputfile + + character(len=*), intent(in), optional :: internal_nml(:) + character(len=*), intent(in), optional :: namelist_filename + character(len=strsize) :: namelist_inputfile ! local string + logical :: read_internal = .false. + logical :: file_exist = .false. + logical :: is_initialized = .false. + integer, optional, intent(in) :: eqtset_tmp integer, optional, intent(in) :: index_ccna, index_cina, outfile + + + 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 + integer :: compute_dualpol_local = 0 - double precision :: arg + double precision :: arg,cwch real :: temq integer :: igam integer :: i,il,j,l @@ -1247,17 +1414,25 @@ SUBROUTINE nssl_2mom_init( & real :: bxh1,bxhl1 real :: alp,ratio - double precision :: x,y,y2,y7 - logical :: turn_on_ccna, turn_on_cina + double precision :: x,y,y2,y3,y7 + logical :: turn_on_ccna, turn_on_cina, turn_on_cinda integer :: iufccn = 0 integer :: istat real :: alpjj, alpii, xnuii, xnujj integer :: ii, jj - + + ! DTD: I don't think this is supposed to be here (preprocessing issue for CM1?) + ! nssl_params(11) is ipelec, so redo indices if it is not zero (inner grid) + ! IF ( is_initialized .and. nssl_params(11) == 0 ) RETURN + is_initialized = .true. + + + turn_on_ccna = .false. turn_on_cina = .false. + turn_on_cinda = .false. ! IF ( present( igvol ) ) THEN ! igvol_local = igvol @@ -1289,10 +1464,15 @@ SUBROUTINE nssl_2mom_init( & ENDIF ENDIF + IF ( present( compute_dualpol ) ) THEN + compute_dualpol_local = compute_dualpol + ENDIF + ! ! set some global values from namelist input ! + ! open(unit=20,file='namelist.input',form='formatted',status='old', & ! access='sequential') ! read(20,nml=micro_params) @@ -1308,6 +1488,7 @@ SUBROUTINE nssl_2mom_init( & + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac IF ( present(nssl_ehw0) ) THEN @@ -1334,70 +1515,112 @@ SUBROUTINE nssl_2mom_init( & ENDIF + ipconc = ipctmp - IF ( ipconc < 5 ) THEN - ihlcnh = 0 - ENDIF IF ( ihlcnh <= 0 ) THEN - IF ( ipconc == 5 ) THEN + IF ( ipconc < 5 ) THEN + ihlcnh = 0 + ELSEIF ( ipconc == 5 ) THEN + ihlcnh = 3 + ELSEIF ( ipconc >= 6 ) THEN ihlcnh = 3 ENDIF ENDIF - ! turn on active rain breakup by default for 3-moment rain since it has no implicit breakup from sedimentation - IF ( irainbreak == 0 .and. ipconc >= 6 ) THEN - irainbreak = 2 + IF ( imaxdiaopt <= 0 ) THEN + IF ( ipconc < 5 ) THEN + imaxdiaopt = 3 + ELSEIF ( ipconc == 5 ) THEN + imaxdiaopt = 3 + ELSEIF ( ipconc >= 6 ) THEN + imaxdiaopt = 1 + ENDIF ENDIF - - namelist_inputfile = 'namelist.input' ! default for WRF/1 - IF ( present( namelist_filename ) ) THEN + + + + +#ifdef INTERNAL_FILE_NML + read_internal = .true. + read (internal_nml, nml = nssl_mp_params, iostat=istat) +#endif + + namelist_inputfile = 'namelist.input' ! default for WRF/cm1 + IF ( present( namelist_filename ) ) THEN ! filename is passed in namelist_inputfile = namelist_filename ELSE ENDIF - open(15,file=namelist_inputfile,status='old',form='formatted',action='read') + + open(15,file=trim(namelist_inputfile),status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) close(15) - IF ( istat /= 0 ) THEN -#ifdef WRF_ELEC - IF ( wrf_dm_on_monitor() ) THEN - write(0,*) 'NSSL_2MOM_INIT: NSSL_MP_PARAMS namelist: not found or bad token' + + + + ! turn on active rain breakup by default for 3-moment rain since it has no implicit breakup from sedimentation + ! Check this after namelist read so that user can set irainbreak=0 to turn off + IF ( irainbreak == -1 ) THEN + IF ( ipconc >= 6 ) THEN + irainbreak = 2 + ELSE + irainbreak = 0 ENDIF -#else - ! write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' -#endif ENDIF - IF ( istat /= 0 ) THEN - IF ( present(myrank) ) THEN - IF ( myrank == 0 ) write(0,*) 'READ_NAMELIST: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + + IF ( icorrecthaildbz == -1 ) THEN + IF ( ipconc >= 6 ) THEN + icorrecthaildbz = 0 + ELSE + icorrecthaildbz = 1 ENDIF - ELSE - IF ( present(myrank) ) THEN - IF ( myrank == 0 ) write(0,*) 'Read nssl_mp_params' + ENDIF + + IF ( icorrectfddbz == -1 ) THEN + IF ( ipconc >= 6 ) THEN + icorrectfddbz = 0 + ELSE + icorrectfddbz = 1 ENDIF ENDIF -! IF ( present( outfile ) ) THEN -! IF ( outfile >= 0 ) THEN -! write(outfile,NML=nssl_mp_params) -! ENDIF -! ENDIF - IF ( present(myrank) ) THEN - myrankcm1 = myrank - IF ( myrank == 0 ) THEN + + IF ( present( nssl_icenucopt ) ) THEN + icenucopt = nssl_icenucopt + ENDIF + + + + IF ( present ( myrank ) .and. present ( mpiroot ) ) THEN + myrankcm1 = myrank + IF ( myrank == mpiroot ) THEN + IF ( istat /= 0 ) THEN + write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + ENDIF + +! write(0,*) 'iusewetsnow = ',iusewetsnow + + inquire(file='namelist.output', exist=file_exist) ! check for WRF standard namelist output + IF ( file_exist ) THEN + open(15,file='namelist.output',status='old',action='readwrite', position='append',form='formatted') + ELSE open(15,file='nssl_mp_params.out',status='unknown',form='formatted') - write(15,NML=nssl_mp_params) - close(15) - ENDIF - ENDIF + ENDIF + write(15,NML=nssl_mp_params) + close(15) + ENDIF ! rank=0 + ENDIF + + + @@ -1413,6 +1636,9 @@ SUBROUTINE nssl_2mom_init( & IF ( present( nssl_ccn_on ) ) THEN IF ( nssl_ccn_on ) THEN ccn_on = 1 + IF ( present( nssl_ccn_opt ) ) THEN + IF ( nssl_ccn_opt > 10 ) ac_opt = 22 + ENDIF ELSE ccn_on = 0 irenuc = 2 @@ -1423,8 +1649,11 @@ SUBROUTINE nssl_2mom_init( & turn_on_ccna = .true. IF ( present( nssl_ccn_on ) ) THEN IF ( .not. nssl_ccn_on ) THEN - write(0,*) 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!' + + write(0,*) 'NSSL_MP Error: Must have nssl_ccn_on=1/true for irenuc >= 5!' + STOP + ENDIF ENDIF ENDIF @@ -1441,6 +1670,13 @@ SUBROUTINE nssl_2mom_init( & cwccn = ccn + IF ( present( nssl_cina_on ) ) THEN + turn_on_cina = nssl_cina_on + ENDIF + IF ( present( nssl_cinda_on ) ) THEN + turn_on_cinda = nssl_cinda_on + ENDIF + lhab = 8 lhl = 8 IF ( icespheres >= 1 ) THEN @@ -1484,6 +1720,7 @@ SUBROUTINE nssl_2mom_init( & ENDIF + ! write(0,*) 'wrf_init: lhab,lhl,hail_on,density_on = ',lhab,lhl,hail_on,density_on ! IF ( ipelec > 0 ) idonic = .true. @@ -1506,6 +1743,8 @@ SUBROUTINE nssl_2mom_init( & tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + & & cai/(temq - cbi))*tabqis(l) + + end do bx(lr) = 0.85 @@ -1557,8 +1796,8 @@ SUBROUTINE nssl_2mom_init( & gmoi(igam) = gamma_dp(arg) end do - ! build lookup table to compute the number and mass fractions of rain drops - ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr + ! build lookup table to compute the number and mass fractions of particles + ! (mu=1) greater than a given diameter. Used for qiacr and ciacr ! 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) @@ -1570,6 +1809,7 @@ SUBROUTINE nssl_2mom_init( & alp = float(j)*dqiacralpha y = gamma_dpr(1.+alp) y2 = gamma_dpr(2.+alp) + y3 = gamma_dpr(real(3.+alp)) DO i = 0,nqiacrratio ratio = float(i)*dqiacrratio x = gamxinfdp( 1.+alp, ratio ) @@ -1586,6 +1826,7 @@ SUBROUTINE nssl_2mom_init( & gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y gamxinflu(i,j,12,1) = gamxinfdp( 2.0+alp, ratio )/y2 + gamxinflu(i,j,13,1) = gamxinfdp( 3.0+alp, ratio )/y3 ! hail (.,.,.,2) gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) @@ -1595,6 +1836,8 @@ SUBROUTINE nssl_2mom_init( & 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) + gamxinflu(i,j,12,2) = gamxinflu(i,j,12,1) + gamxinflu(i,j,13,2) = gamxinflu(i,j,13,1) IF ( alp > 1.1 ) THEN ! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y @@ -1664,16 +1907,24 @@ SUBROUTINE nssl_2mom_init( & lhw = 0 lhlw = 0 + denscale(:) = 0 + ! lccn = 9 IF ( ipconc == 0 ) THEN IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme - lvh = 9 - ltmp = 9 - denscale(lvh) = 1 + IF ( density_on >= 1 ) THEN ! turn on graupel density for 1-moment scheme + lvh = 9 + ltmp = 9 + denscale(lvh) = 1 + ELSE + ltmp = lhab + lvh = 0 + lvhl = 0 + ENDIF ELSE ! no hail, 'LFO' scheme ltmp = lhab lhl = 0 @@ -1720,6 +1971,7 @@ SUBROUTINE nssl_2mom_init( & ! ltmp = lhlw ENDIF ELSEIF ( ipconc >= 6 ) THEN + ltmp = lhab IF ( iufccn > 0 ) THEN ltmp = ltmp+1 @@ -1754,19 +2006,23 @@ SUBROUTINE nssl_2mom_init( & IF ( ipconc == 6 ) THEN ltmp = ltmp + 1 lzh = ltmp + denscale(lzh) = 1 ELSEIF ( ipconc == 7 ) THEN ltmp = ltmp + 1 lzh = ltmp ltmp = ltmp + 1 lzr = ltmp + denscale(lzh:lzr) = 1 ELSEIF ( ipconc == 8 ) THEN ltmp = ltmp + 1 lzh = ltmp ltmp = ltmp + 1 lzr = ltmp + denscale(lzh:lzr) = 1 IF ( lhl > 1 ) THEN ltmp = ltmp + 1 lzhl = ltmp + denscale(lzhl) = 1 ENDIF ! write(0,*) 'ipcon,lzr = ',ipconc,lzr,lzh,lzhl ENDIF @@ -1783,13 +2039,18 @@ SUBROUTINE nssl_2mom_init( & ENDIF ! ltmp = lhlw ENDIF + ELSE + write(0,*) 'nssl_2mom_init: Invalid value of ipctmp' STOP + ENDIF + + ! 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 @@ -1799,12 +2060,28 @@ SUBROUTINE nssl_2mom_init( & denscale(ltmp) = 1 ENDIF + IF ( turn_on_cina ) THEN + IF ( icenucopt == 5 ) THEN + ! error + ENDIF ltmp = ltmp + 1 lcina = ltmp denscale(ltmp) = 1 ENDIF + IF ( turn_on_cinda ) THEN + IF ( turn_on_cina ) THEN + ! assume option 6 + icenucopt = 6 + ELSE + icenucopt = 5 + ENDIF + ltmp = ltmp + 1 + lcinda = ltmp + denscale(ltmp) = 1 + ENDIF + IF ( turn_on_cin .or. is_aerosol_aware ) THEN ltmp = ltmp + 1 lcin = ltmp @@ -1812,7 +2089,8 @@ SUBROUTINE nssl_2mom_init( & !debug write(0,*) 'Setting lcin to ',lcin ENDIF na = ltmp - + + ln(:) = 0 ln(lc) = lnc ln(lr) = lnr ln(li) = lni @@ -1820,6 +2098,7 @@ SUBROUTINE nssl_2mom_init( & ln(lh) = lnh IF ( lhl .gt. 1 ) ln(lhl) = lnhl + ipc(:) = 0 ipc(lc) = 2 ipc(lr) = 3 ipc(li) = 1 @@ -1866,7 +2145,7 @@ SUBROUTINE nssl_2mom_init( & lliq(lh) = lhw IF ( lhl .gt. 1 ) lliq(lhl) = lhlw IF ( mixedphase ) THEN -! write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw +! write(0,*) 'lsw,lhw,lhlw,ltmp = ',lsw,lhw,lhlw,ltmp ENDIF @@ -1924,10 +2203,10 @@ SUBROUTINE nssl_2mom_init( & ELSE ! rain is gamma of diameter rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & - & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + & ((1. + alphah)*(2. + alphah)*(3. + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & - & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) rzs = & @@ -1937,14 +2216,17 @@ SUBROUTINE nssl_2mom_init( & ENDIF + rzhlh = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphah)*(2. + alphah)*(3. + alphah))/ & + & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(4. + alphah)*(5. + alphah)*(6. + alphah)) + IF ( ipconc <= 5 ) THEN - imltshddmr = Min(1, imltshddmr) +! imltshddmr = Min(1, imltshddmr) ibinhmlr = 0 ibinhlmlr = 0 ENDIF IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN - imltshddmr = Min(1, imltshddmr) +! imltshddmr = Min(1, imltshddmr) ENDIF ! write(0,*) 'rz,rzhl = ', rz,rzhl @@ -2022,11 +2304,23 @@ SUBROUTINE nssl_2mom_init( & ido(lh) = idohw IF ( lhl .gt. 1 ) ido(lhl) = idohl + linfall(:) = infall + linfall(lc) = 0 IF ( irfall .lt. 0 ) irfall = infall IF ( isfall .lt. 0 ) isfall = infall + IF ( iifall .lt. 0 ) iifall = infall IF ( lzr > 0 ) irfall = 0 + IF ( lzs > 0 ) isfall = 0 + IF ( lzh > 0 ) linfall(lh) = 0 + IF ( lzhl > 0 .and. lhl > 0 ) linfall(lhl) = 0 + IF ( lzr > 0 .and. lf > 0 ) linfall(lf) = 0 + linfall(lr) = irfall + linfall(ls) = isfall + linfall(li) = iifall qccn = ccn/rho00 + qccnco = ccn_co/rho00 + qccnnu = ccn_nu/rho00 qccnuf = ccnuf/rho00 IF ( old_cccn > 0.0 ) THEN old_qccn = old_cccn/rho00 @@ -2055,6 +2349,19 @@ SUBROUTINE nssl_2mom_init( & ELSE xvhmx = 0.523599*(dhmx)**3 ENDIF + + IF ( dhlmx <= 0.0 ) THEN + xvhlmx = xvhlmx0 + ELSE + xvhlmx = 0.523599*(dhlmx)**3 + ENDIF + + IF ( ipconc == 5 .and. imorrgdnglimit >= 1 ) THEN + ! convert morrdnglimit to xvhmx equivalent + cwch = ((3. + alphah)*(2. + alphah)*(1.0 + alphah))**(-1./3.) + xvhmx = pi/6.0*(morrdnglimit/cwch)**3 + dhmx = morrdnglimit/cwch + ENDIF IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh) IF ( qhacidn < 0. ) qhacidn = xdnmn(lh) @@ -2135,7 +2442,9 @@ SUBROUTINE nssl_2mom_init( & IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 + qxmin_init(:) = 1.0e-8 ! threshold for considering single-moment initial condition mixing ratios + ! constants for droplet nucleation cckm = cck-1. @@ -2145,7 +2454,9 @@ SUBROUTINE nssl_2mom_init( & ! if k (cck) is changed! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck)) + ! write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp + IF ( cwccn .lt. 0.0 ) THEN cwccn = Abs(cwccn) ccwmx = 50.e9 ! cwccn @@ -2242,33 +2553,38 @@ SUBROUTINE nssl_2mom_init( & iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ; iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; ENDIF - + + ! IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac ! IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac - RETURN END SUBROUTINE nssl_2mom_init ! ##################################################################### ! ##################################################################### + 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, & + cn, vhw, vhl, cna, cni, cndi, f_cn, f_cna, f_cina, f_cinda, & f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, & - cnuf, f_cnuf, & + cn_nu, cn_co, cinp, f_cnnu, f_cnco, f_cinp, & + cna_co, cna_nu, f_cnaco, f_cnanu, & + cnuf, f_cnuf, cn_ac, f_cnac, & 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, & + tt, th, pii, p, w, dn, dz, dtp, itimestep, first_step, & is_theta_or_temp, & ntmul, ntcnt, lastloop, & - RAIN,nrain,prate, & + + RAIN,hail,nrain,prate, & tcond,tevac,tevar,train, & ruh,rvh,rmh,rr, & dx, dy, & ib3d,ie3d,jb3d,je3d,kb3d,ke3d, & nout3d,out3d, & axtra, dorad, & + SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & SR,HAILNC, HAILNCV, & hail_maxk1, hail_max2d, nwp_diagnostics, & @@ -2282,8 +2598,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw rscghis_2d,rscghis_2dp,rscghis_2dn, & scr,scw,sci,scs,sch,schl,sctot, & elec_physics, & - induc,elecz,scion,sciona, & + induc,elecz,scion,sciona,f_scion,f_sciona, & noninduc,noninducp,noninducn, & + + ssat3d,ssati,nssl_ssat_output, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & rim1_2, rim2_2,rim3_2, & @@ -2297,12 +2615,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! re_liquid, re_graupel, re_hail, re_icesnow, & ! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & ipelectmp, & - diagflag,ke_diag, & + isedonly_in, & + diagflag,ke_diag,diag_dbz, & + refl_diagnostic,kdbz1km, & !LJR + nssl_progn, & ! wrf-chem ! 20130903 acd_mb_washout start wetscav_on, rainprod, evapprod, & ! wrf-chem ! 20130903 acd_mb_washout end cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added + ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte) ! tile dims @@ -2310,21 +2632,31 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + + + + + ! this line intentionally commented #ifdef MPI use mpi ! this line intentionally commented #endif + implicit none + !Subroutine arguments: + integer :: mytask = 0 integer, intent(in), optional :: & ids,ide, jds,jde, kds,kde + integer, intent(in):: & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte real, dimension(ims:ime, jms:jme, kms:kme), intent(inout):: & @@ -2337,7 +2669,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl 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, jms:jme, kms:kme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf + integer, optional, intent(in) :: nssl_ssat_output + real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cndi, cnuf + + real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout):: cn_nu, cn_ac, cn_co, cinp, cna_co, cna_nu + logical, optional, intent(in) :: f_cnnu, f_cnac, f_cnco, f_cinp, f_cnaco, f_cnanu + 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) @@ -2349,11 +2686,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout):: & induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(in) :: elecz ! elecsave = Ez - real, dimension(ims:ime, jms:jme, kms:kme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, jms:jme, kms:kme, 2),optional, intent(inout) :: scion real, dimension(ims:ime, jms:jme, kms:kme), intent(in):: p,w,dz,dn + real, dimension(ims:ime, jms:jme, kms:kme), intent(inout):: pii + real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout):: & + ssat3d, ssati, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & rim1_2, rim2_2,rim3_2, & @@ -2367,12 +2707,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! re_liquid, re_graupel, re_hail, re_icesnow, & ! vtcloud, vtrain, vtsnow, vtgraupel, vthail + real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout) :: axtra + + ! COMMAS vars integer, intent(in) :: nrain - real, dimension(ims:ime, jms:jme,nrain), intent(inout):: & - rain ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme,nrain), intent(inout), optional :: & + rain, hail ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, INTENT(INOUT) :: prate real, dimension(ims:ime, jms:jme) :: & ! used as local temp array in 1/COMMAS RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) @@ -2380,6 +2723,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR,HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) ! logical, parameter :: f_THPROC = .false. + ! extra vars for cm1 real*8, intent(inout) :: tcond,tevac,tevar,train REAL, DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(IN):: rmh, rr @@ -2387,26 +2731,36 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, intent(in), dimension(jms:jme) :: rvh logical, intent(in), optional :: dorad ! flag for radiation logical :: doradlocal + real*8, dimension(jte) :: bud1,bud2 + 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 double precision :: proctot(nproc),proctotmpi(nproc) + REAL, DIMENSION(ims:ime, jms:jme, kms:kme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, & re_rain, re_graup, re_hail + REAL, DIMENSION(ims:ime, jms:jme, kms:kme), optional, INTENT(IN):: tkediss + REAL, DIMENSION(ims:ime, jms:jme), optional, INTENT(INOUT):: refl_diagnostic ! 1km-ish reflectivity + integer, DIMENSION(ims:ime, jms:jme), optional, INTENT(IN):: kdbz1km ! index of level just below 1km 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) :: first_step 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) :: diagflag, f_cna, f_cn, f_cina, f_cinda, f_cnuf, diag_dbz logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl - integer, optional, intent(in) :: ipelectmp, ke_diag + logical, optional, intent(in) :: f_scion,f_sciona + integer, optional, intent(in) :: ipelectmp, ke_diag, isedonly_in + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem @@ -2418,8 +2772,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw logical :: flag_ccn = .false. logical :: flag_qi = .true. logical :: has_reqr_local = .false., has_reqg_local = .false., has_reqh_local = .false. + logical :: flag logical :: nwp_diagflag = .false. + integer :: compute_dualpol_local = 0 real :: cinchange, t7max,testmax,wmax ! 20130903 acd_ck_washout start @@ -2436,18 +2792,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw INTEGER, optional, intent(in) :: cu_used LOGICAL, optional, intent(in) :: wetscav_on + integer, intent(in) :: ib3d,ie3d,jb3d,je3d,kb3d,ke3d,nout3d real, intent(inout) , dimension(ib3d:ie3d,jb3d:je3d,kb3d:ke3d,nout3d) :: out3d + ! ! local variables ! real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab + ! real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+ 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, 4) :: alpha2d + + real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9,t7d 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 @@ -2471,6 +2831,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, parameter :: cnin2a = 12.96 real, parameter :: cnin2b = 0.639 + double precision :: cwmass1,cwmass2 double precision :: rwmass1,rwmass2 double precision :: icemass1,icemass2 @@ -2480,16 +2841,18 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: wvol5,wvol10 real :: tmp,dv,dv1,tmpchg real :: rdt + real :: temp1, c1 double precision :: dt1,dt2 double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed double precision :: timevtcalc,timesetvt - logical :: f_cnatmp, f_cinatmp, f_cnacotmp, f_cnanutmp + logical :: f_cnatmp, f_cinatmp, f_cindatmp, f_cnacotmp, f_cnanutmp logical :: has_wetscav integer :: kediagloc integer :: iunit + integer :: isedonly_local real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot real :: fach(kts:kte) @@ -2498,16 +2861,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw integer :: loopcnt, loopmax, outerloopcnt logical :: lastlooptmp + logical :: is_first_step ! for initializing Z moments when restarting from 2-moment + ! -#if defined(MPI) +#if defined(MPI) || defined( WRF_ELEC ) + INTEGER :: mpi_error_code = 1 #endif + ! ------------------------------------------------------------------- + rdt = 1.0/dtp IF ( debugdriver ) write(0,*) 'N2M: entering routine' @@ -2518,7 +2886,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw flag_cnuf = .false. flag_ccn = .false. nwp_diagflag = .false. - + is_first_step = .false. + + IF ( present( first_step ) ) THEN + is_first_step = first_step + ELSEIF ( itimestep == 1 ) THEN + is_first_step = .true. + ENDIF + 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 ) @@ -2541,6 +2916,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( .not. flag_qi .and. ffrzs < 1.0 ) ffrzs = 1.0 + IF ( PRESENT ( has_reqr ) ) has_reqr_local = has_reqr > 0 IF ( PRESENT ( has_reqg ) ) has_reqg_local = has_reqg > 0 @@ -2574,6 +2950,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSE f_cinatmp = .false. ENDIF + + IF ( present( f_cinda ) ) THEN + f_cindatmp = f_cinda + ELSE + f_cindatmp = .false. + ENDIF IF ( present( vzf ) ) vzflag0 = 1 @@ -2582,6 +2964,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSE ipelec = 0 ENDIF + + IF ( present( isedonly_in ) ) THEN + isedonly_local = isedonly_in + ELSE + isedonly_local = 0 + ENDIF + ! IF ( present( dbz ) ) THEN ! DO jy = jts,jte ! DO kz = kts,kte @@ -2600,11 +2989,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw dy1 = 1.0 ENDIF + makediag = .true. IF ( present( diagflag ) ) THEN makediag = diagflag .or. itimestep == 1 + IF ( diagflag ) cleardiag = .true. + ENDIF IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag @@ -2622,9 +3014,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + + ! ENDIF ! itimestep == 1 + ! sedimentation settings infdo = 2 @@ -2635,13 +3030,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw infdo = 0 ENDIF - IF ( infall .ge. 3 .or. ipconc .ge. 6 ) THEN + IF ( Any(linfall(:) .ge. 3 ) .or. ipconc .ge. 6 ) THEN infdo = 2 ENDIF - + IF (present( HAILNCV ) ) HAILNCV(its:ite,jts:jte) = 0. + tke2d(:,:) = 0.0 ! initialize if not used lnb = Max(lh,lhl)+1 ! lnc @@ -2669,43 +3065,58 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + IF ( debugdriver ) write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) ancuten(its:ite,1,kts:kte,:) = 0.0 thproclocal(:,:) = 0.0 + proctot(:) = 0 + + +#if (defined (OPENMP) ) !$OMP PARALLEL DO DEFAULT(SHARED) & -!$OMP PRIVATE(ix,jy,kz,xfall,axtra2d,an,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9, & +!$OMP PRIVATE(ix,jy,kz,xfall,axtra2d,an,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9,t7d, & !$OMP t00,t77,dbz2d,vzf2d,dn1,pn,wn,dz2d,dz2dinv,ltemq,ssival,dp1, & !$OMP elec2,thproclocal,t8s,t9s,il,n,ssat,loopcnt, & !$OMP qvapor,ssifac,ancuten,rainprod2d,evapprod2d,kediagloc,alpha2d, & + !$OMP hailmax1d,hailmaxk1) ! need to figure out how to treat thproc: with a critical section? +#endif DO jy = jts,jye ! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn - IF ( present( pcc2 ) .and. makediag ) THEN + + IF ( ( present( pcc2 ) .or. present( axtra ) ) .and. makediag ) THEN + axtra2d(its:ite,1,kts:kte,:) = 0.0 ENDIF - IF ( nwp_diagflag ) THEN + IF ( nwp_diagflag .or. compute_dualpol_local > 0 ) 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 + + ! for now, only using thproclocal for domain totals thproclocal(:,:) = 0.0 + ! copy from 3D array to 2D slab DO kz = kts,kte DO ix = its,ite + an(ix,1,kz,lt) = th(ix,jy,kz) + an(ix,1,kz,lv) = qv(ix,jy,kz) an(ix,1,kz,lc) = qc(ix,jy,kz) an(ix,1,kz,lr) = qr(ix,jy,kz) @@ -2719,7 +3130,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,jy,kz) IF ( lccn > 1 ) THEN IF ( is_aerosol_aware .and. flag_qnwfa ) THEN + ! + ELSEIF ( flag_ccn ) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN an(ix,1,kz,lccna) = cn(ix,jy,kz) @@ -2732,14 +3145,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ELSE IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN + an(ix,1,kz,lccn) = qccn - ccw(ix,jy,kz) + ELSE + an(ix,1,kz,lccn) = qccn + ENDIF 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,jy,kz) ) @@ -2750,16 +3168,24 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lccna > 1 ) THEN IF ( present( cna ) .and. f_cnatmp ) THEN - an(ix,1,kz,lccna) = cna(ix,jy,kz) + an(ix,1,kz,lccna) = Max(0.0, cna(ix,jy,kz) ) ENDIF ENDIF + IF ( lcina > 1 ) THEN IF ( present( cni ) .and. f_cinatmp ) THEN an(ix,1,kz,lcina) = cni(ix,jy,kz) ENDIF ENDIF + IF ( lcinda > 1 ) THEN + IF ( present( cndi ) .and. f_cindatmp ) THEN + ! icenucopt = 6 + an(ix,1,kz,lcinda) = cndi(ix,jy,kz) + ENDIF + ENDIF + IF ( ipconc >= 5 ) THEN an(ix,1,kz,lnc) = ccw(ix,jy,kz) IF ( constccw > 0.0 ) THEN @@ -2775,17 +3201,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw an(ix,1,kz,lnh) = chw(ix,jy,kz) IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,jy,kz) ENDIF - IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,jy,kz) + IF ( lvh > 0 .and. present( vhw ) ) an(ix,1,kz,lvh) = vhw(ix,jy,kz) IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,jy,kz) + IF ( ipconc >= 6 ) THEN IF ( lzr > 0 ) an(ix,1,kz,lzr) = zrw(ix,jy,kz)*zscale IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,jy,kz)*zscale IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,jy,kz)*zscale ENDIF + + + + ENDDO ENDDO @@ -2793,8 +3224,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO ix = its,ite + t0(ix,1,kz) = th(ix,jy,kz)*pii(ix,jy,kz) ! temperature (Kelvin) - t00(ix,1,kz) = 380.0/p(ix,jy,kz) + + t00(ix,1,kz) = 380.0/p(ix,jy,kz) ! 380 = 0.622*6.112*100 (0.622=rd/rw; 6.112 from formula fit; 100 to convert mb to Pa) t77(ix,1,kz) = pii(ix,jy,kz) dbz2d(ix,1,kz) = 0.0 vzf2d(ix,1,kz) = 0.0 @@ -2823,10 +3256,13 @@ 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 + t7d(ix,1,kz) = 0.0 pn(ix,1,kz) = p(ix,jy,kz) wn(ix,1,kz) = w(ix,jy,kz) + dn1(ix,1,kz) = dn(ix,jy,kz) + ! wmax = Max(wmax,wn(ix,1,kz)) dz2d(ix,1,kz) = dz(ix,jy,kz) dz2dinv(ix,1,kz) = 1./dz(ix,jy,kz) @@ -2849,6 +3285,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 @@ -2899,8 +3336,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw end if - ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 + ELSEIF ( icenucopt == 4 .or. icenucopt == 5 .or. icenucopt == 6 ) THEN + IF ( icenucopt == 4 .or. icenucopt == 6 ) THEN ! DeMott 2010 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, @@ -2909,7 +3347,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! naer needs units of cm**-3, so mult by 1.e-6 ! 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) @@ -2917,6 +3357,28 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! t7(ix,1,kz) = 0.0 ENDIF + ELSEIF ( icenucopt == 5 .or. icenucopt == 6 ) THEN ! DeMott 2015 + + IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + + ! cf = 1, alpha=0, beta = 1.25, gamma = 0.46, delta = -11.6 + ! nint = cf * naer**(alpha*(-Tc) + beta) *exp(gamma*(-Tc) + delta) + ! nint = 1.0 * naer**( beta) *exp(gamma*(-Tc) + delta) + ! 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 + + + tmp = 1.e-6*naerdust + + ! 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*dn1(ix,1,kz)/rho00* (tmp)**(1.25)*exp( 0.46*(273.16 - t0(ix,1,kz)) - 11.6) + t7d(ix,1,kz) = Min(dp1, 1.0d30) + + ELSE + t7d(ix,1,kz) = 0.0 + ENDIF + ENDIF ! demott options + ENDIF ! icenucopt @@ -2937,6 +3399,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! transform from number mixing ratios to number conc. + IF ( loopcnt == 1 ) THEN DO il = lnb,na IF ( denscale(il) == 1 ) THEN @@ -2949,6 +3412,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! il ENDIF + ! sedimentation xfall(:,:,:) = 0.0 @@ -2957,8 +3421,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! IF ( .true. ) THEN -! for real cases when hydrometeor mixing ratios have been initialized without concentrations - IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN + +! for real cases when hydrometeor mixing ratios have been initialized without concentrations (or without Z moments) + IF ( (itimestep == 1 .or. (is_first_step .and. ipconc > 5) ) .and. & + ipconc > 0 .and. loopcnt == 1 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) ENDIF @@ -2980,29 +3446,19 @@ 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 !} - - + IF ( isedonly_local == 0 ) THEN + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & & t0,t7,infdo,jy,its,jts & & ,timesed1,timesed2,timesed3,zmaxsed,timesetvt) + ! copy xfall to appropriate places... IF ( debugdriver ) write(0,*) 'N2M: end sediment, jy = ',jy @@ -3018,11 +3474,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF IF ( present ( rainncw2 ) ) THEN ! rain only - rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) + rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) ENDIF IF ( present ( rainnci2 ) ) THEN ! ice only IF ( lhl > 1 ) THEN - rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) ELSE rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & @@ -3031,15 +3487,37 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF 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 ( lhw > 0 ) THEN + tmp = xfall(ix,1,lhw) ! subtract liquid fraction from ice accumulation + ELSE + tmp = 0.0 + ENDIF + IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel + IF ( lhlw > 0 ) tmp = tmp + xfall(ix,1,lhlw) + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl) - tmp) *1000./xdn0(lr) + ELSE + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh)-tmp)*1000./xdn0(lr) + ENDIF + ENDIF + + + IF ( present( hail ) ) THEN IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel - GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + tmp = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) ELSE - GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + tmp = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) ENDIF + do n = 1,nrain + hail(ix,jy,n) = hail(ix,jy,n) + 0.1*tmp + enddo ENDIF + + IF ( loopcnt == loopmax ) RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) - IF ( loopcnt == loopmax ) THEN + + + IF ( loopcnt == loopmax .and. present( rain ) ) THEN do n = 1,nrain RAIN(ix,jy,n) = RAIN(ix,jy,n) + 0.1*RAINNCV(ix,jy) enddo @@ -3053,16 +3531,18 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! bud2(jy) = bud2(jy) - rr(ix,jy,kz)*PRE(kz)*ruh(ix)*rvh(jy)*rmh(ix,jy,kz)*tem1 ! enddo + 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 1 -! IF ( .true. ) THEN -!#else IF ( present( HAILNC ) ) THEN -!#endif - HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + IF ( lhlw > 0 ) THEN + tmp = xfall(ix,1,lhlw) ! subtract liquid fraction from ice accumulation + ELSE + tmp = 0.0 + ENDIF + HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lhl)-tmp)*1000./xdn0(lr) 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) @@ -3071,10 +3551,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( GRPLNCV ) .and. loopcnt == loopmax ) THEN GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) ENDIF + ENDDO + ENDIF ! isedonly_local + ! ENDIF ! .false. + IF ( isedonly /= 1 ) THEN ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics @@ -3082,11 +3566,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! IF ( isedonly /= 2 ) THEN + call nssl_2mom_gs & & (nx,ny,nz,na,jy & & ,nor,nor & & ,dtp,dz2d & - & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9,t7d & & ,an,dn1,t77 & & ,pn,wn,0 & & ,t00,t77, & @@ -3098,6 +3583,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & thproclocal,nproc,dx1,dy1,ngs, & & timevtcalc,axtra2d, makediag & & ,has_wetscav, rainprod2d, evapprod2d, alpha2d & + & ,elec2,its,ids,ide,jds,jde & & ) @@ -3105,6 +3591,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + + + + ENDIF ! isedonly /= 1 ! droplet nucleation/condensation/evaporation @@ -3117,9 +3607,20 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,an,dn1,t77 & & ,pn,wn & & ,ngs & + & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) +! Clean up tiny values of mixing ratio and final checks on max/min sizes + CALL smallvalues & + & (nx,ny,nz,na,jy & + & ,nor,nor,dtp,nx & + & ,t0 & + & ,an,dn1,wn & + & ,t77,flag_qndrop) + + + ENDIF @@ -3127,32 +3628,76 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + 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,jy,kz) = axtra2d(ix,1,kz,1) + ENDDO ENDDO ENDIF + IF ( ( present( ssat3d ) .and. present( nssl_ssat_output ) ) .and. makediag ) THEN + DO kz = kts,kte + DO ix = its,ite + + ! updated temperature and qv + temp1 = t0(ix,1,kz) ! an(ix,1,kz,lt)*t77(ix,1,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + IF ( present( ssat3d ) .and. nssl_ssat_output >= 1 ) THEN + +! c1 = t00(ix,1,kz)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + c1 = (380.0/pn(ix,1,kz))*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + c1 = rdorv*esbolton*tabqvs(ltemq)/(pn(ix,1,kz) - esbolton*tabqvs(ltemq)) + ENDIF + + IF ( c1 > 0. ) THEN + ssat3d(ix,jy,kz) = 100.*(an(ix,1,kz,lv)/c1 - 1.0) ! from "new" values + ENDIF + + ENDIF + + IF ( present( ssati ) .and. nssl_ssat_output >= 2 ) THEN + t9s = (380.0/pn(ix,1,kz))*tabqis(ltemq) !saturation mixing ratio wrt ice + ssati(ix,jy,kz) = 100.*(an(ix,1,kz,lv)/t9s - 1.0) ! Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + ENDIF + + ENDDO + ENDDO + ENDIF + + + + ! compute diagnostic S-band reflectivity if needed IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN ! calc dbz IF ( .true. ) THEN + IF ( present(ke_diag) ) THEN kediagloc = ke_diag ELSE kediagloc = nz ENDIF call radardd02(nx,ny,nz,nor,na,an,t0, & + & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0) + ENDIF ! .false. + DO kz = kts,kediagloc ! kte DO ix = its,ite @@ -3169,20 +3714,44 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( compdbz ) ) THEN compdbz(ix,jy) = Max( compdbz(ix,jy), dbz2d(ix,1,kz) ) ENDIF + IF ( present( refl_diagnostic ) .and. present( diag_dbz ) .and. present( kdbz1km ) ) THEN + IF (diag_dbz) then + refl_diagnostic(ix,jy) = dbz2d(ix,1,kdbz1km(ix,jy)) + ! print*, "after refl_diagnostic" + ENDIF + ENDIF ENDDO ENDDO ENDIF + IF ( present( refl_diagnostic ) .and. present( diag_dbz ) .and. present( kdbz1km ) ) THEN + IF (diag_dbz .and. .not. makediag ) then + ! compute diagnostics S-band refelctivity at chosen levels at every time step + !print*, "computing 1 level reflectivity" + call radardd02(nx,ny,nz,nor,na,an,t0, & + & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0, & + & zdbz_start=Minval(kdbz1km(its:ite,jy)), zdbz_end=Maxval(kdbz1km(its:ite,jy)) ) + + do ix = its, ite + refl_diagnostic(ix,jy) = dbz2d(ix,1,kdbz1km(ix,jy) ) + enddo + + ENDIF + ENDIF + + ! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F + IF ( present( dorad ) ) THEN doradlocal = dorad ELSE doradlocal = .true. ENDIF IF ( doradlocal ) THEN + IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) .and. & lastlooptmp) THEN @@ -3249,9 +3818,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + ENDIF ! dorad + + + IF ( present( hail_maxk1 ) .and. present( hail_max2d ) .and. nwp_diagflag ) THEN DO ix = its,ite hailmax1d(ix,1) = hail_max2d(ix,jy) @@ -3268,6 +3841,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ENDIF ENDIF + ! transform concentrations back to mixing ratios DO il = lnb,na IF ( denscale(il) == 1 ) THEN @@ -3278,6 +3852,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDIF ENDDO ! il + ! copy 2D slabs back to 3D @@ -3285,11 +3860,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO kz = kts,kte DO ix = its,ite + th(ix,jy,kz) = an(ix,1,kz,lt) + + IF ( eqtset > 2 ) THEN pii(ix,jy,kz) = t77(ix,1,kz) ENDIF + qv(ix,jy,kz) = an(ix,1,kz,lv) qc(ix,jy,kz) = an(ix,1,kz,lc) qr(ix,jy,kz) = an(ix,1,kz,lr) @@ -3299,7 +3878,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) qhl(ix,jy,kz) = an(ix,1,kz,lhl) IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN + ! not used here + ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN cn(ix,jy,kz) = Max(0.0, an(ix,1,kz,lccna) ) @@ -3313,11 +3894,17 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + IF ( lcina > 1 ) THEN IF ( present( cni ) .and. f_cinatmp ) THEN cni(ix,jy,kz) = Max(0.0, an(ix,1,kz,lcina) ) ENDIF ENDIF + IF ( lcinda > 1 ) THEN + IF ( present( cndi ) .and. f_cindatmp ) THEN + cndi(ix,jy,kz) = Max(0.0, an(ix,1,kz,lcinda) ) + 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 @@ -3334,6 +3921,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + IF ( ipconc >= 5 ) THEN ccw(ix,jy,kz) = an(ix,1,kz,lnc) @@ -3344,6 +3932,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) chl(ix,jy,kz) = an(ix,1,kz,lnhl) ENDIF + IF ( ipconc >= 6 ) THEN IF ( lzr > 0 ) zrw(ix,jy,kz) = an(ix,1,kz,lzr) *zscaleinv IF ( lzh > 0 ) zhw(ix,jy,kz) = an(ix,1,kz,lzh) *zscaleinv @@ -3352,7 +3941,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw - IF ( lvh > 0 ) vhw(ix,jy,kz) = an(ix,1,kz,lvh) + + + + IF ( lvh > 0 .and. present( vhw ) ) vhw(ix,jy,kz) = an(ix,1,kz,lvh) IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,jy,kz) = an(ix,1,kz,lvhl) #if ( WRF_CHEM == 1 ) @@ -3380,20 +3972,28 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw !$OMP END CRITICAL ENDIF + ENDDO ! jy + DO jy = jts,jte DO ix = its,ite train = train + RAINNCV(ix,jy)*ruh(ix)*rvh(jy)*dx*dy ENDDO ENDDO + + + + + + 11 format('processes: ',100(1x,1pe12.5)) IF ( nproc > 1 ) THEN #ifdef MPI @@ -3408,12 +4008,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF + RETURN END SUBROUTINE nssl_2mom_driver + ! ##################################################################### ! ##################################################################### + REAL FUNCTION GAMMA_SP(xx) implicit none @@ -3432,7 +4035,9 @@ REAL FUNCTION GAMMA_SP(xx) IF ( xx <= 0.0 ) THEN write(0,*) 'Argument to gamma must be > 0!! xx = ',xx + STOP + ENDIF x = xx @@ -3451,6 +4056,7 @@ END FUNCTION GAMMA_SP ! ##################################################################### + DOUBLE PRECISION FUNCTION GAMMA_DPR(x) ! dp gamma with real input implicit none @@ -3469,6 +4075,7 @@ end FUNCTION GAMMA_DPR ! ##################################################################### + real function GAMXINF(A1,X1) ! =================================================== @@ -3496,7 +4103,9 @@ real function GAMXINF(A1,X1) XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN WRITE(*,*)'a and/or x too large' + STOP + ENDIF IF (X.EQ.0.0) THEN GIN=0.0 @@ -3528,6 +4137,7 @@ END function GAMXINF ! ##################################################################### + double precision function GAMXINFDP(A1,X1) ! =================================================== @@ -3557,7 +4167,9 @@ double precision function GAMXINFDP(A1,X1) XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN WRITE(*,*)'a and/or x too large' + STOP + ENDIF IF (X.EQ.0.0) THEN GIN=0.0 @@ -3590,6 +4202,7 @@ END function GAMXINFDP ! ##################################################################### + real function gaminterp(ratio, alp, luindex, ilh) implicit none @@ -3640,6 +4253,7 @@ END FUNCTION gaminterp ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 40 micron drops) ! ********************************************************** + real FUNCTION GAML02(x) implicit none integer ig, i, ii, n, np @@ -3682,6 +4296,7 @@ END FUNCTION GAML02 ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb) ! ********************************************************** + real FUNCTION GAML02d300(x) implicit none integer ig, i, ii, n, np @@ -3728,6 +4343,7 @@ END FUNCTION GAML02d300 ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 500 micron drops) (see zieglerstuff.nb) ! ********************************************************** + real FUNCTION GAML02d500(x) implicit none integer ig, i, ii, n, np @@ -3798,6 +4414,7 @@ END function BETA ! ##################################################################### ! ##################################################################### + DOUBLE PRECISION FUNCTION GAMMA_DP(xx) implicit none @@ -3829,6 +4446,7 @@ DOUBLE PRECISION FUNCTION GAMMA_DP(xx) END function gamma_dp ! ##################################################################### + SUBROUTINE GAMMADP(X,GA) ! ! ================================================== @@ -3846,6 +4464,19 @@ SUBROUTINE GAMMADP(X,GA) integer :: k,m1,m double precision :: G(26) + + DATA G/1.0D0,0.5772156649015329D0, & + & -0.6558780715202538D0, -0.420026350340952D-1, & + & 0.1665386113822915D0,-.421977345555443D-1, & + & -.96219715278770D-2, .72189432466630D-2, & + & -.11651675918591D-2, -.2152416741149D-3, & + & .1280502823882D-3, -.201348547807D-4, & + & -.12504934821D-5, .11330272320D-5, & + & -.2056338417D-6, .61160950D-8, & + & .50020075D-8, -.11812746D-8, & + & .1043427D-9, .77823D-11, & + & -.36968D-11, .51D-12, & + & -.206D-13, -.54D-14, .14D-14, .1D-15/ IF (X.EQ.INT(X)) THEN IF (X.GT.0.0D0) THEN @@ -3869,18 +4500,6 @@ SUBROUTINE GAMMADP(X,GA) ELSE Z=X ENDIF - DATA G/1.0D0,0.5772156649015329D0, & - & -0.6558780715202538D0, -0.420026350340952D-1, & - & 0.1665386113822915D0,-.421977345555443D-1, & - & -.96219715278770D-2, .72189432466630D-2, & - & -.11651675918591D-2, -.2152416741149D-3, & - & .1280502823882D-3, -.201348547807D-4, & - & -.12504934821D-5, .11330272320D-5, & - & -.2056338417D-6, .61160950D-8, & - & .50020075D-8, -.11812746D-8, & - & .1043427D-9, .77823D-11, & - & -.36968D-11, .51D-12, & - & -.206D-13, -.54D-14, .14D-14, .1D-15/ GR=G(26) DO K=25,1,-1 GR=GR*Z+G(K) @@ -3900,6 +4519,7 @@ END SUBROUTINE GAMMADP ! ! ! ##################################################################### + Function delbk(bb,nu,mu,k) ! ! Purpose: Caluculates collection coefficients following Siefert (2006) @@ -3955,6 +4575,7 @@ END Function delbk ! ! ##################################################################### ! Equation (91) in Seifert and Beheng (2006) ("a" collecting "b") + Function delabk(ba,bb,nua,nub,mua,mub,k) implicit none @@ -3973,7 +4594,9 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) del = tmp - dgam*i IF ( i+1 > ngm0 ) THEN write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp + STOP + ENDIF g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami ! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) @@ -4014,11 +4637,14 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) END Function delabk + + ! ##################################################################### ! ! ! ##################################################################### + REAL FUNCTION cnudiag(ccw) ! function to diagnose cloud drop DSD shape parameter (cnu) based on Chandrakar et al. 2016 (PNAS) data @@ -4071,6 +4697,8 @@ REAL FUNCTION cnudiag(ccw) RETURN END FUNCTION cnudiag + + ! ##################################################################### ! ! ##################################################################### @@ -4089,9 +4717,11 @@ end subroutine cld_cpu ! !-------------------------------------------------------------------------- ! + ! ####################################################################### ! HAILMAXD - calculated maximum expected hail size ! ####################################################################### + subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & & hailmax1d,hailmaxk1,jslab ) ! @@ -4320,6 +4950,7 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & END SUBROUTINE HAILMAXD ! ####################################################################### ! ####################################################################### + 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 @@ -4332,6 +4963,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! implicit none + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia integer id ! =1 use density, =0 no density integer :: its,jts ! SW point of local tile @@ -4443,10 +5075,12 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & jgs = jy + ! ! zero the precip flux arrays (2d) ! + xvt(:,:,:,:) = 0.0 if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' @@ -4486,6 +5120,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2' ! loop over columns @@ -4493,6 +5128,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & dummy = 0.d0 + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & & xvt, rhovtzx, & @@ -4503,9 +5139,11 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & & cnostmp, & & infdo,0 & + & ) + ! loop over each species and do sedimentation for all moments DO il = lc,lhab IF ( ido(il) == 0 ) CYCLE @@ -4516,6 +5154,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! phi = 0 + vtmax = 0.0 do kz = kzb,kze @@ -4540,6 +5179,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ENDIF ENDDO + IF ( vtmax == 0.0 ) CYCLE @@ -4566,6 +5206,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & dtfrac = dtptmp/dtp + DO n = 1,ndfall IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN @@ -4575,6 +5216,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & dummy = 0.d0 + xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & @@ -4598,15 +5240,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & + ENDIF ! (n .ge. 2) - 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 ) .or. (il == ls .and. isfall == infall ) ) THEN + + IF ( il >= lr .and. ( linfall(il) .eq. 3 .or. linfall(il) .eq. 4 ) .and. ln(il) > 0 ) 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 ENDIF if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b' @@ -4617,6 +5258,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & an,db1,il,1,xfall,dtz1,ix) + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c' ! volume @@ -4628,6 +5270,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF ENDIF + ! reflectivity IF ( ipconc .ge. 6 ) THEN @@ -4637,40 +5280,32 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF ENDIF + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' IF ( ipconc .gt. 0 ) THEN !{ IF ( ipconc .ge. ipc(il) ) THEN - IF ( ( infall .ge. 2 .or. (infall .eq. 0 .and. il .lt. lh) ) .and. lz(il) .lt. 1) THEN !{ + IF ( ( linfall(il) .ge. 2 ) .and. lz(il) .lt. 1) THEN !{ ! ! load number conc. into tmpn to do fallout by mass-weighted mean fall speed ! to put a lower bound on number conc. ! - 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 + IF ( linfall(il) == 3 .or. linfall(il) == 4 ) THEN + ! set up for method I or I+II DO kz = kzb,kze -! DO ix = ixb,ixe tmpn2(ix,jy,kz) = z(ix,kz,il) -! ENDDO ENDDO DO kz = kzb,kze -! DO ix = ixb,ixe tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) -! ENDDO 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)) -! ENDDO ENDDO ENDIF @@ -4681,17 +5316,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f' in = 2 - IF ( infall .eq. 1 ) in = 1 + IF ( linfall(il) .eq. 1 ) in = 1 call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & & an,db1,ln(il),0,xfall,dtz1,ix) - IF ( lz(il) .lt. 1 ) THEN ! if not 3-moment, run one of the correction schemes - IF ( (infall .ge. 2 .or. infall .eq. 3) .and. .not. (infall .eq. 0 .and. il .ge. lh) & - & .and. ( il .eq. lr .or. (il .ge. li .and. il .le. lhab) )) THEN -! : .or. il .eq. lhl )) THEN - + IF ( lz(il) .lt. 1 ) THEN ! { if not 3-moment, run one of the correction schemes + IF ( linfall(il) >= 2 ) THEN xfall0(:,jgs) = 0.0 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & @@ -4706,42 +5338,38 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & tmpn,db1,1,0,xfall0,dtz1,ix) ENDIF - IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & - & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) THEN -! "Method I" - dbz correction - + IF ( linfall(il) == 3 .or. linfall(il) == 4 ) THEN + ! "Method I" - dbz correction + ! Uses input tmpn2 (temp. Z-moment) to determine if new N and q values in an(:,:,:,ln(il)) + ! cause an increase in reflectivity moment. If so, either use N from mass-wgt Vt (tmpn) to replace + ! new N (infall=3; I) or use smaller N from tmpn or calculated from q and temporary Z (infall=4; I+II) + ! Uses 'z' array to check if new reflectivity is greater than pre-sedimentation reflectivity 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), xdn0(il), infall, ix) - ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN + ELSEIF ( linfall(il) .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN DO kz = kzb,kze -! DO ix = ixb,ixe an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) )) - -! ENDDO ENDDO 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 -! DO ix = ixb,ixe - an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) ) - -! ENDDO ENDDO - ENDIF - ENDIF ! lz(il) .lt. 1 + ENDIF !} + ENDIF - ENDIF - ENDIF + ENDIF !} lz(il) .lt. 1 + ENDIF ! ipconc > ipc - ENDIF !} + ENDIF !} (ipconc > 0) + ENDDO ! n=1,ndfall @@ -4750,6 +5378,7 @@ 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) @@ -4788,6 +5417,7 @@ END SUBROUTINE SEDIMENT1D ! !-------------------------------------------------------------------------- ! + subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & & a,db1,ia,id,xfall,dtz1,ixcol) ! @@ -4898,6 +5528,7 @@ END SUBROUTINE FALLOUT1D ! ############################################################################## ! ############################################################################## + subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol) @@ -4924,7 +5555,7 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & integer ix,jy,kz - real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu,xvbarmax jy = jgs @@ -4957,11 +5588,23 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) chw = a(ix,jy,kz,ln) - IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN - xv = Min( xvmx, Max( xvmn,xv ) ) + IF ( imaxdiaopt == 1 .or. l /= lr ) THEN + xvbarmax = xvmx + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx /((3. + alpha)**3/((3. + alpha)*(2. + alpha)*(1. + alpha))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx /((4. + alpha)**3/((3. + alpha)*(2. + alpha)*(1. + alpha))) + ELSE + xvbarmax = xvmx + ENDIF + + IF ( xv .lt. xvmn .or. xv .gt. xvbarmax ) THEN + xv = Min( xvbarmax, Max( xvmn,xv ) ) chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + a(ix,jy,kz,ln) = chw ENDIF + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw @@ -5020,6 +5663,7 @@ END subroutine calczgr1d ! Calculation is in a slab (constant jgs) ! + subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, & & lvol, rho_qx, infall, ixcol) @@ -5053,14 +5697,8 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & double precision vr,qr,nrx,rd,g1,zx,chw,z,znew,zt,zxt real xv,xdn integer :: ndbz, nmwgt, nnwgt, nwlessthanz - - ndbz = 0 - nmwgt = 0 - nnwgt = 0 - nwlessthanz = 0 - - + jy = jgs ix = ixcol @@ -5101,42 +5739,19 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & - & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN !{ + & t0(ix,jy,kz) .gt. 0.0 )) THEN !{ ! (( +! & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN zx = t0(ix,jy,kz)/((6./(pi*1000.))**2) - + ! nrx is number diagnosed from sedimented Z nrx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/zx IF ( infall .eq. 3 ) THEN - IF ( nrx .gt. a(ix,jy,kz,ln) ) THEN - ndbz = ndbz + 1 - IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 - ELSE - nnwgt = nnwgt + 1 - ENDIF a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) - ELSE - IF ( nrx .gt. a(ix,jy,kz,ln) .and. t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN - IF ( nrx .lt. t1(ix,jy,kz) ) THEN - ndbz = ndbz + 1 - ELSE - nmwgt = nmwgt + 1 - IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 - ENDIF - ELSE - nnwgt = nnwgt + 1 - ENDIF - + ELSE ! infall = 4 a(ix,jy,kz,ln) = Max(Min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) ) ENDIF ELSE ! } { - IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN - IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN - nmwgt = nmwgt + 1 - ELSE - nnwgt = nnwgt + 1 - ENDIF - ENDIF a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) nrx = a(ix,jy,kz,ln) @@ -5146,13 +5761,7 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & ! } ELSE ! { - IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN - IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN - nmwgt = nmwgt + 1 - ELSE - nnwgt = nnwgt + 1 - ENDIF - ENDIF + ENDIF! } ENDDO @@ -5203,6 +5812,7 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & END subroutine calcnfromz1d + ! ############################################################################## ! ############################################################################## ! @@ -5213,10 +5823,11 @@ END subroutine calcnfromz1d ! ! 10.27.2015: Added hail calculation ! + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & & qcw,qci,qsw,qrw,qhw,qhl, & & ccw,cci,csw,crw,chw,chl, & - & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin ) + & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin, sizecheck_flag ) @@ -5231,13 +5842,12 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, & ccw,cci,csw,crw,chw,chl, & cccn,cccna,vhw,vhl,qv, spechum - logical, optional, intent(in) :: invertccn_flag + logical, optional, intent(in) :: invertccn_flag, sizecheck_flag real, optional :: cwmasin integer ixe,kze real alpha real qmin - real xvmn,xvmx integer ipconc integer lvol ! index for volume integer infall @@ -5257,10 +5867,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet - real xv,xdn,cwmasinv + real xv,xvmax,xdn,cwmasinv,hwdn integer :: ndbz, nmwgt, nnwgt, nwlessthanz double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4 - logical :: invertccn_local + logical :: invertccn_local, sizecheck_flag_local ! ------------------------------------------------------------------ @@ -5269,7 +5879,13 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ELSE invertccn_local = .false. ENDIF - + + IF ( present( sizecheck_flag ) ) THEN + sizecheck_flag_local = sizecheck_flag + ELSE + sizecheck_flag_local = .false. + ENDIF + IF ( present( cwmasin ) ) THEN cwmasinv = 1.0/cwmasin ELSE @@ -5399,9 +6015,24 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) an(ix,jy,kz,lnr) = 0.0 an(ix,jy,kz,lr) = 0.0 + ELSEIF ( sizecheck_flag_local ) THEN + ! check size + xv = dn(ix,kz)*an(ix,jy,kz,lr)/(rho_qr*an(ix,jy,kz,lnr)) + IF ( imaxdiaopt == 3 .and. lzr <= 0 ) THEN + xvmax = xvmx(lr)/((4. + alphar)**3/((3. + alphar)*(2. + alphar)*(1. + alphar))) + ELSE + xvmax = xvmx(lr) + ENDIF + IF ( xvmn(lr) > xv ) THEN + an(ix,jy,kz,lnr) = dn(ix,kz)*an(ix,jy,kz,lr)/(rho_qr*xvmn(lr)) + ELSEIF ( xv > xvmax ) THEN + an(ix,jy,kz,lnr) = dn(ix,kz)*an(ix,jy,kz,lr)/(rho_qr*xvmax) + ENDIF + 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 @@ -5411,6 +6042,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & 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 @@ -5438,9 +6070,14 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & IF ( lnh > 1 ) THEN IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin_init(lh) ) THEN + xdn = xdnh IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh + ELSE + ! check density limits + xdn = Max(xdnmn(lh), Min(xdnmx(lh), dn(ix,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) ) ) + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdn ENDIF ENDIF @@ -5469,10 +6106,34 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) an(ix,jy,kz,lh) = 0.0 - + ELSEIF ( sizecheck_flag_local ) THEN + ! check size limits + xdn = xdnh + IF ( lvh > 1 ) THEN + IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh + ELSE + ! check density limits + xdn = Max(xdnmn(lh), Min(xdnmx(lh), dn(ix,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) ) ) + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdn + ENDIF + ENDIF + + ! check volume + xv = dn(ix,kz)*an(ix,jy,kz,lh)/(xdn*an(ix,jy,kz,lnh)) +! IF ( lzh <= 0 ) THEN +! xv = xv/((4. + alphah)**3/((3. + alphah)*(2. + alphah)*(1. + alphah))) +! ENDIF + IF ( xvmn(lh) > xv ) THEN + an(ix,jy,kz,lnh) = dn(ix,kz)*an(ix,jy,kz,lh)/(rho_qr*xvmn(lh)) + ELSEIF ( xv > xvmx(lh) ) THEN + an(ix,jy,kz,lnh) = dn(ix,kz)*an(ix,jy,kz,lh)/(rho_qr*xvmx(lh)) + ENDIF + 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 @@ -5482,6 +6143,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF ENDIF + ! hail IF ( lnhl > 1 .and. lhl > 1 ) THEN @@ -5508,9 +6170,33 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) an(ix,jy,kz,lhl) = 0.0 + ELSEIF ( sizecheck_flag_local ) THEN + ! check size limits + xdn = xdnhl + IF ( lvh > 1 ) THEN + IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN + an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl + ELSE + ! check density limits + xdn = Max(xdnmn(lhl), Min(xdnmx(lhl), dn(ix,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) ) ) + an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdn + ENDIF + ENDIF + + ! check volume + xv = dn(ix,kz)*an(ix,jy,kz,lhl)/(xdn*an(ix,jy,kz,lnhl)) +! IF ( lzhl <= 0 ) THEN +! xv = xv/((4. + alphahl)**3/((3. + alphahl)*(2. + alphahl)*(1. + alphahl))) +! ENDIF + IF ( xvmn(lhl) > xv ) THEN + an(ix,jy,kz,lnhl) = dn(ix,kz)*an(ix,jy,kz,lhl)/(rho_qr*xvmn(lhl)) + ELSEIF ( xv > xvmx(lhl) ) THEN + an(ix,jy,kz,lnhl) = dn(ix,kz)*an(ix,jy,kz,lhl)/(rho_qr*xvmx(lhl)) + ENDIF 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 @@ -5519,6 +6205,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv ENDIF ENDIF + ! ENDIF @@ -5584,6 +6271,7 @@ END subroutine calcnfromq ! ! 10.27.2015: Added hail calculation ! + subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) @@ -5599,7 +6287,6 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) integer ixe,kze real alpha real qmin - real xvmn,xvmx integer ipconc integer lvol ! index for volume integer infall @@ -5687,9 +6374,11 @@ 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 @@ -5740,9 +6429,11 @@ 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 ! @@ -5766,9 +6457,11 @@ 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 @@ -5782,6 +6475,7 @@ END subroutine calcnfromcuten ! ##################################################################### ! ##################################################################### + SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & @@ -5854,6 +6548,9 @@ SUBROUTINE calc_eff_radius & double precision :: numh, numhl,denomh,denomhl logical :: flag_t4, flag_t5, flag_t6 + + real, parameter :: qmin = 1.e-8 + real, parameter :: volmin = 1.e-30 ! ------------------------------------------------------------------------------- @@ -5968,7 +6665,7 @@ SUBROUTINE calc_eff_radius & ENDIF IF ( present( t4 ) .and.( ( present(qrw) .and. present(crw) ) .or. flag_t4 ) ) THEN - IF ( qx(mgs,lr) > Max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN + IF ( qx(mgs,lr) > Max(qmin,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN IF ( imurain == 1 ) THEN ! gamma-diameter ! Lambda for rain lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) @@ -5987,11 +6684,11 @@ SUBROUTINE calc_eff_radius & IF ( lhl < 1 .or. flag_t6 ) THEN ! graupel only - IF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) ) THEN + IF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) ) THEN ! Lambda for graupel hwdn = xdn0(lh) IF ( lvh > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF @@ -6002,11 +6699,11 @@ SUBROUTINE calc_eff_radius & ELSE ! have hail, too, but do not have t6 array - IF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) < Max(1.e-8,qxmin(lhl)) ) THEN + IF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) < Max(qmin,qxmin(lhl)) ) THEN ! Lambda for graupel hwdn = xdn0(lh) IF ( lvh > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF @@ -6014,11 +6711,11 @@ SUBROUTINE calc_eff_radius & lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) t5(ix,jy,kz) = 0.5*(alphah+3.)/lam_h - ELSEIF ( qx(mgs,lh) < Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN + ELSEIF ( qx(mgs,lh) < Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! Lambda for hail hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF @@ -6026,19 +6723,19 @@ SUBROUTINE calc_eff_radius & lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) t5(ix,jy,kz) = 0.5*(alphahl+3.)/lam_hl - ELSEIF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN + ELSEIF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! r_eff graupel and hail combined hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF hwdn = xdn0(lh) IF ( lvh > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF @@ -6063,11 +6760,11 @@ SUBROUTINE calc_eff_radius & IF ( present(t6) .and. flag_t6 .and. lhl > 1 ) THEN - IF ( qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN + IF ( qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! Lambda for hail hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF @@ -6087,14 +6784,17 @@ SUBROUTINE calc_eff_radius & END SUBROUTINE calc_eff_radius + ! ##################################################################### ! ##################################################################### + SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) !##################################################################### ! Purpose: find the amount of vapor that can be condensed to liquid +! No ice here !##################################################################### implicit none @@ -6170,6 +6870,7 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) @@ -6235,6 +6936,7 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qcw(mgs) = max( 0.0, qcw(mgs) ) qwv(mgs) = max( 0.0, qvap(mgs)) @@ -6259,6 +6961,7 @@ END SUBROUTINE QVEXCESS ! ! ############################################################################## ! + SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & & ipconc1,ndebug1,ngs,nz,igs,kgs,fadvisc, & @@ -7107,6 +7810,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & if ( qx(mgs,ls) .gt. qxmin(ls) ) then IF ( ipconc .ge. 4 ) THEN if ( mixedphase .and. qsvtmod ) then + else IF ( isnowfall == 1 ) THEN ! original (Zrnic et al. 1993) @@ -7280,6 +7984,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs) ENDIF + end if end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' @@ -7374,6 +8079,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ENDIF + end if end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' @@ -7526,8 +8232,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & (aax*(xdia(mgs,il,1) )**bbx * & & x)/y ! & Gamma(7.0 + alpha(mgs,il) + bbx)/Gamma(7. + alpha(mgs,il)) - IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & - .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN + IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 250. ) .or. & + .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 250. ) ) THEN write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3) ! call commasmpi_abort() @@ -7557,6 +8263,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! & Gamma_sp(1.0 + dnu(il) + 0.6)/Gamma_sp(1. + dnu(il)) ENDIF ! } + ! IF ( infdo .ge. 2 ) THEN ! Z-weighted ! vtxbar(mgs,il,3) = rhovt(mgs)* & ! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & @@ -7643,6 +8350,7 @@ END SUBROUTINE setvtz ! subroutine to calculate fall speeds of hydrometeors ! + subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & & xvt, rhovtzx, & & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & @@ -7667,6 +8375,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! implicit none + integer ng1 parameter(ng1 = 1) @@ -7763,7 +8472,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & logical ldoliq - real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp + real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp, tmpc, tmpz real vtmax real xvbarmax @@ -7796,6 +8505,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! constants ! + ldoliq = .false. IF ( ls .gt. 1 ) THEN DO il = ls,lhab @@ -7855,13 +8565,12 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ngscnt = 0 - do kz = nzmpb,nz + do kz = 1,nz do ix = ixcol,ixcol flag = .false. - DO il = l1,l2 - flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) ) + flag = flag .or. ( an(ix,jy,kz,il) > 0.0 ) ENDDO if ( flag ) then @@ -7870,7 +8579,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ngscnt = ngscnt + 1 igs(ngscnt) = ix kgs(ngscnt) = kz - if ( ngscnt .eq. ngs ) goto 1100 + if ( ngscnt .eq. nz ) goto 1100 end if end do !!ix nxmpb = 1 @@ -7886,6 +8595,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! + ! ! Reconstruct various quantities ! @@ -7896,11 +8606,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) temcg(mgs) = temg(mgs) - tfr - + ! end do ! -! only need fadvisc for +! only need fadvisc for droplets IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then do mgs = 1,ngscnt fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & @@ -7949,58 +8659,52 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) end do end if + if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then do mgs = 1,ngscnt cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) -! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) end do end if + if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then do mgs = 1,ngscnt cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) -! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN -! ELSE -! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) ) -! ENDIF end do end if + if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then do mgs = 1,ngscnt cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) -! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN -! ELSE -! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) ) -! ENDIF end do end if if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then do mgs = 1,ngscnt - cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) -! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN -! ELSE -! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) ) -! ENDIF - end do ENDIF if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then do mgs = 1,ngscnt - cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) -! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN -! cx(mgs,lhl) = 0.0 -! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN -! qx(mgs,lhl) = 0.0 -! ELSE -! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) ) -! ENDIF - end do end if - + + ! Vaporize tiny values + DO il = l1,l2 + IF ( lz(il) < 1 .and. ln(il) > 1 ) THEN + do mgs = 1,ngscnt + IF ( cx(mgs,il) <= cxmin .or. qx(mgs,il) < qxmin(il) ) THEN + 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) + ENDIF + end do + ENDIF + ENDDO + do mgs = 1,ngscnt xdn(mgs,lc) = xdn0(lc) xdn(mgs,lr) = xdn0(lr) @@ -8078,6 +8782,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ENDIF + ! ! Set 6th moments ! @@ -8100,10 +8805,13 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ENDDO ENDIF + + + ! Find shape parameter rain @@ -8358,7 +9066,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! ENDIF ENDIF - IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN + IF ( zx(mgs,il) > zxmin .and. cx(mgs,il) <= cxmin ) 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))) @@ -8367,6 +9075,18 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & 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) + IF ( cx(mgs,il) < cxmin ) THEN + ! if resulting concentration is too small, then zero out + 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) + + 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 + 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))/ & @@ -8428,7 +9148,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! check for artificial breakup (graupel/hail larger than allowed max size) - IF ( imaxdiaopt == 1 ) THEN + IF ( imaxdiaopt == 1 .or. il /= lr ) 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)))) @@ -8444,7 +9164,16 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & 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)) ) + ! check if incoming zx is consistent + ! Z from incoming cx, qx, and alpha + tmpz = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/tmp + IF ( tmpz > zx(mgs,il) ) THEN + ! find cx that gives zx + tmpc = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/zx(mgs,il) + cx(mgs,il) = Max(cx(mgs,il), tmpc) + ENDIF + zx(mgs,il) = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/cx(mgs,il) +! 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) @@ -8510,11 +9239,14 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & + + ! ! 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, & @@ -8525,6 +9257,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & + ! ! put fall speeds into the x-z arrays ! @@ -8538,6 +9271,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & & ( 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 @@ -8551,6 +9285,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! 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) ) @@ -8561,6 +9296,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & 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) @@ -8573,6 +9309,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! 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) ) @@ -8595,6 +9332,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ENDDO + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' @@ -8625,6 +9363,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE" + RETURN END subroutine ziegfall1d @@ -8632,12 +9371,260 @@ END subroutine ziegfall1d ! ##################################################################### + +!----------------------------------------------------------------------- +! +! ################################################################## +! ###### ###### +! ###### REAL FUNCTION NSSL_QTODBZ ###### +! ###### ###### +! ################################################################## +! +! Computes effective radar-reflectivity factor corresponding to the model +! hydrometeor variables. +! +! +! Units are MKS, and for most accurate results, make sure that the +! number concentrations and densities of rain, snow and hail are the +! same as the model used in producing the fields. +! +! To be fully consistent with the microphysics, hail/graupel particle +! conditions (wet or dry) would need to be passed to this routine. This +! is because hail/graupel can be wet at temperatures colder than freezing. +! Instead, here we assume that all particles are dry at T<0. (M. Gilmore) +! +!-------------------------------------------------------------------------- +! +! Code obtained from Lou Wicker, 30 August 2004 +! Modified by David Dowell, 7 September 2004, after input from Matt Gilmore +! +! +! 2005.07.18: (erm) Added option for Ferrier (1994) version of dBZ +! calculation, which uses equivalent melted diameter. +! Here it is assumed that all ice particles are dry, which +! may not be realistic in that regard. +! +! Also added dBZ calculation for 10-ice and 2-moment +! +!-------------------------------------------------------------------------- +! +!----------------------------------------------------------------------- + REAL FUNCTION nssl_qtodbz( & + qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + vhw, vhl, zrw, zhw, zhl, pb, tb ) + + implicit none + +!---- Passed Variables + + integer nc + real :: qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + vhw, vhl, zrw, zhw, zhl + real pb, tb + real cno(3:50) + ! real cnoh, cnos, cnor, rho_qh, rho_qs, rho_qr + real :: mindbz = 0 + integer :: ipconc +!--- Local Variables + +! integer lv,lc,lr,li,lir,ls +! integer lgl,lgm,lgh,lf,lh +! integer lip,lhl,lhab + + + + logical ice10 + +! integer iuseferrier ! set = 1 to use alternate dBZ based on Ferrier 1994 + ! NOTE that snow is treated as always dry. Might want to + ! change that.... +! integer idbzci ! set = 1 to include dBZ contribution of cloud ice + ! in 3ice (Heymsfield JAS, 1977). Used for 10-ice by default +! parameter ( iuseferrier = 1, idbzci = 0 ) + + integer nx,ny,nz,nor, k, kediagloc + parameter ( nx = 1, ny = 1, nz = 1, nor = 0) + real z1d(1,4), gz(1), den, temp + real :: an(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) + real :: dn(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) + real :: temk(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) + real :: dbz(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) + +!----------------------------------------------------------------------- + + + den = 1.0e5*pb**2.509/(287.04*tb) + temp = tb*pb + + +! IF ( microp(1:5) .eq. 'ICE10' .or. microp(1:1) .eq. 'Z' .or. microp .eq. 'WARMZIEG' ) THEN +! CALL setmicro(cnoh,rho_qh,cnor,rho_qr,cnos,rho_qs) + + z1d(:,:) = 1.0 + gz(1) = 1.0 + an(:,:,:,:) = 0.0 + dn(:,:,:) = den + temk = temp + +! DO k = 1,2*lqmx + an(1,1,1,lc) = qc + an(1,1,1,lr) = qr + an(1,1,1,li) = qi + an(1,1,1,ls) = qs + an(1,1,1,lh) = qh + IF ( lhl > 1 ) an(1,1,1,lhl) = qhl + an(1,1,1,lnc) = den*ccw + an(1,1,1,lnr) = den*crw + an(1,1,1,lni) = den*cci + an(1,1,1,lns) = den*csw + an(1,1,1,lnh) = den*chw + IF ( lnhl > 1 ) an(1,1,1,lnhl) = den*chl + IF ( lvh > 1 ) an(1,1,1,lvh) = den*vhw + IF ( lvhl > 1 ) an(1,1,1,lvhl) = den*vhl + IF ( lzr > 1 ) an(1,1,1,lzr) = den*zrw + IF ( lzh > 1 ) an(1,1,1,lzh) = den*zhw + IF ( lzhl > 1 ) an(1,1,1,lzhl) = den*zhl +! ENDDO + + call calcnfromq(nx,ny,nz,an,na,nor,nor,dn) + +! write(*,*) 'qtodbz: den,temp = ',den,temp + +! assume ipconc = 0 for now.... +! assume print unit=6 + kediagloc = 1 + call radardd02(nx,ny,nz,nor,na,an,temk, & + & dbz,dn,1,cnoh,rho_qh,ipconc,kediagloc,0, zdbz_start=1,zdbz_end=1) +! call radardd02(nx,ny,nz,nor,na,an,temk, +! dbz,dn, 1, cnoh,rho_qh,ipconc, 6, microp, 0, 0, vzf) + +! IF ( dbz .gt. 1.0 ) write(*,*) 'qtodbz: dbz = ', dbz + nssl_qtodbz = Max( dbz(1,1,1), mindbz ) + + RETURN + + + + RETURN + END FUNCTION nssl_qtodbz + +! ###################################################################### +! +! nssl_column_dbz: column-level reflectivity (dBZ) +! Processes an entire column at once for efficiency, avoiding +! per-level overhead of nssl_qtodbz. +! +! ###################################################################### + + subroutine nssl_column_dbz(nz_in, & + qc, qr, qi, qs, qh, qhl, & + ccw, crw, cci, csw, chw, chl, & + vhw, vhl, zrw, zhw, zhl, & + pb, tb, rho_air, dbzout, no_dbz ) + +! ############################################################################## + implicit none + +!---- Passed Variables + + integer, intent(in) :: nz_in + real, dimension(nz_in), intent(inout) :: qc, qr, qi, qs, qh, qhl + real, dimension(nz_in), intent(inout) :: ccw, crw, cci, csw, chw, chl + real, dimension(nz_in), intent(inout) :: vhw, vhl, zrw, zhw, zhl + real, dimension(nz_in), intent(in) :: pb, tb, rho_air + real, dimension(nz_in), intent(out), optional :: dbzout + logical, optional :: no_dbz ! if true, then skip reflectivity + +!--- Local Variables + + integer, parameter :: nx = 1, ny = 1, nor = 0 + integer :: k, kediagloc + real :: cnoh, rho_qh + real :: an(1,1,nz_in,na) + real :: dn(1,1,nz_in+1) + real :: temk(1,1,nz_in) + real :: dbz(1,1,nz_in) + real :: xv, xmas, cx + logical :: no_dbz_local + +!----------------------------------------------------------------------- + + no_dbz_local = .false. + IF ( present( no_dbz ) ) THEN + no_dbz_local = no_dbz + ENDIF + an(:,:,:,:) = 0.0 + do k = 1, nz_in + dn(1,1,k) = rho_air(k) ! 1.0e5*pb(k)**2.509/(287.04*tb(k)) + temk(1,1,k) = tb(k)*pb(k) + + an(1,1,k,lc) = qc(k) + an(1,1,k,lr) = qr(k) + an(1,1,k,li) = qi(k) + an(1,1,k,ls) = qs(k) + an(1,1,k,lh) = qh(k) + IF ( lhl > 1 ) an(1,1,k,lhl) = qhl(k) + an(1,1,k,lnc) = rho_air(k)*ccw(k) + an(1,1,k,lnr) = rho_air(k)*crw(k) + an(1,1,k,lni) = rho_air(k)*cci(k) + an(1,1,k,lns) = rho_air(k)*csw(k) + an(1,1,k,lnh) = rho_air(k)*chw(k) + IF ( lnhl > 1 ) an(1,1,k,lnhl) = rho_air(k)*chl(k) + IF ( lvh > 1 ) an(1,1,k,lvh) = rho_air(k)*vhw(k) + IF ( lvhl > 1 ) an(1,1,k,lvhl) = rho_air(k)*vhl(k) + IF ( lzr > 1 ) an(1,1,k,lzr) = rho_air(k)*zrw(k) + IF ( lzh > 1 ) an(1,1,k,lzh) = rho_air(k)*zhw(k) + IF ( lzhl > 1 ) an(1,1,k,lzhl) = rho_air(k)*zhl(k) + enddo + dn(1,1,nz_in+1) = dn(1,1,nz_in) + + call calcnfromq(nx,ny,nz_in,an,na,nor,nor,dn,sizecheck_flag=.true.) + + IF ( present( dbzout ) .and. .not. no_dbz_local ) THEN + kediagloc = nz_in + call radardd02(nx,ny,nz_in,nor,na,an,temk, & + & dbz,dn,1,cnoh,rho_qh,ipconc,kediagloc,0, & + & zdbz_start=1,zdbz_end=nz_in) + + do k = 1, nz_in + dbzout(k) = dbz(1,1,k) + enddo + ENDIF + + do k = 1, nz_in +! dn(1,1,k) = rho_air(k) ! 1.0e5*pb(k)**2.509/(287.04*tb(k)) +! temk(1,1,k) = tb(k)*pb(k) +! + qc(k) = an(1,1,k,lc) + qr(k) = an(1,1,k,lr) + qi(k) = an(1,1,k,li) + qs(k) = an(1,1,k,ls) + qh(k) = an(1,1,k,lh) + IF ( lhl > 1 ) qhl(k) = an(1,1,k,lhl) + crw(k) = an(1,1,k,lnr)/rho_air(k) + ccw(k) = an(1,1,k,lnc)/rho_air(k) + cci(k) = an(1,1,k,lni)/rho_air(k) + csw(k) = an(1,1,k,lns)/rho_air(k) + chw(k) = an(1,1,k,lnh)/rho_air(k) + IF ( lnhl > 1 ) chl(k) = an(1,1,k,lnhl)/rho_air(k) + IF ( lvh > 1 ) vhw(k) = an(1,1,k,lvh)/rho_air(k) + IF ( lvhl > 1 ) vhl(k) = an(1,1,k,lvhl)/rho_air(k) + IF ( lzr > 1 ) zrw(k) = an(1,1,k,lzr)/rho_air(k) + IF ( lzh > 1 ) zhw(k) = an(1,1,k,lzh)/rho_air(k) + IF ( lzhl > 1 ) zhl(k) = an(1,1,k,lzhl)/rho_air(k) + enddo + + END subroutine nssl_column_dbz + + ! ##################################################################### ! ##################################################################### ! ############################################################################## + subroutine radardd02(nx,ny,nz,nor,na,an,temk, & - & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit) + & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit, & + & vzflag0, vzf, zdbz_start, zdbz_end) ! ! 11.13.2005: Changed values of indices for reordering of lip ! @@ -8686,6 +9673,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & character(LEN=15), parameter :: microp = 'ZVD' integer nx,ny,nz,nor,na,ngt integer nzdbz ! how many levels actually to process + integer, intent(in), optional :: zdbz_start,zdbz_end ! start and end levels actually to process integer ng1,n10 integer iunit @@ -8702,12 +9690,18 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & integer imapz,mzdist integer vzflag +! #ifdef USEVZF + integer, optional, intent(in) :: vzflag0 +! #endif integer, parameter :: norz = 3 real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air density ! real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt) real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air temperature (kelvin) real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! reflectivity +! #ifdef USEVZF + real, optional, intent(out) :: vzf(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! power-weighted fall velocity +! #endif real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4) ! real g,rgas,eta,inveta @@ -8731,8 +9725,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & double precision :: xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc double precision :: dadr real dbzmax,dbzmin + parameter ( dbzmin = 0 ) + real cnow,cnoi,cnoip,cnoir,cnor,cnos real cnogl,cnogm,cnogh,cnof,cnoh,cnohl @@ -8769,6 +9765,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & real :: dnsnow real qh + real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 real, parameter :: cwradn = 5.0e-6 ! minimum radius @@ -8779,11 +9776,24 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & real :: ksq real :: dtp + integer :: loop_start, loop_end ! ######################################################################### + if (.not. present(zdbz_start)) then + loop_start = 1 + else + loop_start = zdbz_start + endif + if (.not. present(zdbz_end)) then + loop_end = ke_diag + else + loop_end = zdbz_end + endif + vzflag = 0 + izieg = 0 ice10 = 0 ! g=9.806 ! g: gravity constant @@ -9057,7 +10067,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & DO jy=1,1 - DO kz = 1,ke_diag ! nz + + DO kz = loop_start, loop_end !1,ke_diag ! nz DO ix=1,nx dbz(ix,jy,kz) = 0.0 @@ -9082,8 +10093,10 @@ 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)) @@ -9096,6 +10109,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF ENDIF dtmpr = dtmp(ix,kz) + ENDIF !----------------------------------------------------------------------- @@ -9309,6 +10323,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF !} ENDIF !} + ENDIF !} ENDIF @@ -9352,10 +10367,12 @@ 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 @@ -9401,9 +10418,11 @@ 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 @@ -9448,6 +10467,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF + ENDIF ! } ENDIF ! na .gt. 5 @@ -9476,11 +10496,13 @@ 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) IF ( chl .gt. 0.0 ) THEN !{ @@ -9503,9 +10525,11 @@ 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)) @@ -9553,12 +10577,14 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF ! ipconc .ge. 5 + ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 IF ( dtmp(ix,kz) .gt. 0.0 ) THEN dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) ) + IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN dbzmax = Max(dbzmax,dbz(ix,jy,kz)) @@ -9615,7 +10641,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN write(0,*) 'dbz out of bounds!' + ! STOP + ENDIF ENDIF @@ -9643,15 +10671,19 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF + RETURN END subroutine radardd02 + ! ############################################################################## ! ############################################################################## + + ! ##################################################################### ! ##################################################################### ! @@ -9662,16 +10694,21 @@ END subroutine radardd02 SUBROUTINE NUCOND & & (nx,ny,nz,na,jyslab & & ,nor,norz,dtp,nxi & + & ,dz3d & + & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & + & ,ngs & + & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) + implicit none ! real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3 @@ -9715,12 +10752,16 @@ SUBROUTINE NUCOND & real pb(-norz+ng1:nz+norz) real pinit(-norz+ng1:nz+norz) + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + ! local + + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) logical :: io_flag @@ -9734,6 +10775,7 @@ 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 + integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs) integer nsvcnt @@ -9762,8 +10804,6 @@ SUBROUTINE NUCOND & ! =0 to use ad to calculate SS ! =1 to use an at end of main jy loop to calculate SS parameter (iba = 1) - integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat - parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold real :: ssmax(ngs) ! maximum SS experienced by a parcel real ssmx @@ -9775,7 +10815,7 @@ SUBROUTINE NUCOND & real volb, t2s real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler - real ec0, ex1, ft, rhoinv(ngs) + real rhoinv(ngs) real chw, g1, rd1 @@ -9797,8 +10837,9 @@ SUBROUTINE NUCOND & real dqvr, dqc, dqr, dqi, dqs real qv1m,qvs1m,ss1m,ssi1m,qis1m real cwmastmp - real dcloud,dcloud2 ! ,as, bs - real dcrit + real dcloud,dcloud2,dcloudmx ! ,as, bs + real dcrit,dcloudcheck,cnucmax + real cn(ngs), cnuf(ngs) real :: ccwmax @@ -9880,7 +10921,7 @@ SUBROUTINE NUCOND & integer, parameter :: iunit = 0 - real :: frac, hwdn, tmpg + real :: frac, hwdn, tmpg, xdia1, xdia3, cwch,xvol real :: cvm,cpm,rmm @@ -9892,6 +10933,24 @@ SUBROUTINE NUCOND & integer :: count +! Addtion T.Iguchi Y2021 Update + real, parameter :: mwwater = 0.01801528 ! Molecular weight of water (kg/mol) + real, parameter :: rhowater = 997.0 ! Density of liquid water (kg/m3) + real, parameter :: gasconst = 8.3144598 ! Gas constant (m2 kg s-2 K-1 mol-1) + real :: sswater ! unit change supersaturation from percentage to n/a + real :: sigvl, aact + + real :: alpha_ar, gamma_ar, G_ar, evs, zeta, smax + real :: f_ac, g_ac, eta_ac + real :: f_nu, g_nu, eta_nu + real :: f_co, g_co, eta_co + + real :: sm_nu, sm_ac, sm_co, ss_ac, ss_nu, ss_co + real :: uu_nu, uu_ac, uu_co + + real :: cn_ac, cn_co, cn_nu + + ! ------------------------------------------------------------------------------- itile = nxi jtile = ny @@ -9902,16 +10961,20 @@ SUBROUTINE NUCOND & nxend = nxi + 1 nyend = ny + 1 nzend = nz + 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 kstag = 0 pb(:) = 0.0 pinit(:) = 0.0 + IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 @@ -9936,11 +10999,13 @@ SUBROUTINE NUCOND & c1 = t00(ix,jy,kz)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pn(ix,jy,kz) + pb(kz) - esbolton*tabqvs(ltemq)) - ! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ENDIF IF ( c1 > 0. ) THEN ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values + ELSE + ssfilt(ix,jy,kz) = -100. ENDIF ENDDO @@ -9992,6 +11057,7 @@ SUBROUTINE NUCOND & qvs(1) = pqs(1)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(1) = rdorv*esbolton*tabqvs(ltemq)/(pres(1) - esbolton*tabqvs(ltemq)) + ENDIF qis(1) = pqs(1)*tabqis(ltemq) @@ -10028,8 +11094,10 @@ SUBROUTINE NUCOND & qx(:,:) = 0.0 cx(:,:) = 0.0 + zx(:,:) = 0.0 + xv(:,:) = 0.0 xmas(:,:) = 0.0 @@ -10076,15 +11144,16 @@ SUBROUTINE NUCOND & qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) ! qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) IF ( iqvsopt == 0 ) THEN es(mgs) = 6.1078e2*tabqvs(ltemq) - ! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN es(mgs) = esbolton*tabqvs(ltemq) + ENDIF ! es(mgs) = 6.1078e2*tabqvs(ltemq) qss(mgs) = qvs(mgs) @@ -10159,7 +11228,37 @@ SUBROUTINE NUCOND & 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) + IF ( lccna > 1 ) THEN + cnuc(mgs) = ccnc(mgs) + ENDIF + ENDIF + IF ( lcn_nu > 1 ) THEN + ccnc_nu(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_nu) + ENDIF + IF ( lcn_co > 1 ) THEN + ccnc_co(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_co) + ENDIF + IF ( lccnaco > 1 ) THEN + ccnaco(mgs) = an(igs(mgs),jy,kgs(mgs),lccnaco) + ELSE + ccnaco(mgs) = 0.0 ENDIF + IF ( lccnanu > 1 ) THEN + ccnanu(mgs) = an(igs(mgs),jy,kgs(mgs),lccnanu) + ELSE + ccnanu(mgs) = 0.0 + ENDIF + ELSEIF ( lccn > 1 .and. ( ac_opt == 1 .or. ac_opt == 11 ) ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ! ccnc(mgs) = ccnc_ac(mgs) + cnuc(mgs) = ccnc(mgs) + cwnccn(mgs) = cnuc(mgs) + ! write(0,*) 'ccnc_ac,mgs = ', ccnc_ac(mgs),mgs,igs(mgs),jy,kgs(mgs) + ELSEIF ( lccn > 1 .and. ( ac_opt == 2 .or. ac_opt == 22 ) ) THEN + ccnc_nu(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_nu) + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ! ccnc(mgs) = ccnc_ac(mgs) + ccnc_co(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_co) ELSE ccnc(mgs) = cwnccn(mgs) ENDIF @@ -10185,7 +11284,9 @@ SUBROUTINE NUCOND & ENDIF ELSE IF ( lccn > 1 ) THEN - ccna(mgs) = cwnccn(mgs) - ccnc(mgs) ! diagnose activated ccn as background value - remaining unactivated ccn + + ccna(mgs) = 0.0 ! WRF driver interface already has ccw subtracted from ccnc + ELSE ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn ENDIF @@ -10202,9 +11303,13 @@ SUBROUTINE NUCOND & DO mgs = 1,ngscnt ! default value of renucfrac is 0.0 IF ( irenuc /= 6 ) THEN - cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + IF ( irenuc == 2 ) THEN + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + ELSE + cnuc(mgs) = ccnc(mgs)*(1. - renucfrac) + ccnc(mgs)*renucfrac + ENDIF ELSE - cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac + cnuc(mgs) = ccnc(mgs)*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac ENDIF IF ( renucfrac >= 0.999 ) THEN IF ( temg(mgs) < 265. ) THEN @@ -10230,6 +11335,7 @@ SUBROUTINE NUCOND & ventrxn(:) = ventrn + ! Find shape parameter rain IF ( lzr > 1 .and. rcond == 2 ) THEN ! { RAIN SHAPE PARAM @@ -10241,21 +11347,42 @@ SUBROUTINE NUCOND & il = lr DO mgs = 1,ngscnt - IF ( zx(mgs,il) <= zxmin ) THEN - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + 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 ( cx(mgs,il) <= 0.0 ) THEN - qx(mgs,lv) = qx(mgs,lv) + qx(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,lr) .gt. qxmin(lr) ) THEN @@ -10462,6 +11589,7 @@ SUBROUTINE NUCOND & ENDIF ! } + ! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit ssmx = 0.0 DO mgs = 1,ngscnt @@ -10615,16 +11743,32 @@ SUBROUTINE NUCOND & QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) - IF ( qx(mgs,lc) <= 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) - 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 ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + IF ( restoreccn ) THEN !{ + IF ( lccna > 1 .and. .not. (ac_opt == 1 .or. ac_opt == 2) ) THEN + tmp = restoreccnfrac*cx(mgs,lc) + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) + IF ( tmp2 > 0.0 ) THEN + ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 + ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 + ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 + ENDIF + ELSE + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ELSEIF ( ac_opt == 1 ) THEN + ! do not need to add back because ccnc = ccn_unactivated + ccw, so reducing ccw "restores" ccn_unactived + ! ccnc(mgs) = ccnc(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) ) ) @@ -10632,16 +11776,29 @@ SUBROUTINE NUCOND & ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ENDIF ENDIF - ENDIF + ENDIF !} cx(mgs,lc) = 0. - ELSE + ELSE !} { qctmp = qx(mgs,lc) qwvp(mgs) = qwvp(mgs) + QEVAP qx(mgs,lc) = qx(mgs,lc) - QEVAP IF ( qx(mgs,lc) .le. 0. ) THEN IF ( restoreccn ) THEN - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + IF ( lccna > 1 .and. .not. (ac_opt == 1 .or. ac_opt == 2)) THEN + tmp = restoreccnfrac*cx(mgs,lc) + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) + IF ( tmp2 > 0.0 ) THEN + ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 + ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 + ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 + ENDIF + ELSE + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ELSEIF ( ac_opt == 1 ) THEN + ! ccnc(mgs) = ccnc(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) @@ -10656,8 +11813,22 @@ SUBROUTINE NUCOND & 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 ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp + IF ( lccna > 1 .and. .not. (ac_opt == 1 .or. ac_opt == 2) ) THEN + tmp = restoreccnfrac*tmp + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) + IF ( tmp2 > 0.0 ) THEN + ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 + ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 + ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 + ENDIF + ELSE + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ! ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp + ELSEIF ( ac_opt == 1 ) THEN + ! ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) ! ccnc(mgs) = ccnc(mgs) + tmp @@ -10671,11 +11842,13 @@ SUBROUTINE NUCOND & cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF 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 - ENDIF + + ENDIF !} GO TO 631 @@ -10799,7 +11972,11 @@ SUBROUTINE NUCOND & ltemq = Min( nqsat, Max(1,ltemq) ) ltemq1 = ltemq temp1 = temg(mgs) - p380 = 380.0/pres(mgs) + IF ( iqvsopt == 0 ) THEN + p380 = 380.0/pres(mgs) + ELSE + p380 = esbolton*rdorv/(pres(mgs) - es(mgs)) + ENDIF ! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) ) ! nc = NInt(dtp/Min(1.0,0.5*taus)) @@ -10842,6 +12019,14 @@ SUBROUTINE NUCOND & dqs = 0.0 dqvii = 0.0 dqvis = 0.0 + + IF ( icondlimit == 1 .or. dtp > dtcond ) THEN + ssmx = 0.001 + + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloudmx, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + ENDIF + RK2c: DO WHILE ( dt1 .lt. dtp ) nc = 0 @@ -10934,17 +12119,31 @@ SUBROUTINE NUCOND & ENDDO RK2c + IF ( icondlimit == 1 .or. dtp > dtcond ) THEN + IF ( dqc + dqr > 0.0 .and. dcloudmx > 0.0 .and. dqc + dqr > dcloudmx ) THEN + ! backstop for max condensation + ! write(0,*) 'dcl,dclmx = ',dqc+dqr,dcloudmx,ssmx,dqc,dqr + dcloudcheck = dqc+dqr + dqc = dqc*dcloudmx/dcloudcheck + dqr = dqr*dcloudmx/dcloudcheck + ! write(0,*) 'new dcl,dqc,dqr = ',dqc+dqr,dqc,dqr + ENDIF + ENDIF + dcloud = dqc ! qx(mgs,lv) - qv1 thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) + IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) ENDIF + IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp ENDIF + qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) qx(mgs,lc) = qx(mgs,lc) + DCLOUD qx(mgs,lr) = qx(mgs,lr) + dqr @@ -10952,6 +12151,7 @@ SUBROUTINE NUCOND & !! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + 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) @@ -10965,15 +12165,16 @@ SUBROUTINE NUCOND & 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) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ! es(mgs) = 6.1078e2*tabqvs(ltemq) @@ -11012,7 +12213,7 @@ SUBROUTINE NUCOND & ! 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) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test + ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc(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) @@ -11027,9 +12228,11 @@ SUBROUTINE NUCOND & thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD + IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap ! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) @@ -11040,6 +12243,7 @@ SUBROUTINE NUCOND & qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ! es(mgs) = 6.1078e2*tabqvs(ltemq) @@ -11053,11 +12257,11 @@ SUBROUTINE NUCOND & IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem - IF ( ac_opt == 0 ) THEN + ! IF ( ac_opt == 0 ) THEN cnuctmp = cnuc(mgs) - ELSE - cnuctmp = ccnc_ac(mgs) - ENDIF + ! ELSE + ! cnuctmp = ccnc(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 @@ -11090,7 +12294,7 @@ SUBROUTINE NUCOND & ! ccnc(mgs) = 0.0 ENDIF ELSE - cn(mgs) = Min( cn(mgs), ccnc_ac(mgs) ) + cn(mgs) = Min( cn(mgs), ccnc(mgs) ) ENDIF ! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) @@ -11138,8 +12342,10 @@ SUBROUTINE NUCOND & if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug DSSDZ=0. + r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) + 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 !{ @@ -11228,6 +12434,7 @@ SUBROUTINE NUCOND & ENDIF IF ( icnuclimit > 0 ) THEN + tmp = ccnc(mgs) + cx(mgs,lc) IF ( tmp < 330.34e6 ) THEN ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 @@ -11247,6 +12454,7 @@ SUBROUTINE NUCOND & 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) @@ -11311,6 +12519,7 @@ SUBROUTINE NUCOND & 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 @@ -11328,6 +12537,7 @@ SUBROUTINE NUCOND & 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) ) ) @@ -11352,6 +12562,7 @@ SUBROUTINE NUCOND & ! 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 @@ -11373,26 +12584,45 @@ SUBROUTINE NUCOND & 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 !} { + IF ( isscheck > 0 ) THEN + ! test code; not working yet as intended + ss1 = qv1/qvs1 + ssmx = 100.*0.01 + qvex = 0.0 + + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + + ! dcritcheck = 2.*3.17e-6 + dcloudcheck = 1000.*dcritcheck**3*Pi/6. + cnucmax = rho0(mgs)*qvex/dcloudcheck + ENDIF ! modification of Phillips Donner Garner 2007 ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) ! 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 CN(mgs) = Min( cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) + IF ( isscheck > 0 ) THEN + cn(mgs) = Min( cn(mgs), cnucmax ) + ENDIF + IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted 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 ( iqvsopt == 0 ) THEN c1 = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF IF ( c1 > 0. ) THEN ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values @@ -11415,6 +12645,10 @@ 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 + IF ( isscheck > 0 ) THEN + cn(mgs) = Min( cn(mgs), cnucmax ) + + ELSE dcrit = 2.0*2.0e-6 dcloud = 1000.*dcrit**3*Pi/6. ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass @@ -11422,17 +12656,22 @@ SUBROUTINE NUCOND & ! tmp is number of droplets at diameter dcrit tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) cn(mgs) = Min(tmp, cn(mgs) ) + ENDIF IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - dcrit = 2.5e-7 - - dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + IF ( isscheck > 0 ) THEN + dcrit = dcritcheck + ELSE + dcrit = 2.5e-7 + ENDIF + 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 @@ -11452,6 +12691,7 @@ SUBROUTINE NUCOND & 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, (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) @@ -11471,11 +12711,11 @@ SUBROUTINE NUCOND & ltemq = Min( nqsat, Max(1,ltemq) ) ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) - ! c1= pqs(mgs)*tabqvs(ltemq) IF ( iqvsopt == 0 ) THEN c1 = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ssf(mgs) = 0.0 @@ -11501,6 +12741,7 @@ SUBROUTINE NUCOND & ENDIF + ! CN(mgs) = Min( Min(0.1,ssf(mgs)-1.)*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from ! CN(mgs) = Min( Min(0.5*cx(mgs,lc), Min(0.1,ssf(mgs)/100.)*cnuc(mgs)), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from @@ -11517,6 +12758,7 @@ SUBROUTINE NUCOND & IF ( icnuclimit > 0 ) THEN ! max droplet conc. based on Chandrakar et al. (2016) and Konwar et al. (2012) + tmp = ccnc(mgs) - ccna(mgs) + cx(mgs,lc) IF ( tmp < 330.34e6 ) THEN ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 @@ -11549,6 +12791,7 @@ SUBROUTINE NUCOND & 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)) ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) ENDIF @@ -11577,11 +12820,11 @@ SUBROUTINE NUCOND & ltemq = Min( nqsat, Max(1,ltemq) ) ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) - !c1= pqs(mgs)*tabqvs(ltemq) IF ( iqvsopt == 0 ) THEN c1 = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ssf(mgs) = 0.0 @@ -11612,13 +12855,23 @@ SUBROUTINE NUCOND & 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 == 9 .or. irenuc == 10 ) THEN ! } { + write(0,*) 'irenuc=9 requires nuwrfmods=1' + + + + ELSEIF ( irenuc == 11 ) THEN ! } { + + + write(0,*) 'irenuc=11 requires nuwrfmods=1' + ENDIF ! } @@ -11628,6 +12881,7 @@ SUBROUTINE NUCOND & ENDIF ! irenuc >= 0 .and. .not. flag_qndrop + ! IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. GO TO 631 !.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT @@ -11662,9 +12916,11 @@ SUBROUTINE NUCOND & IF ( qvex .gt. 0.0 ) THEN thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp ENDIF + qwvp(mgs) = qwvp(mgs) - qvex qx(mgs,lc) = qx(mgs,lc) + qvex IF ( .not. flag_qndrop) THEN @@ -11786,12 +13042,14 @@ 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 ( ac_opt > 10 .and. (cx(mgs,lc) > 0. .or. ccna(mgs) > 0. ) ) THEN @@ -11803,6 +13061,18 @@ SUBROUTINE NUCOND & IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) ENDIF + ELSEIF ( ac_opt == 1 .and. lccn > 1) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max( 0.0, ccnc(mgs) ) ! cn are depleted for ac_opt=1 or 2 + ELSEIF ( ac_opt == 11 .and. lccna > 1) THEN + ! an(igs(mgs),jy,kgs(mgs),lccna) = Max( 0.0, ccna(mgs) ) ! done below + ELSEIF ( ac_opt == 2 .and. lccn > 1) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max( 0.0, ccnc(mgs) ) + an(igs(mgs),jy,kgs(mgs),lcn_nu) = Max( 0.0, ccnc_nu(mgs) ) + an(igs(mgs),jy,kgs(mgs),lcn_co) = Max( 0.0, ccnc_co(mgs) ) + ELSEIF ( ac_opt == 22 .and. lccna > 1) THEN + ! an(igs(mgs),jy,kgs(mgs),lccna) = Max( 0.0, ccna(mgs) ) ! done below + an(igs(mgs),jy,kgs(mgs),lccnanu) = Max( 0.0, ccnanu(mgs) ) + an(igs(mgs),jy,kgs(mgs),lccnaco) = Max( 0.0, ccnaco(mgs) ) ENDIF 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) ) @@ -11810,7 +13080,7 @@ SUBROUTINE NUCOND & IF ( lccna .gt. 1 ) THEN an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) ) ENDIF - ENDIF + ENDIF ! ipconc >= 2 IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) ENDIF @@ -11843,17 +13113,79 @@ SUBROUTINE NUCOND & ! end of gather scatter (for this jy slice) -!#ifdef COMMAS -! GOTO 9999 -!#endif +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! +! moved to separate subroutine (below) +! + + + + 9999 RETURN + + END SUBROUTINE NUCOND + + +! ##################################################################### +! ##################################################################### +! Clean up tiny values of mixing ratio +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! + subroutine smallvalues & + & (nx,ny,nz,na,jyslab & + & ,nor,norz,dtp,nxi & + & ,t0 & + & ,an,dn, w & + + & ,t77,flag_qndrop & + & ) + + + + implicit none + + integer :: nx,ny,nz,na,nxi + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + logical,intent(in) :: flag_qndrop + +! +! external temporary arrays +! + real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + 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 w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + ! local + + + + logical zerocx(lc:lqmx) + + real :: frac, hwdn, tmpg, xdia1, xdia3, cwch,xvol + + integer ix,kz,i,n, km1 + integer :: il + integer :: jy, jgs + real :: chw, g1, z1, tmp, tmp2, fw, tmpmx, qr + ! Redistribute inappreciable cloud particles and charge ! ! Redistribution everywhere in the domain... ! - IF ( .true. ) THEN - + + jy = 1 + + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 + + cwch = ((3. + alphah)*(2. + alphah)*(1.0 + alphah))**(-1./3.) ! ! alternate test version for ipconc .ge. 3 ! just vaporize stuff to prevent noise in the number concentrations @@ -11873,21 +13205,23 @@ SUBROUTINE NUCOND & ELSE IF ( il == lc ) THEN IF ( ln(il) > 1 ) THEN - zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0.0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) + zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) ENDIF ELSE - IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0.0 ) + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) ENDIF ENDIF ENDDO 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,lhl) .ge. frac*qxmin(lhl) .and. & + rescale_low_alpha .and. rescale_low_alphahl ) THEN ! check 6th moment IF ( an(ix,jy,kz,lnhl) .gt. 0.0 ) THEN @@ -11919,6 +13253,7 @@ SUBROUTINE NUCOND & ENDIF ENDIF !lzhl + if ( (an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl)) .or. zerocx(lhl) ) then @@ -11947,6 +13282,7 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lzhl) = 0.0 ENDIF + ELSE IF ( lvol(lhl) .gt. 1 ) THEN ! check density IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN @@ -11994,6 +13330,28 @@ SUBROUTINE NUCOND & ENDIF + 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 + + IF ( ipconc >= 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) THEN + qr = an(ix,jy,kz,lhl) + xvol = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl)) + chw = an(ix,jy,kz,lnhl) + + IF ( xvol .lt. xvmn(lhl) .or. xvol .gt. xvmx(lhl) ) THEN + xvol = Min( xvmx(lhl), Max( xvmn(lhl),xvol ) ) + chw = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvol*hwdn) + an(ix,jy,kz,lnhl) = chw + ENDIF + ENDIF ! CHECK INTERCEPT IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN @@ -12004,9 +13362,9 @@ SUBROUTINE NUCOND & hwdn = xdn0(lhl) ENDIF tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) - tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.) + tmpg = an(ix,jy,kz,lnhl)*(tmp*pi)**(1./3.) IF ( tmpg .lt. cnohlmn ) THEN - tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*pi)**(1./3.) an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) ENDIF @@ -12019,11 +13377,14 @@ 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 ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. & + rescale_low_alpha .and. rescale_low_alphah ) THEN IF ( an(ix,jy,kz,lnh) .gt. 0.0 ) THEN @@ -12056,6 +13417,7 @@ SUBROUTINE NUCOND & ENDIF + if ( (an(ix,jy,kz,lh) .lt. frac*qxmin(lh)) .or. zerocx(lh) ) then ! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN @@ -12083,6 +13445,7 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lzh) = 0.0 ENDIF + ELSE IF ( lvol(lh) .gt. 1 ) THEN ! check density IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN @@ -12130,9 +13493,6 @@ SUBROUTINE NUCOND & ENDIF -! CHECK INTERCEPT - IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 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) @@ -12143,16 +13503,46 @@ SUBROUTINE NUCOND & ELSE hwdn = xdn0(lh) ENDIF + + IF ( ipconc >= 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) ) THEN + qr = an(ix,jy,kz,lh) + xvol = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh)) + chw = an(ix,jy,kz,lnh) + + IF ( xvol .lt. xvmn(lh) .or. xvol .gt. xvmx(lh) ) THEN + xvol = Min( xvmx(lh), Max( xvmn(lh),xvol ) ) + chw = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(xvol*hwdn) + an(ix,jy,kz,lnh) = chw + ENDIF + ENDIF + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN + tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) - tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.) + tmpg = an(ix,jy,kz,lnh)*(tmp*pi)**(1./3.) IF ( tmpg .lt. cnohmn ) THEN ! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) ! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) - tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*pi)**(1./3.) an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) ENDIF ENDIF + + IF ( ipconc == 5 .and. imorrgdnglimit == 1 ) THEN + ! limit on characteristic diameter (i.e., 1/slope) + xdia3 = (xvol*6.*piinv)**(1./3.) + xdia1 = cwch*xdia3 + IF ( xdia1 > morrdnglimit ) THEN + xdia1 = morrdnglimit + xvol = pi/6.0*(xdia1/cwch)**3 + chw = dn(ix,jy,kz)*qr/(xvol*hwdn) + an(ix,jy,kz,lnh) = chw + xdia3 = (xvol*6.*piinv)**(1./3.) + ENDIF + + ENDIF end if @@ -12199,6 +13589,7 @@ SUBROUTINE NUCOND & ENDIF + ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) @@ -12214,10 +13605,12 @@ 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 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) an(ix,jy,kz,lr) = 0.0 @@ -12226,14 +13619,17 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lnr) = 0.0 ENDIF + IF ( lzr > 1 ) THEN an(ix,jy,kz,lzr) = 0.0 ENDIF + + end if ! -! for qci +! for qi ! IF ( (an(ix,jy,kz,li) .le. frac*qxmin(li)) .or. zerocx(li) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) @@ -12241,36 +13637,24 @@ SUBROUTINE NUCOND & IF ( ipconc .ge. 1 ) THEN an(ix,jy,kz,lni) = 0.0 ENDIF - ENDIF -! -! for qis -! - IF ( lis > 1 ) THEN ! { - IF ( (an(ix,jy,kz,lis) .le. frac*qxmin(lis)) .or. zerocx(lis) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 - & ) THEN ! { { - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis) - an(ix,jy,kz,lis)= 0.0 - IF ( ipconc .ge. 1 ) THEN - an(ix,jy,kz,lnis) = 0.0 - ENDIF - - ELSEIF ( icespheres >= 2 ) THEN ! } { - km1 = Max(1, kz-1) - IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or. & - & (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. & - & (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. & - & ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc) )) ) .or. & - & (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp - an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis) - an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis) - an(ix,jy,kz,lis)= 0.0 - an(ix,jy,kz,lnis)= 0.0 - - ENDIF - - ENDIF ! } } - ENDIF ! } + IF ( restoreccn ) THEN + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) + an(ix,jy,kz,lc) + IF ( tmp < qxmin(li) ) THEN + IF ( lcina > 0 ) THEN + IF ( an(ix,jy,kz,lcina) > 0. .and. tmp < qxmin(li) ) THEN + an(ix,jy,kz,lcina) = an(ix,jy,kz,lcina)*Exp(-dtp/ccntimeconst) + ENDIF + ENDIF + IF ( lcinda > 0 ) THEN + IF ( an(ix,jy,kz,lcinda) > 0. .and. tmp < qxmin(li) ) THEN + an(ix,jy,kz,lcinda) = an(ix,jy,kz,lcinda)*Exp(-dtp/ccntimeconst) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF ! qi + ! ! for qcw @@ -12284,37 +13668,66 @@ SUBROUTINE NUCOND & 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)) + ELSEIF ( lccn > 1 ) 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)) ) + tmp = Max(0.0,an(ix,jy,kz,lnc)) + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = an(ix,jy,kz,lccna) + an(ix,jy,kz,lccnaco) + an(ix,jy,kz,lccnanu) + IF ( tmp2 > 0.0 .and. tmp > 0.0 ) THEN + an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - tmp*an(ix,jy,kz,lccna)/tmp2 ) + an(ix,jy,kz,lccnaco) = Max( 0.0, an(ix,jy,kz,lccnaco) - tmp*an(ix,jy,kz,lccnaco)/tmp2 ) + an(ix,jy,kz,lccnanu) = Max( 0.0, an(ix,jy,kz,lccnanu) - tmp*an(ix,jy,kz,lccnanu)/tmp2 ) + ENDIF + ELSE + an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - tmp ) + ENDIF 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 .and. ac_opt == 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 ( lccna > 0 .and. .not. (ac_opt == 1 .or. ac_opt == 2) ) 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) + IF ( tmp < qxmin(li) ) THEN + IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) + IF ( lccnaco > 1 ) an(ix,jy,kz,lccnaco) = an(ix,jy,kz,lccnaco)*Exp(-dtp/ccntimeconst) + IF ( lccnanu > 1 ) an(ix,jy,kz,lccnanu) = an(ix,jy,kz,lccnanu)*Exp(-dtp/ccntimeconst) + ENDIF ENDIF - ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN + ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt <= 2 ) 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 ! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst) ! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) ! ENDIF - IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN + IF ( tmp < qxmin(li) ) THEN + IF ( an(ix,jy,kz,lccn) > 1. .and. & + ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN ! an(ix,jy,kz,lccn) = & ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst)) ! Equivalent form after expanding last term: - an(ix,jy,kz,lccn) = & - dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) + tmp = an(ix,jy,kz,lccn) + an(ix,jy,kz,lccn) = Max( tmp, & + dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) ) + ! write(0,*) 'restore: ',ix,kz, tmp, an(ix,jy,kz,lccn),an(ix,jy,kz,lccn)-tmp ENDIF + IF ( ac_opt == 2 .and. lcn_co > 1 .and. lcn_nu > 1 ) THEN + an(ix,jy,kz,lcn_co) = & + dn(ix,jy,kz)*qccnco - Max(0.0 , dn(ix,jy,kz)*qccnco - an(ix,jy,kz,lcn_co))*Exp(-dtp/ccntimeconst) + an(ix,jy,kz,lcn_nu) = & + dn(ix,jy,kz)*qccnnu - Max(0.0 , dn(ix,jy,kz)*qccnnu - an(ix,jy,kz,lcn_nu))*Exp(-dtp/ccntimeconst) + ENDIF + ENDIF ! tmp < qxmin ENDIF + ENDIF ENDIF @@ -12323,20 +13736,13 @@ SUBROUTINE NUCOND & ! end do end do - ENDIF ! true/false - IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' -! -! - - - 9999 RETURN - - END SUBROUTINE NUCOND + end subroutine smallvalues + + + -! ##################################################################### -! ##################################################################### @@ -12351,7 +13757,7 @@ subroutine nssl_2mom_gs & & (nx,ny,nz,na,jyslab & & ,nor,norz & & ,dtp,gz & - & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9,t7d & & ,an,dn,p2 & & ,pn,w,iunit & & ,t00,t77, & @@ -12360,13 +13766,17 @@ subroutine nssl_2mom_gs & ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,tmp3d,tkediss & + & ,thproc,numproc,dx1,dy1,ngs & & ,timevtcalc,axtra,io_flag & & , has_wetscav,rainprod2d, evapprod2d, alpha2d & + & ,elec,its,ids,ide,jds,jde & & ) + + ! !-------------------------------------------------------------------------- ! @@ -12436,6 +13846,7 @@ subroutine nssl_2mom_gs & logical, intent(in) :: io_flag + integer itile,jtile,ktile integer ixbeg,jybeg integer ixend,jyend,kzend,kzbeg @@ -12449,12 +13860,17 @@ 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 + real :: alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,4) + + + 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) @@ -12485,12 +13901,15 @@ subroutine nssl_2mom_gs & logical, parameter :: gammacheck = .false. integer :: luindex double precision :: tmpgam + logical, parameter :: usegamxinfcnu = .false. logical, parameter :: usegamxinf = .false. logical, parameter :: usegamxinf2 = .false. logical, parameter :: usegamxinf3 = .false. + ! real rar ! rime accretion rate as calculated from qxacw + ! a few vars for time-split fallout real vtmax integer n,ndfall @@ -12502,7 +13921,9 @@ subroutine nssl_2mom_gs & real pb(-norz+ng1:nz+norz) real pinit(-norz+ng1:nz+norz) + real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! dz + real qimax,xni0,roqi0 @@ -12522,7 +13943,7 @@ subroutine nssl_2mom_gs & integer i,j,k,i1 integer kzb,kze real slope1, slope2 - real x1, x2, x3 + real x1, x2, x3, y1 real eps,eps2 parameter (eps=1.e-20,eps2=1.e-5) ! @@ -12583,6 +14004,7 @@ subroutine nssl_2mom_gs & real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t7d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) ! perturbation Pi real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) @@ -12597,6 +14019,7 @@ subroutine nssl_2mom_gs & ! integer nxmpb,nzmpb,nxz integer jgs,mgs,ngs,numgs + integer, parameter :: ngsz = 500 integer ntt parameter (ntt=300) @@ -12623,7 +14046,8 @@ subroutine nssl_2mom_gs & ! - real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) + real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs),cinda(ngs) + real cwnccn(ngs) real sscb ! 'cloud base' SS threshold parameter ( sscb = 2.0 ) @@ -12633,8 +14057,6 @@ subroutine nssl_2mom_gs & ! =0 to use ad to calculate SS ! =1 to use an at end of main jy loop to calculate SS parameter (iba = 1) - integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat - parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter (same as area-weighted diameter), 4 for mass-weighted diameter @@ -12657,12 +14079,13 @@ subroutine nssl_2mom_gs & real, parameter :: mfrag = 1.0e-10 ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) double precision cautn(ngs), rh(ngs), nh(ngs) real ex1, ft, rhoinv(ngs) - double precision ec0(ngs) + real :: ec0(ngs) - real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super - real :: flim + real ac1,bc, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super + real :: flim, xmass real dw,dwr double precision :: tmpz, tmpzmlt + real :: tmpc real ratio, delx, dely real dbigg,volt real chgtmp,fac,mixedphasefac @@ -12752,6 +14175,7 @@ subroutine nssl_2mom_gs & real gf73rds, gf83rds real gamice73fac, gamsnow73fac real gf43rds, gf53rds + real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn parameter ( rwradmn = 50.e-6 ) real dh0 @@ -12815,6 +14239,7 @@ subroutine nssl_2mom_gs & real :: qxmxd(ngs,lv:lhab) real :: scx(ngs,lc:lhab) real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) real :: xmas(ngs,lc:lhab) real :: xdn(ngs,lc:lhab) @@ -12829,11 +14254,13 @@ 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 :: g1xmax,g1xmin real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis real :: qsimxsub(ngs) ! max depositionof qi+qs+qis logical,parameter :: DoSublimationFix = .true. @@ -12856,9 +14283,10 @@ subroutine nssl_2mom_gs & real :: qhgt10mm ! mass greater than 10mm real :: qhgt20mm ! mass greater than 20mm real :: fwmhtmp - real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles +! real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass (0.268e-3 kg) of an 8mm spherical drop real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield + real :: dtmp ! real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) real hxventtmp @@ -12904,12 +14332,16 @@ subroutine nssl_2mom_gs & real qvimxd(ngs) real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) + real cionpmxd(ngs),cionnmxd(ngs) real clionpmxd(ngs),clionnmxd(ngs) + + real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! Ez (elecsave) + ! ! ! Hallett-Mossop arrays @@ -12925,11 +14357,12 @@ subroutine nssl_2mom_gs & ! real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs) real :: chlcnhhl(ngs) ! number of new hail particles (may be different from number of lost graupel) - real cracif(ngs), ciacrf(ngs) + real ciacrf(ngs) ! cracif(ngs), real cracr(ngs) ! - real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) + real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs), cidint(ngs) + real ciintd(ngs), qiintd(ngs) ! IN activation by droplet freezing real cicint(ngs) real cipint(ngs) real ciacw(ngs), cwacii(ngs) @@ -12956,6 +14389,7 @@ subroutine nssl_2mom_gs & real chlshr(ngs), chlshrr(ngs) + real chdpv(ngs),chsbv(ngs) real chmlr(ngs),chcev(ngs) real chmlrr(ngs) @@ -12975,16 +14409,21 @@ 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), qxacwtmp, qxacrtmp, qxacitmp, qxacstmp ! + real :: cxacstmp,cxacitmp real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + real qfcev(ngs) real qfmul1(ngs),cfmul1(ngs) ! @@ -13009,6 +14448,7 @@ subroutine nssl_2mom_gs & ! real qsaci(ngs) real qsacis(ngs) + real csacis(ngs) real qhaci(ngs) real qhacs(ngs) @@ -13017,6 +14457,7 @@ subroutine nssl_2mom_gs & real :: chacis0(ngs) real :: csaci0(ngs) ! collision rate only + real :: csacis0(ngs) ! collision rate only real :: chaci0(ngs) ! collision rate only real :: chacs0(ngs) ! collision rate only real :: chlaci0(ngs) @@ -13039,7 +14480,7 @@ subroutine nssl_2mom_gs & ! ! conversions ! - real qrfrz(ngs) ! , qirirhr(ngs) + real qrfrz(ngs), qrfrzfrac(ngs) ! , qirirhr(ngs) real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs) real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) real zhacw(ngs), zhacs(ngs), zhaci(ngs) @@ -13077,16 +14518,18 @@ subroutine nssl_2mom_gs & real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs) real qscnh(ngs), cscnh(ngs), vscnh(ngs) real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs) - real qiint(ngs),qipipnt(ngs),qicicnt(ngs) - real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs) + real qiint(ngs),qipipnt(ngs),qicicnt(ngs),qidint(ngs),qiintv(ngs) + real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs),cninda(ngs) real tke(ngs) real uvel(ngs),vvel(ngs) ! real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs), + real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) ! ,qicev(ngs) real qismlr(ngs) ! + ! real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) @@ -13167,7 +14610,7 @@ subroutine nssl_2mom_gs & real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) real ehxr(ngs),ehlr(ngs),egmr(ngs) - real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) + real eri(ngs),esi(ngs),esis(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),ehsfac(ngs) real ehscnv(ngs) @@ -13176,7 +14619,7 @@ subroutine nssl_2mom_gs & real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs) real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) - real esiclsn(ngs) + real esiclsn(ngs),esisclsn(ngs) real :: ehs_collsn = 0.5, ehi_collsn = 1.0 real :: efs_collsn = 0.5, efi_collsn = 1.0 @@ -13233,6 +14676,7 @@ subroutine nssl_2mom_gs & real pqlwlghi(ngs),pqlwlghli(ngs) real pqlwlghd(ngs),pqlwlghld(ngs) + @@ -13411,6 +14855,7 @@ subroutine nssl_2mom_gs & integer :: infdo real tau, ewtmp + integer cntnic_noliq real q_noliqmn, q_noliqmx @@ -13420,8 +14865,10 @@ subroutine nssl_2mom_gs & ! arrays for temporary bin space + real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt + real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt real :: term1,term2,term3,term4 @@ -13433,15 +14880,20 @@ subroutine nssl_2mom_gs & 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) + + + +! 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) + ! ! #################################################################### ! @@ -13453,6 +14905,7 @@ subroutine nssl_2mom_gs & ! + pb(:) = 0.0 pinit(:) = 0.0 itile = nx @@ -13471,6 +14924,8 @@ 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 @@ -13478,6 +14933,7 @@ subroutine nssl_2mom_gs & IF ( lhl > 1 ) lrescalelow(lhl) = rescale_low_alphahl .and. rescale_low_alpha + ! ! slope intercepts ! @@ -13500,7 +14956,9 @@ subroutine nssl_2mom_gs & ENDDO + ffrzh = 1 + ! DO il = lc,lhab ! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) ! ENDDO @@ -13664,10 +15122,12 @@ subroutine nssl_2mom_gs & mltdiam(ndiam+4) = mltdiam4 !200.0e-3 ENDIF + kzb = 1 kze = ktile ! if (kzend .eq. nzend) kze = kzend-kzbeg+1-kstag + ! ! cw constants in mks units ! @@ -13704,6 +15164,7 @@ subroutine nssl_2mom_gs & iend = 0 + ! timetd1 = etime(tarray) ! timetd1 = tarray(1) @@ -13768,6 +15229,7 @@ subroutine nssl_2mom_gs & qvs(1) = pqs(1)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(1) = rdorv*esbolton*tabqvs(ltemq)/(pres(1) - esbolton*tabqvs(ltemq)) + ENDIF IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN @@ -13789,6 +15251,7 @@ subroutine nssl_2mom_gs & ENDIF + if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & @@ -13810,10 +15273,12 @@ subroutine nssl_2mom_gs & if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5, ngscnt = ',ngscnt + ! write(0,*) 'allocating qc' xv(:,:) = 0.0 + xmas(:,:) = 0.0 vtxbar(:,:,:) = 0.0 xdia(:,:,:) = 0.0 @@ -13829,11 +15294,15 @@ subroutine nssl_2mom_gs & ! ! define temporaries for state variables to be used in calculations ! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = def temps' + do mgs = 1,ngscnt + kgsm(mgs) = max(kgs(mgs)-1,1) kgsp(mgs) = min(kgs(mgs)+1,nz-1) kgsm2(mgs) = Max(kgs(mgs)-2,1) + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs) theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) @@ -13860,6 +15329,7 @@ subroutine nssl_2mom_gs & qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN @@ -13878,6 +15348,9 @@ subroutine nssl_2mom_gs & if ( temg(mgs) .lt. tfr ) then il5(mgs) = 1 end if + + qrfrzfrac(mgs) = 1.0 + enddo !mgs IF ( ipconc < 1 .and. lwsm6 ) THEN @@ -13909,13 +15382,17 @@ subroutine nssl_2mom_gs & + + ! ! 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 @@ -13924,11 +15401,19 @@ subroutine nssl_2mom_gs & cx(mgs,li) = 0.0 ENDIF + IF ( lcina .gt. 1 ) THEN cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) ELSE cina(mgs) = cx(mgs,li) ENDIF + + IF ( lcinda .gt. 1 ) THEN + cinda(mgs) = an(igs(mgs),jy,kgs(mgs),lcinda) + ELSE + cinda(mgs) = cx(mgs,li) + ENDIF + IF ( lcin > 1 ) THEN ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin) ENDIF @@ -13949,6 +15434,7 @@ subroutine nssl_2mom_gs & ELSE ccnc(mgs) = 0.0 ENDIF + IF ( lccna .gt. 1 ) THEN ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ELSE @@ -13994,6 +15480,7 @@ subroutine nssl_2mom_gs & end do end if if ( ipconc .ge. 5 ) then + do mgs = 1,ngscnt cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) @@ -14015,12 +15502,14 @@ subroutine nssl_2mom_gs & ENDIF + end do end if if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then + do mgs = 1,ngscnt cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) @@ -14042,6 +15531,7 @@ subroutine nssl_2mom_gs & ENDIF + end do end if @@ -14076,6 +15566,9 @@ subroutine nssl_2mom_gs & + + + ! ! 6th moments ! @@ -14092,8 +15585,16 @@ subroutine nssl_2mom_gs & ENDIF + + IF ( ipconc .ge. 6 ) THEN + tmp = alphamax - 1.0 + g1xmax = (6.0 + tmp)*(5.0 + tmp)*(4.0 + tmp)/ & + & ((3.0 + tmp)*(2.0 + tmp)*(1.0 + tmp)) + g1xmin = (6.0 + alphamin)*(5.0 + alphamin)*(4.0 + alphamin)/ & + & ((3.0 + alphamin)*(2.0 + alphamin)*(1.0 + alphamin)) + 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)) @@ -14118,7 +15619,22 @@ subroutine nssl_2mom_gs & ENDIF + + IF ( ipconc == 5 ) THEN + ! set up factors for ihlcnh=3 conversion + g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + g1x(:,lh) = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + IF ( lhl > 0 ) THEN + g1x(:,lhl) = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + ENDIF + ENDIF + + scx(:,:) = 0.0 + ! ! set shape parameters ! @@ -14131,6 +15647,7 @@ subroutine nssl_2mom_gs & alpha(:,li) = xnu(li) alpha(:,lc) = xnu(lc) + IF ( idiagnosecnu > 0 ) THEN DO mgs = 1,ngscnt IF ( cx(mgs,lc) > cxmin ) THEN @@ -14143,6 +15660,7 @@ subroutine nssl_2mom_gs & ENDDO ENDIF + IF ( imusnow == 1 ) THEN alpha(:,ls) = alphas ELSEIF ( imusnow == 3 ) THEN @@ -14173,6 +15691,7 @@ subroutine nssl_2mom_gs & da1lr(:) = da1(lr) da0lc(:) = da0(lc) da1lc(:) = da1(lc) + IF ( idiagnosecnu > 0 ) THEN DO mgs = 1,ngscnt IF ( cx(mgs,lc) > cxmin ) THEN @@ -14183,19 +15702,28 @@ subroutine nssl_2mom_gs & ENDIF + 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 + IF ( icorrecthaildbz == 0 ) THEN + rzxhlh(:) = rzhlh + ELSE + rzxhlh(:) = 1.0 ! correction already accounts for difference in shape param + ENDIF 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 @@ -14218,6 +15746,7 @@ subroutine nssl_2mom_gs & ! ! set factors ! + do mgs = 1,ngscnt ! ssi(mgs) = qx(mgs,lv)/qis(mgs) @@ -14252,7 +15781,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) @@ -14345,6 +15874,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt xdn(mgs,li) = xdn0(li) + xdn(mgs,lc) = xdn0(lc) xdn(mgs,lr) = xdn0(lr) xdn(mgs,ls) = xdn0(ls) @@ -14358,6 +15888,7 @@ subroutine nssl_2mom_gs & IF ( lvol(lh) .gt. 1 ) THEN IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN IF ( mixedphase ) THEN + ELSE dnmx = xdnmx(lh) ENDIF @@ -14372,6 +15903,7 @@ subroutine nssl_2mom_gs & ENDIF + IF ( lhl .gt. 1 ) THEN xdn(mgs,lhl) = xdn0(lhl) @@ -14381,6 +15913,7 @@ subroutine nssl_2mom_gs & 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 @@ -14536,6 +16069,7 @@ subroutine nssl_2mom_gs & massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) ENDIF + ! Find shape parameter rain g1shr = 1.0 @@ -14878,7 +16412,7 @@ subroutine nssl_2mom_gs & 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 + IF ( zx(mgs,il) > zxmin .and. cx(mgs,il) <= cxmin ) 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))) @@ -14886,6 +16420,17 @@ subroutine nssl_2mom_gs & 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) + IF ( cx(mgs,il) < cxmin ) THEN + ! if resulting concentration is too small, then zero out + 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) + + 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 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN ! have mass and concentration but no reflectivity, so set reflectivity, using default alpha @@ -14900,6 +16445,18 @@ subroutine nssl_2mom_gs & 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) + IF ( zx(mgs,il) <= zxmin ) THEN + ! if resulting reflectivity is still too small, then zero out + 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) + + 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 + 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 @@ -14956,7 +16513,7 @@ subroutine nssl_2mom_gs & ! check for artificial breakup (graupel/hail larger than allowed max size) - IF ( imaxdiaopt == 1 ) THEN + IF ( imaxdiaopt == 1 .or. il /= lr ) 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)))) @@ -14983,12 +16540,21 @@ subroutine nssl_2mom_gs & 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)) ) +! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + ! check if incoming zx is consistent + ! Z from incoming cx, qx, and alpha + tmpz = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/tmp + IF ( tmpz > zx(mgs,il) ) THEN + tmpc = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/zx(mgs,il) + cx(mgs,il) = Max(cx(mgs,il), tmpc) + ! find cx that gives zx + ENDIF + zx(mgs,il) = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/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) + qr = qx(mgs,il) + chw = cx(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))/ & @@ -15043,7 +16609,7 @@ subroutine nssl_2mom_gs & 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 + ! Usual resetting of reflectivity moment to force consistency 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 @@ -15102,12 +16668,12 @@ subroutine nssl_2mom_gs & gf1palp(mgs) = y IF ( iferwisventr == 2 ) THEN +! ventrn = Gamma(alphar + 2.5 + br/2.)/Gamma(alphar + 1.) ! adapted from Wisner et al. 1972 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 @@ -15218,6 +16784,7 @@ subroutine nssl_2mom_gs & 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 @@ -15247,6 +16814,7 @@ subroutine nssl_2mom_gs & ! CALL cld_cpu('Z-MOMENT-1') + ! ! set some values for ice nucleation ! @@ -15255,12 +16823,16 @@ subroutine nssl_2mom_gs & ! wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & ! & +w(igs(mgs),jgs,kgs(mgs))) + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & & +w(igs(mgs),jgs,kgsm(mgs))) cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) + IF ( icenucopt == 5 .or. icenucopt == 6 ) THEN + cninda(mgs) = t7d(igs(mgs),jgs,kgs(mgs)) + ENDIF end do ! @@ -15277,9 +16849,12 @@ subroutine nssl_2mom_gs & ! & itype1a,itype2a,temcg,infdo,alpha) + infdo = 1 IF ( rimdenvwgt > 0 ) infdo = 1 + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & & ipconc,ndebug,ngs,nz,igs,kgs,fadvisc, & @@ -15288,6 +16863,8 @@ subroutine nssl_2mom_gs & ! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + + IF ( lwsm6 .and. ipconc == 0 ) THEN tmp = Max(qxmin(lh), qxmin(ls)) DO mgs = 1,ngscnt @@ -15301,6 +16878,7 @@ subroutine nssl_2mom_gs & ENDIF + ! ! Set number concentrations (need xdia from setvt) ! @@ -15345,6 +16923,7 @@ subroutine nssl_2mom_gs & end if IF ( ipconc .ge. 2 ) THEN + DO mgs = 1,ngscnt rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.) @@ -15364,6 +16943,7 @@ subroutine nssl_2mom_gs & ENDDO ENDIF + ! ! ! @@ -15371,6 +16951,7 @@ subroutine nssl_2mom_gs & ! maximum depletion tendency by any one source ! ! + if( ndebug .ge. 0 ) THEN !mpi! write(0,*) 'Set depletion max/min1' endif @@ -15387,6 +16968,7 @@ subroutine nssl_2mom_gs & qrmxd(mgs) = frac*qx(mgs,lr)*dtpinv qsmxd(mgs) = frac*qx(mgs,ls)*dtpinv qhmxd(mgs) = frac*qx(mgs,lh)*dtpinv + IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)*dtpinv end do ! @@ -15439,6 +17021,7 @@ subroutine nssl_2mom_gs & + IF ( ipconc >= 6 ) THEN frac = 0.4d0 zxmxd(:,:) = 0.0 @@ -15454,6 +17037,8 @@ subroutine nssl_2mom_gs & + + ! default factors between mean volume and maximum mass volume maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) ) maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) ) @@ -15482,6 +17067,7 @@ subroutine nssl_2mom_gs & + DO mgs = 1,ngscnt DO il = lh,lhab ! graupel and hail only (and frozen drops) @@ -15515,6 +17101,7 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies' ! + do mgs = 1,ngscnt ! ! @@ -15555,6 +17142,7 @@ subroutine nssl_2mom_gs & ! eiw(mgs) = 0.0 eii(mgs) = 0.0 + ehsclsn(mgs) = 0.0 ehiclsn(mgs) = 0.0 ehlsclsn(mgs) = 0.0 @@ -15612,6 +17200,7 @@ subroutine nssl_2mom_gs & ENDIF + IF ( lhl .gt. 1 ) THEN ! hail is turned on ihlr(mgs) = 1 IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN @@ -15652,11 +17241,12 @@ subroutine nssl_2mom_gs & 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 + eiw(mgs) = eiw0 end if if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 end if + ! ! ! @@ -15793,9 +17383,17 @@ subroutine nssl_2mom_gs & 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) + ELSEIF ( ssi(mgs) <= 1.005 ) THEN ! ssi in range of 1.0 to 1.005 + fac = 0.1 + (ssi(mgs) - 1.0)*(fac - 0.1)/(1.005 - 1.0) ! Max(0.1, fac*(ssi(mgs) - 1.0)/0.005) + ehsfac(mgs) = fac ! Max(0.1, (ssi(mgs) - 1.0)/0.005) + ENDIF + ELSEIF ( iessopt == 5 ) THEN ! factor based on ice supersat; very roughly based on Hosler et al. 1957 (J. Met.) + IF ( ssi(mgs) < 0.90 ) THEN + fac = 0.1 + ehsfac(mgs) = 0.1 + ELSEIF ( ssi(mgs) < 1.0 ) THEN ! ssi in range of 0.9 to 1.0 + fac = 0.1 + (ssi(mgs) - 0.9)*(fac - 0.1)/(1.0 - 0.9) + ehsfac(mgs) = fac ! Max(0.1, 0.1*(1.0 - ssi(mgs))/0.1) ENDIF ENDIF @@ -15827,6 +17425,8 @@ subroutine nssl_2mom_gs & ! ENDIF if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 end if + + ! ! ! @@ -15946,6 +17546,7 @@ subroutine nssl_2mom_gs & end if ENDIF + ! ! @@ -16080,6 +17681,7 @@ subroutine nssl_2mom_gs & + ! ! ! @@ -16152,7 +17754,9 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt qraci(mgs) = 0.0 + qracif(mgs) = 0.0 craci(mgs) = 0.0 +! cracif(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 @@ -16321,6 +17925,7 @@ subroutine nssl_2mom_gs & ENDIF end do ! + ! ! do mgs = 1,ngscnt @@ -16361,6 +17966,7 @@ subroutine nssl_2mom_gs & ! ! + if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' ! do mgs = 1,ngscnt @@ -16372,7 +17978,9 @@ subroutine nssl_2mom_gs & zhacw(mgs) = 0.0 IF ( .false. ) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1)) vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2)) vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3)) @@ -16525,8 +18133,7 @@ subroutine nssl_2mom_gs & end do - qhacis(:) = 0.0 - qhacis0(:) = 0.0 + ! ! do mgs = 1,ngscnt @@ -16679,7 +18286,9 @@ subroutine nssl_2mom_gs & vhlacw(mgs) = 0.0 vhlsoak(mgs) = 0.0 IF ( lhl > 1 .and. .true.) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1)) vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2)) vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3)) @@ -16780,6 +18389,7 @@ subroutine nssl_2mom_gs & qhlacis(:) = 0.0 qhlacis0(:) = 0.0 + qhlacs(:) = 0.0 qhlacs0(:) = 0.0 IF ( lhl .gt. 1 ) THEN @@ -16877,6 +18487,7 @@ subroutine nssl_2mom_gs & end do + ! ! if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' @@ -16901,7 +18512,7 @@ subroutine nssl_2mom_gs & ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) ENDIF IF ( imurain == 1 ) THEN ! gamma of diameter - IF ( iacrsize /= 4 ) THEN + IF ( iacrsize /= 4 ) THEN IF ( iacrsize .eq. 1 ) THEN ratio = 500.e-6/xdia(mgs,lr,1) ELSEIF ( iacrsize .eq. 2 ) THEN @@ -16910,6 +18521,9 @@ subroutine nssl_2mom_gs & ratio = 40.e-6/xdia(mgs,lr,1) ELSEIF ( iacrsize .eq. 5 ) THEN ratio = 150.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 6 ) THEN + ratio = 60.e-6/xdia(mgs,lr,1) + ni = cx(mgs,li) ENDIF i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) @@ -16935,10 +18549,10 @@ subroutine nssl_2mom_gs & qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) - ELSE ! iacrsize == 4 : use all - nr = cx(mgs,lr) - qr = qx(mgs,lr) - ENDIF + ELSE ! iacrsize == 4 : use all + nr = cx(mgs,lr) + qr = qx(mgs,lr) + ENDIF vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) @@ -16947,9 +18561,9 @@ subroutine nssl_2mom_gs & & ( da0(li)*xdia(mgs,li,3)**2 + & & dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da1(lr)*xdia(mgs,lr,3)**2 ) - + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) - + ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & @@ -17037,7 +18651,13 @@ subroutine nssl_2mom_gs & ! ave. diam of freezing drops in microns IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns - csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs) + fac = 1.0 + IF ( nsplinter .eq. 1001 ) THEN + ! fac = 0.2/sqrt(2.0*pi*10.**2)*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ! ELSE + fac = 0.2*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ENDIF + csplinter(mgs) = fac*lawson_splinter_fac*tmpdiam**4*ciacr(mgs) ENDIF ELSEIF ( nsplinter .ge. 0 ) THEN csplinter(mgs) = nsplinter*ciacr(mgs) @@ -17103,12 +18723,13 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then do mgs = 1,ngscnt ciacw(mgs) = 0.0 - IF ( eiw(mgs) .gt. 0.0 ) THEN + IF ( eiw(mgs) .gt. 0.0 .and. xmas(mgs,lc) > 0.0 ) THEN ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) ENDIF end do + end if if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' @@ -17117,6 +18738,7 @@ subroutine nssl_2mom_gs & tmp1 = 0.0 cracw(mgs) = 0.0 cracr(mgs) = 0.0 + zracr(mgs) = 0.0 ec0(mgs) = 1.e9 IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) & & .and. qracw(mgs) .gt. 0.0 ) THEN @@ -17130,7 +18752,7 @@ subroutine nssl_2mom_gs & & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & & + gf3*xdia(mgs,lr,2) ) ENDIF - ELSE ! IF ( ipconc .ge. 3 .and. + ELSE ! IF ( ipconc .ge. 3 .and. ) IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{ IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) ! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN @@ -17167,18 +18789,19 @@ subroutine nssl_2mom_gs & ! 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) + tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of m (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 + tmpdiam = tmp ! Using collection efficiency factor ec0 to simulate break-up that off-sets self-collection (Zieger 1985; Cohard & Pinty 2000) ! ec0 is 1 for rain diameter < 600 microns and then drop off toward zero until diameter of 2mm to represent passive breakup ! ec0 does not go negative here (i.e., does not follow other versions that create extra breakup at large rain diameter) - IF ( ( tmp .gt. 1.9e-3 .and. irainbreak /= 10 .and. irainbreak /= 20 ) .or. icracr <= 0 ) THEN + IF ( ( tmpdiam .gt. 1.9e-3 .and. irainbreak /= 10 .and. irainbreak /= 20 ) .or. icracr <= 0 ) THEN ec0(mgs) = 0.0 cracr(mgs) = 0.0 IF ( ibincracr == 3 ) THEN @@ -17188,12 +18811,15 @@ subroutine nssl_2mom_gs & ENDIF ELSE IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN - IF ( xdia(mgs,lr,3) .lt. 6.1e-4 .or. irainbreak == 10 ) THEN + IF ( icracrthresh == 1 ) THEN + tmpdiam = xdia(mgs,lr,3) + ENDIF + + IF ( tmpdiam .lt. 6.1e-4 .or. irainbreak == 10 ) THEN ec0(mgs) = 1.0 ELSE - ec0(mgs) = Exp( -2500.0*(xdia(mgs,lr,3) - 6.0e-4) ) + ec0(mgs) = Exp( -2500.0*(tmpdiam - 6.0e-4) ) ENDIF - IF ( rwrad .ge. 50.e-6 ) THEN tmp1 = aa2*cx(mgs,lr)**2*xv(mgs,lr) @@ -17214,26 +18840,42 @@ subroutine nssl_2mom_gs & cracr(mgs) = tmp1 ENDIF ENDIF + ENDIF ! rwrad > 50 +! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) + ENDIF ! dmrauto <= 0 + ENDIF ! tmp > 1.9e-3 + + IF ( irainbreak == 100 ) THEN ! Morrison breakup + ec0(mgs) = 1.0 + IF ( xdia(mgs,lr,1) > 300.e-6 ) THEN + ec0(mgs) = 2. - Exp(2300.*(xdia(mgs,lr,1)-300.e-6)) + ENDIF + cracr(mgs) = 5.78*ec0(mgs)*cx(mgs,lr)*qx(mgs,lr) + ENDIF + + ENDIF ! ( qx(mgs,lr) .gt. qxmin(lr) ) - ENDIF ! dmrauto <= 0 - -! IF ( igs(mgs) == 15 ) write(6,*) 'cracr,k = ',kgs(mgs),cracr(mgs),qx(mgs,lr),cx(mgs,lr),ec0(mgs),rwrad -! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) - ENDIF - ENDIF - ENDIF ! active breakup option crbreak = 0.0 IF ( irainbreak == 1 .or. irainbreak == 10 ) THEN crbreak = Max( 0.0, rainbreakfac* (rho0(mgs)*qx(mgs,lr))**2 ) ! hand fit to lower range of wkqss output cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup - ELSEIF ( irainbreak == 2 .or. irainbreak == 20 ) THEN + ELSEIF ( irainbreak == 2 .or. irainbreak == 20 .or. irainbreak == 12 ) THEN ! irainbreak == 20 does not work as intended + IF ( irainbreak == 12 ) THEN + IF ( xdia(mgs,lr,1) > 300.e-6 ) THEN + crbreak = Max( 0.0, rainbreakfac*(rho0(mgs)*qx(mgs,lr))**2 ) ! hand fit to lower range of wkqss output + ELSE + crbreak = 0.0 + ENDIF + ELSE crbreak = Max( 0.0, rainbreakfac*(1. - ec0(mgs))*(rho0(mgs)*qx(mgs,lr))**2 ) ! hand fit to lower range of wkqss output + ENDIF ! crbreak = Max(0.0, -0.18 + 1.139e6 * (rho0(mgs)*qx(mgs,lr) + 0.00038106)**2) cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup + ELSEIF ( irainbreak == 11 .and. rho0(mgs)*qx(mgs,lr) > qrbrthresh1 .and. ipconc >= 5 ) THEN ! Ad hoc method to break up drops in the DSD tail (D > draintail) @@ -17265,6 +18907,7 @@ subroutine nssl_2mom_gs & ! ENDIF cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup + ! reflectivity -- not used yet: goes into zracr ! IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! tmp3 = gaminterp(ratio,alpha(mgs,lr),11,1) @@ -17274,17 +18917,32 @@ subroutine nssl_2mom_gs & ! zxd1 = 0 ! ENDIF ! zrbreak = Max(0.0, zrbreak - crbreaksmall*drsmall**6) - ELSEIF ( irainbreak == 12 ) THEN - crbreak = Max( 0.0, 3.8098 * (rho0(mgs)*qx(mgs,lr))**1.9416 ) ! best fit to lower range of wkqss (collision only) output - cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup + +! ELSEIF ( irainbreak == 12 ) THEN +! crbreak = Max( 0.0, 3.8098 * (rho0(mgs)*qx(mgs,lr))**1.9416 ) ! best fit to lower range of wkqss (collision only) output +! cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup ENDIF ENDIF + IF ( lzr > 0 .and. cracr(mgs) /= 0.0 .and. cx(mgs,lr) > 0.0 ) THEN +! tmp = qx(mgs,lr)/cx(mgs,lr) +! zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) ) + ! rewrite because original can overestimate zracr if -cracr*dtp is on the order of cx (i.e., + ! large increase in the number of drops, which violates differential assumption + ! Pass -cracr because its meaning is backwards (neg. value ADDS number, positive value SUBTRACTS) + zracr(mgs) = zraten(dtpinv,dtp,g1x(mgs,lr),rho0(mgs),rho_qr,qx(mgs,lr),cx(mgs,lr),-cracr(mgs)) + +! zracr(mgs) = dtpinv*g1x(mgs,lr)*(6.*rho0(mgs)*qx(mgs,lr)/(pi*1000.))**2 & +! * ( cracr(mgs) )/((cx(mgs,lr) - dtp*cracr(mgs))*(cx(mgs,lr))) + ENDIF + ! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) + end do end if + ! ! ! @@ -17362,6 +19020,7 @@ subroutine nssl_2mom_gs & end if + ! ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' @@ -17469,6 +19128,7 @@ subroutine nssl_2mom_gs & end if + ! ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' @@ -17508,7 +19168,9 @@ subroutine nssl_2mom_gs & if (ndebug .gt. 0 ) write(0,*) 'conc 26a' DO mgs = 1,ngscnt + zrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 crcnw(mgs) = 0.0 cautn(mgs) = 0.0 @@ -17536,6 +19198,7 @@ subroutine nssl_2mom_gs & t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc)) qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) ) + crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) ) IF ( dmrauto == 0 ) THEN @@ -17558,7 +19221,8 @@ subroutine nssl_2mom_gs & tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) ! try mass*diameter-weighted average of old and new Dmr (using full qc mass) - crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/(xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) + crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/ & + (xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) @@ -17568,7 +19232,8 @@ subroutine nssl_2mom_gs & tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) ! try sqrt(diameter)-weighted average of old and new Dmr - crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/(sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) + crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/ & + (sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) ENDIF ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN IF ( qx(mgs,lr) > qxmin(lr) ) THEN @@ -17587,7 +19252,6 @@ subroutine nssl_2mom_gs & IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 -! IF ( igs(mgs) == 15 ) write(6,*) 'crcnw,k = ',kgs(mgs),crcnw(mgs),qx(mgs,lc),cx(mgs,lc),cautn(mgs),xv(mgs,lc) IF ( ipconc >= 6 ) THEN IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN @@ -17630,6 +19294,7 @@ subroutine nssl_2mom_gs & ! 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), @@ -17798,6 +19463,7 @@ subroutine nssl_2mom_gs & ! volt is given in cm**3, so convert to m**3 dbigg = (6./pi* volt )**(1./3.) + ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. IF ( dbigg < 8.e-3 ) THEN !{ only bother if freezing diameter is reasonable @@ -17839,16 +19505,81 @@ subroutine nssl_2mom_gs & ELSE !{ - - IF ( ipconc >= 6 .and. lzr > 1 ) THEN + + + IF ( (ipconc >= 5 .or. lzr > 1) ) THEN !{ + + cxd1 = crfrz(mgs)*dtp + qxd1 = qrfrz(mgs)*dtp + ! 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 ( ipconc >= 6 .and. lzr > 1 ) THEN + + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr) + ! Do the correction for alphamax + zrfrz(mgs) = zxd1*dtpinv + ! tmp4 is the Z from the converted particles assuming shape of alphamax + IF ( icorrectfddbz >= 1 .and. zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + IF ( icorrectfddbz == 1 ) THEN !{ + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + il = lh + IF ( lf > 0 ) il = lf + tmp3 = g1x(mgs,il)*(rho0(mgs)*(qx(mgs,il)+qxd1))**2/((pi*xdn(mgs,il)/6.0)**2*(zx(mgs,il)+zxd1) ) + crfrzf(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,il) ) + + ELSEIF ( icorrectfddbz > 1 ) THEN ! old version (not robust) + tmp3 = g1xmax*(rho0(mgs)*qxd1)**2/((pi*rhofrz/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new graupel/fd number to match zxd1 + ! increase cxd1 to make z,q,c rates consistent + ! cxd1 = g1xmax*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + crfrzf(mgs) = dtpinv*cxd1 + ENDIF + ENDIF !} + ENDIF + + ELSE + IF ( icorrectfddbz >= 1 ) THEN + tmp5 = g1x(mgs,lr)*(rho0(mgs)*qx(mgs,lr))**2/((pi*xdn(mgs,lr)/6.)**2*cx(mgs,lr)) + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*tmp5 ! reflectivity transfer from rain + IF ( icorrectfddbz == 1 ) THEN + IF ( zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + il = lh + IF ( lf > 0 ) il = lf + IF ( cx(mgs,il) > cxmin ) THEN + ! graupel/fd reflectivity + tmp = g1x(mgs,il)*(rho0(mgs)*qx(mgs,il))**2/((pi*xdn(mgs,il)/6.)**2*cx(mgs,il)) + ELSE + tmp = 0. + ENDIF + tmp3 = g1x(mgs,il)*(rho0(mgs)*(qx(mgs,il)+qxd1))**2/((pi*xdn(mgs,il)/6.0)**2*(tmp+zxd1) ) + crfrzf(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,il) ) + ENDIF + ELSEIF ( icorrectfddbz > 1 ) THEN ! old version + ! tmp5 is rain reflectivity moment + ! tmp4 is the reflectivity of the newly-converted graupel particles (use g1x(lh) for loss term) + ! which we want to match zxd1 to prevent spurious increase in total reflectivity + IF ( zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + tmp3 = g1x(mgs,lr)*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lr)/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new FD number to match zxd1 + crfrzf(mgs) = tmp3/zxd1*dtpinv + ENDIF + ENDIF + ENDIF ! t/f + ENDIF + ENDIF + 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 @@ -17858,10 +19589,12 @@ 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! @@ -17873,10 +19606,26 @@ 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 + + ELSEIF ( .false. ) THEN ! test code similar to capture freezing + + frach = 1.0 + IF ( crfrz(mgs) > qxmin(lh) ) THEN + xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) + + qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) + crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs) + + ENDIF + qrfrzs(mgs) = frach*qrfrz(mgs) + crfrzs(mgs) = frach*crfrz(mgs) + ELSE !{ ! recalculate using dhmn for ratio @@ -17886,7 +19635,7 @@ subroutine nssl_2mom_gs & ! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) ! j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) IF ( alp0flag ) THEN - j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + j = Int(Max(0.0,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) ELSE j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) ENDIF @@ -17916,6 +19665,7 @@ 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; @@ -17928,27 +19678,108 @@ subroutine nssl_2mom_gs & 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 ! } + + + IF ( ( ipconc >= 5 .or. lzr > 1 ) ) THEN !{ + + cxd1 = crfrzf(mgs)*dtp + qxd1 = qrfrzf(mgs)*dtp + + ! 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)) - ENDIF !} + ! interpolate along alpha; - IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN - fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) - qrfrz(mgs) = fac*qrfrz(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN !{ + + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr) + ! Do the correction for alphamax + zrfrz(mgs) = zxd1*dtpinv + ! tmp4 is the Z from the converted particles assuming shape of alphamax + IF ( icorrectfddbz >= 1 .and. zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + IF ( icorrectfddbz == 1 ) THEN + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + il = lh + IF ( lf > 0 ) il = lf + tmp3 = g1x(mgs,il)*(rho0(mgs)*(qx(mgs,il)+qxd1))**2/((pi*xdn(mgs,il)/6.0)**2*(zx(mgs,il)+zxd1) ) + crfrzf(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,il) ) + + ELSE ! old version (not robust) + tmp3 = g1xmax*(rho0(mgs)*qxd1)**2/((pi*rhofrz/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new graupel/fd number to match zxd1 + ! increase cxd1 to make z,q,c rates consistent + ! cxd1 = g1xmax*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + crfrzf(mgs) = dtpinv*cxd1 + ENDIF + ENDIF ! t/f + ENDIF + + ELSE ! }{ + IF ( icorrectfddbz >= 1 ) THEN + tmp5 = g1x(mgs,lr)*(rho0(mgs)*qx(mgs,lr))**2/((pi*xdn(mgs,lr)/6.)**2*cx(mgs,lr)) + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*tmp5 ! reflectivity transfer from rain + IF ( icorrectfddbz == 1 ) THEN + IF ( zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + il = lh + IF ( lf > 0 ) il = lf + IF ( cx(mgs,il) > cxmin ) THEN + ! graupel/fd reflectivity + tmp = g1x(mgs,il)*(rho0(mgs)*qx(mgs,il))**2/((pi*xdn(mgs,il)/6.)**2*cx(mgs,il)) + ELSE + tmp = 0. + ENDIF + tmp3 = g1x(mgs,il)*(rho0(mgs)*(qx(mgs,il)+qxd1))**2/((pi*xdn(mgs,il)/6.0)**2*(tmp+zxd1) ) + crfrzf(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,il) ) + ENDIF + ELSEIF ( icorrectfddbz > 1 ) THEN ! old version + ! tmp5 is rain reflectivity moment + tmp5 = g1x(mgs,lr)*(rho0(mgs)*qx(mgs,lr))**2/((pi*xdn(mgs,lr)/6.)**2*cx(mgs,lr)) + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*tmp5 + IF ( zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + ! tmp4 is the reflectivity of the newly-converted graupel particles (use g1x(lh) for loss term) + ! which we want to match zxd1 to prevent spurious increase in total reflectivity + tmp3 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lr)/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new FD number to match zxd1 + crfrzf(mgs) = tmp3/zxd1*dtpinv + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF !} + ENDIF !} + + ENDIF ! } + ELSE + crfrzs(mgs) = 0.0 + qrfrzs(mgs) = 0.0 + + zrfrzs(mgs) = 0.0 + + ENDIF ! } + + ENDIF !} + + IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN + fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) + qrfrz(mgs) = fac*qrfrz(mgs) qrfrzs(mgs) = fac*qrfrzs(mgs) qrfrzf(mgs) = fac*qrfrzf(mgs) 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 !} @@ -18072,7 +19903,13 @@ subroutine nssl_2mom_gs & tmp = 0 IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.) ! avg. diameter of newly frozen drops in microns - tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs) + fac = 1.0 + IF ( nsplinter .eq. 1001 ) THEN + ! fac = 0.2/sqrt(2.0*pi*10.**2)*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ! ELSE + fac = 0.2*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ENDIF + tmp = fac*lawson_splinter_fac*tmpdiam**4*crfrz(mgs) ENDIF ELSEIF ( nsplinter .gt. 0 ) THEN tmp = nsplinter*crfrz(mgs) @@ -18111,6 +19948,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qwfrz(mgs) = 0.0 cwfrz(mgs) = 0.0 + qwfrzc(mgs) = 0.0 cwfrzc(mgs) = 0.0 qwfrzp(mgs) = 0.0 @@ -18139,6 +19977,7 @@ subroutine nssl_2mom_gs & !!! cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs)) qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + ELSE ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc) @@ -18170,6 +20009,7 @@ subroutine nssl_2mom_gs & ENDIF + ENDIF ENDIF if ( temg(mgs) .gt. 268.15 ) then @@ -18179,16 +20019,18 @@ subroutine nssl_2mom_gs & end if ENDIF ! - if ( xplate(mgs) .eq. 1 ) then - qwfrzp(mgs) = qwfrz(mgs) - cwfrzp(mgs) = cwfrz(mgs) - end if + +! if ( xplate(mgs) .eq. 1 ) then + qwfrzp(mgs) = xplate(mgs)*qwfrz(mgs) + cwfrzp(mgs) = xplate(mgs)*cwfrz(mgs) +! end if ! - if ( xcolmn(mgs) .eq. 1 ) then - qwfrzc(mgs) = qwfrz(mgs) - cwfrzc(mgs) = cwfrz(mgs) - end if +! if ( xcolmn(mgs) .eq. 1 ) then + qwfrzc(mgs) = xcolmn(mgs)*qwfrz(mgs) + cwfrzc(mgs) = xcolmn(mgs)*cwfrz(mgs) +! end if + ! ! qwfrzp(mgs) = 0.0 ! qwfrzc(mgs) = qwfrz(mgs) @@ -18214,6 +20056,7 @@ subroutine nssl_2mom_gs & qwctfzc(mgs) = 0.0 cwctfzp(mgs) = 0.0 qwctfzp(mgs) = 0.0 + IF ( icfn .ge. 1 ) THEN IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN @@ -18273,20 +20116,22 @@ subroutine nssl_2mom_gs & ENDIF ! - if ( xplate(mgs) .eq. 1 ) then - qwctfzp(mgs) = qwctfz(mgs) - cwctfzp(mgs) = cwctfz(mgs) - end if + +! if ( xplate(mgs) .eq. 1 ) then + qwctfzp(mgs) = xplate(mgs)*qwctfz(mgs) + cwctfzp(mgs) = xplate(mgs)*cwctfz(mgs) +! end if ! - if ( xcolmn(mgs) .eq. 1 ) then - qwctfzc(mgs) = qwctfz(mgs) - cwctfzc(mgs) = cwctfz(mgs) - end if +! if ( xcolmn(mgs) .eq. 1 ) then + qwctfzc(mgs) = xcolmn(mgs)*qwctfz(mgs) + cwctfzc(mgs) = xcolmn(mgs)*cwctfz(mgs) +! end if ! IF ( cwctfz(mgs)*dtp > 0.5 .and. dtp*qwctfz(mgs) > qxmin(li) ) THEN ! write(91,*) 'cwctfz: ',cwctfz(mgs),qwctfz(mgs) ! ,cwctfzc(mgs),qwctfzc(mgs) ! ENDIF + ! ! qwctfzc(mgs) = qwctfz(mgs) ! qwctfzp(mgs) = 0.0 @@ -18302,8 +20147,6 @@ subroutine nssl_2mom_gs & ! Hobbs-Rangno ice enhancement (Ferrier, 1994) ! if (ndebug .gt. 0 ) write(0,*) 'conc 23a' - dthr = 300.0 - hrifac = (1.e-3)*((0.044)*(0.01**3)) do mgs = 1,ngscnt ciihr(mgs) = 0.0 qiihr(mgs) = 0.0 @@ -18311,9 +20154,15 @@ subroutine nssl_2mom_gs & qicichr(mgs) = 0.0 cipiphr(mgs) = 0.0 qipiphr(mgs) = 0.0 + ENDDO + + dthr = 300.0 + ! hrifac = (1.e-3)*((0.044)*(0.01**3)) + hrifac = cimas1 IF ( ihrn .ge. 1 ) THEN + do mgs = 1,ngscnt if ( qx(mgs,lc) .gt. qxmin(lc) ) then - if ( temg(mgs) .lt. 273.15 ) then + if ( temg(mgs) .lt. 265.15 ) then ! write(iunit,'(3(1x,i3),3(1x,1pe12.5))') ! : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc) ! write(iunit,'(1pe15.6)') @@ -18325,10 +20174,10 @@ subroutine nssl_2mom_gs & ! > ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6))) IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN - ciihr(mgs) = ((1.69e17)/dthr) & + ciihr(mgs) = ((1.69e17)) & & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * & & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.) - ciihr(mgs) = ciihr(mgs)*(1.0e6) + ciihr(mgs) = (ciihr(mgs)*(1.0e6) - cx(mgs,li) - cx(mgs,ls))/dthr qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs) qiihr(mgs) = max(qiihr(mgs), 0.0) qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs)) @@ -18349,8 +20198,8 @@ subroutine nssl_2mom_gs & ! end if end if - ENDIF ! ihrn end do + ENDIF ! ihrn ! ! ! @@ -18416,6 +20265,7 @@ subroutine nssl_2mom_gs & + ! ! Ventilation coeficients ! @@ -18455,6 +20305,7 @@ subroutine nssl_2mom_gs & ENDIF + ENDIF ! icond .eq. 1 end do @@ -18494,6 +20345,7 @@ subroutine nssl_2mom_gs & x = 1. + alpha(mgs,lr) IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! 3 moment + tmp = 1. + alpr ! alpha(mgs,lr) i = Int(dgami*(tmp)) del = tmp - dgam*i @@ -18503,6 +20355,7 @@ subroutine nssl_2mom_gs & 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 @@ -18520,12 +20373,14 @@ subroutine nssl_2mom_gs & 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 ! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br @@ -18537,7 +20392,9 @@ subroutine nssl_2mom_gs & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + IF ( ipconc >= 7 ) THEN + ! vent coeff. for reflectivity rate from evaporation alpr = Min(alpharmax,alpha(mgs,lr) ) tmp = alpr + 5.5 + br/2. @@ -18554,6 +20411,7 @@ subroutine nssl_2mom_gs & ENDIF + ENDIF ! iferwisventr @@ -18601,8 +20459,8 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( icdx /= 6 .and. alpha(mgs,lh) .eq. 0.0 ) THEN hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) - IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN hwvent(mgs) = & & ( hwventa + hwventb*hwventc*fvent(mgs) & & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) & @@ -18643,6 +20501,7 @@ subroutine nssl_2mom_gs & end do + hlvent(:) = 0.0 hlventy(:) = 0.0 @@ -18654,9 +20513,9 @@ subroutine nssl_2mom_gs & ! hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25) do mgs = 1,ngscnt IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN - hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25) - IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN + IF ( icdxhl /= 6 .and. alpha(mgs,lhl) .eq. 0.0 ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25) hlvent(mgs) = & & ( hwventa + hwventb*hwventc*fvent(mgs) & & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) & @@ -18781,6 +20640,8 @@ subroutine nssl_2mom_gs & chlmlrr(:) = 0.0 + + if ( .not. mixedphase ) then !{ do mgs = 1,ngscnt ! @@ -18793,6 +20654,7 @@ subroutine nssl_2mom_gs & & , 0.0 ) ENDIF + ! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), ! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) @@ -18816,6 +20678,7 @@ subroutine nssl_2mom_gs & ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + qhmlr(mgs) = & & min( & & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & @@ -19668,9 +21531,11 @@ subroutine nssl_2mom_gs & ! write(iunit,*) 'chmlrr parts: ',(qhmlr0-qhmlr05)/((qxd1-qxd05)/(cxd1-cxd05)), qhmlr05/(qxd05/cxd05), rho0(mgs)*(qhmlr2*mltmass1inv), rho0(mgs)*( qhmlr12*mltmass2inv) ! write(iunit,*) 'qhmlr0: ',qhmlr0,qhmlr05,qhmlr2,qhmlr12 ! ENDIF + ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN + ENDIF @@ -19698,8 +21563,7 @@ subroutine nssl_2mom_gs & ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results -! #ifdef 1 -! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP ) + qhlmlr(mgs) = & & min( & @@ -20668,8 +22532,10 @@ subroutine nssl_2mom_gs & ENDIF !} + ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results + ENDIF ! ibinhlmlr @@ -20695,6 +22561,7 @@ subroutine nssl_2mom_gs & IF ( .not. mixedphase ) THEN qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.95*qx(mgs,lh)*dtpinv ) ) 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. ! not used @@ -20716,6 +22583,7 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) + IF ( .not. mixedphase ) THEN !{ IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN ! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) @@ -20734,6 +22602,7 @@ subroutine nssl_2mom_gs & + ! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN ! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail ! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) @@ -20774,7 +22643,9 @@ 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) @@ -20783,6 +22654,7 @@ subroutine nssl_2mom_gs & 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 @@ -20888,6 +22760,7 @@ subroutine nssl_2mom_gs & ENDIF !} + IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN IF ( cx(mgs,lhl) > 0.0 ) THEN @@ -20899,6 +22772,7 @@ subroutine nssl_2mom_gs & zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) ) ENDIF ENDIF + ENDIF ! } ENDIF ! }.not. mixedphase @@ -20917,6 +22791,7 @@ subroutine nssl_2mom_gs & rwcap(mgs) = (0.5)*xdia(mgs,lr,1) swcap(mgs) = (0.5)*xdia(mgs,ls,1) hwcap(mgs) = (0.5)*xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1) if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then @@ -20939,11 +22814,13 @@ subroutine nssl_2mom_gs & qhdsv(:) = 0.0 qhldsv(:) = 0.0 + do mgs = 1,ngscnt IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN qidsv(mgs) = & & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac + qsdsv(mgs) = & & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac @@ -20954,11 +22831,13 @@ subroutine nssl_2mom_gs & ! ENDIF ELSE qidsv(mgs) = 0.0 + qsdsv(mgs) = 0.0 ENDIF qhdsv(mgs) = & & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac + IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac ! ! @@ -21008,6 +22887,7 @@ subroutine nssl_2mom_gs & qsstmp = qisstmp + dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp ) @@ -21030,6 +22910,7 @@ subroutine nssl_2mom_gs & ! evaporation and sublimation adjustment ! if( dqwv(mgs) .lt. 0. ) then ! { subsaturated + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit dqci(mgs) = dqwv(mgs) dqwv(mgs) = 0. @@ -21087,6 +22968,7 @@ subroutine nssl_2mom_gs & dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qsstmp/ & & ((temg(mgs)-cbi)**2)) + if ( temg(mgs) .ge. tfr ) then dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qsstmp/ & & ((temg(mgs)-cbw)**2)) @@ -21144,15 +23026,18 @@ subroutine nssl_2mom_gs & qvstmp = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvstmp = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qisstmp = pqs(mgs)*tabqis(ltemq) qctmp(mgs) = max( 0.0, qctmp(mgs) ) qitmp(mgs) = max( 0.0, qitmp(mgs) ) qvtmp(mgs) = max( 0.0, qvaptmp ) + ! qsstmp = qvstmp qsstmp = qisstmp + ELSE ! set max depletion @@ -21195,6 +23080,7 @@ subroutine nssl_2mom_gs & chlcev(:) = 0.0 qfcev(:) = 0.0 + do mgs = 1,ngscnt qisbv(mgs) = 0.0 qssbv(mgs) = 0.0 @@ -21203,6 +23089,7 @@ subroutine nssl_2mom_gs & 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 ! last condition (qr qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. & + temg(mgs) .le. tfr + wetgrthtoffset .and. temg(mgs) .ge. 243.15 ) ) 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 + + + 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 + + + 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) + + + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT + + ENDDO + ENDIF + + dhwet(mgs) = Min(dg0thresh + 0.0001, Max( d, dwetmin )) + ELSE + dhwet(mgs) = dg0thresh + 0.0001 + ENDIF + + IF (((qhlacw(mgs) + qhlacr(mgs))*dtp > qxmin(lhl) .and. qx(mgs,lhl) > 0.01e-3 & + .and. temg(mgs) .le. tfr + wetgrthtoffset .and. temg(mgs) .ge. 243.15 ) ) THEN +! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehlw(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)*(ehlw(mgs)*qx(mgs,lc)+ehlr(mgs)*qx(mgs,lr)) - & +! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + IF ( dhwet(mgs) < dg0thresh ) THEN ! if there is graupel, then probably dhwet is good starting value + d = dhwet(mgs) + ELSE + x = 1.1e4 * rho0(mgs)*(ehlw(mgs)*qx(mgs,lc)+ehlr(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 + ENDIF + IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN + +! 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, ehlw(mgs))*qx(mgs,lc) + h4 = ehlr(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,lhl)*d**bxx(mgs,lhl) + 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 + + + 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) + + + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT + + ENDDO + ENDIF + + dhlwet(mgs) = Min(dg0thresh + 0.0001, Max( d, dwetmin ) ) + + ELSE + dhlwet(mgs) = dg0thresh + 0.0001 + ENDIF + + + + ENDDO + + ENDIF ! incwet @@ -21429,6 +23464,7 @@ subroutine nssl_2mom_gs & & + qhacw(mgs) ! + qhldry(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & @@ -21441,7 +23477,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt - IF ( tfrdry < temg(mgs) .and. 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) @@ -21452,34 +23488,230 @@ subroutine nssl_2mom_gs & ! IF ( dnu(lh) .ne. 0. ) THEN ! qhwet(mgs) = qhdry(mgs) ! ELSE - IF ( incwet == 0 ) THEN + ! 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 + qhwet(mgs) = max( 0.0, qhwet(mgs)) + + IF ( incwet == 1 .and. qhwet(mgs) < qhdry(mgs) .and. dhwet(mgs) < dg0thresh ) THEN + ! ELSE + + ! IF ( dhwet(mgs) < dg0thresh ) THEN + ! find portion of qc and qr collection that are dry/wet growth for d > dwet + + ratio = Min( maxratiolu, dhwet(mgs)/xdia(mgs,lh,1) ) + + tmp1 = gaminterp(ratio,alpha(mgs,lh),13,1) ! alpha + 3 + tmp2 = gaminterp(ratio,alpha(mgs,lh),12,1) ! alpha + 2 + tmp3 = gaminterp(ratio,alpha(mgs,lh), 9,1) ! alpha + 1 + + IF ( qhacw(mgs)*dtp > qxmin(lh) ) THEN + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) + + ! dry growth of qc for D > Dwet to substract from qhacw + qxacwtmp = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & tmp3*da1lc(mgs)*xdia(mgs,lc,3)**2 ) + ELSE + qxacwtmp = 0.0 + ENDIF + + IF ( qhacr(mgs)*dtp > qxmin(lh) ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) + + ! dry growth of qr for D > Dwet to substract from qhacr + qxacrtmp = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & tmp3*da1lr(mgs)*xdia(mgs,lr,3)**2 ) + ELSE + qxacrtmp = 0.0 + ENDIF + + ! hwvent is where the size dependency is, so hxventtmp gives the portion for d > dwet + x = gaminterp(ratio,alpha(mgs,lh),9,1) ! alpha + 1 + y = gaminterp(ratio,alpha(mgs,lh),3,1) ! alpha + b/2 + 5/2 + + hxventtmp = 0.78*x + y*hwventy(mgs) ! & + + ! find the ice and snow collection for d > dwet + qxacitmp = 0.0 + IF ( qhaci(mgs)*dtp > qxmin(lh) ) THEN + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) + + ! note that ehi=1 implicitly here + qxacitmp = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & tmp3*da1(li)*xdia(mgs,li,3)**2 ) + + cxacitmp = & + & 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab0lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & tmp3*da0(li)*xdia(mgs,li,3)**2 ) + ENDIF + + qxacstmp = 0.0 + IF ( qhacs(mgs)*dtp > qxmin(lh) ) THEN + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) + + ! note that ehs=1 implicitly here + qxacstmp = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & tmp3*da1(ls)*xdia(mgs,ls,3)**2 ) + + cxacstmp = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab0lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & tmp3*da0(ls)*xdia(mgs,ls,3)**2 ) + ENDIF + + qxwettmp = & + & xdia(mgs,lh,1)*hxventtmp*cx(mgs,lh)*fwet1(mgs) & + & + fwet2(mgs)*(qxacitmp + qxacstmp) + + tmp = qhwet(mgs) + ! as dry growth but subtract part for D > Dw and add wet growth for D > Dw + qhwet(mgs) = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) & + - ehi(mgs)*qxacitmp - ehs(mgs)*qxacstmp & + - qxacwtmp - qxacrtmp + qxwettmp + + qhaci(mgs) = qhaci(mgs) + (1.0 - ehi(mgs))*qxacitmp + qhacs(mgs) = qhacs(mgs) + (1.0 - ehs(mgs))*qxacstmp + chaci(mgs) = chaci(mgs) + (1.0 - ehi(mgs))*cxacitmp + chacs(mgs) = chacs(mgs) + (1.0 - ehs(mgs))*cxacstmp + + + ! qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + ! ELSE ! for dwet > 15cm, just assume dry growth + ! qhwet(mgs) = qhdry(mgs) + ! ENDIF + ENDIF ! ENDIF + qhlwet(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN - IF ( incwet == 0 ) THEN + !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 + IF ( incwet == 1 .and. qhlwet(mgs) < qhldry(mgs) .and. dhlwet(mgs) < dg0thresh ) THEN + !ELSE + + ! IF ( dhlwet(mgs) < dg0thresh ) THEN + ! find portion of qc and qr collection that are dry/wet growth for d > dwet + + ratio = Min( maxratiolu, dhlwet(mgs)/xdia(mgs,lhl,1) ) + + tmp1 = gaminterp(ratio,alpha(mgs,lhl),13,2) ! alpha + 3 + tmp2 = gaminterp(ratio,alpha(mgs,lhl),12,2) ! alpha + 2 + tmp3 = gaminterp(ratio,alpha(mgs,lhl), 9,2) ! alpha + 1 + + IF ( qhlacw(mgs)*dtp > qxmin(lhl) ) THEN + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) + + qxacwtmp = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & tmp3*da1lc(mgs)*xdia(mgs,lc,3)**2 ) + ELSE + qxacwtmp = 0.0 + ENDIF + + IF ( qhlacr(mgs)*dtp > qxmin(lhl) ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) + + qxacrtmp = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & tmp3*da1lr(mgs)*xdia(mgs,lr,3)**2 ) + ELSE + qxacrtmp = 0.0 + ENDIF + + x = gaminterp(ratio,alpha(mgs,lhl),9,2) ! alpha + 1 + y = gaminterp(ratio,alpha(mgs,lhl),3,2) ! alpha + b/2 + 5/2 + + hxventtmp = 0.78*x + y*hlventy(mgs) ! & + + qxacitmp = 0.0 + IF ( qhlaci(mgs)*dtp > qxmin(lhl) ) THEN + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) + + qxacitmp = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & tmp3*da1(li)*xdia(mgs,li,3)**2 ) + + cxacitmp = & + & 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab0lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & tmp3*da0(li)*xdia(mgs,li,3)**2 ) + + ENDIF + + qxacstmp = 0.0 + IF ( qhlacs(mgs)*dtp > qxmin(lhl) ) THEN + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) + + qxacstmp = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & tmp3*da1(ls)*xdia(mgs,ls,3)**2 ) + + cxacstmp = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab0lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & tmp3*da0(ls)*xdia(mgs,ls,3)**2 ) + ENDIF + + qxwettmp = & + & xdia(mgs,lhl,1)*hxventtmp*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qxacitmp + qxacstmp) + + ! qhlacw(mgs) + qhlacr(mgs) - qxacwtmp - qxacrtmp is the 'dry' growth + ! at smaller diameters +! qhlwet(mgs) = qhlacw(mgs) + qhlacr(mgs) - qxacwtmp - qxacrtmp + qxwettmp + ! as dry growth but subtract part for D > Dw and add wet growth for D > Dw + qhlwet(mgs) = qhlacw(mgs) + qhlacr(mgs) + qhlaci(mgs) + qhlacs(mgs) & + - ehli(mgs)*qxacitmp - ehls(mgs)*qxacstmp & + - qxacwtmp - qxacrtmp + qxwettmp + + qhlaci(mgs) = qhlaci(mgs) + (1.0 - ehli(mgs))*qxacitmp + qhlacs(mgs) = qhlacs(mgs) + (1.0 - ehls(mgs))*qxacstmp + chlaci(mgs) = chlaci(mgs) + (1.0 - ehli(mgs))*cxacitmp + chlacs(mgs) = chlacs(mgs) + (1.0 - ehls(mgs))*cxacstmp + + + ! ELSE + ! qhlwet(mgs) = qhldry(mgs) + ! ENDIF + ENDIF ! incwet ENDIF - ELSE + ELSE ! ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) qhwet(mgs) = qhdry(mgs) qhlwet(mgs) = qhldry(mgs) - ENDIF + + ENDIF ! } ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) ! ! qhlwet(mgs) = qhldry(mgs) @@ -21505,6 +23737,7 @@ subroutine nssl_2mom_gs & wetsfchl(:) = .false. wetgrowthhl(:) = .false. + do mgs = 1,ngscnt ! ! @@ -21515,6 +23748,7 @@ subroutine nssl_2mom_gs & qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) + ! ! limit wet growth to only higher density particles ! @@ -21533,6 +23767,7 @@ subroutine nssl_2mom_gs & wetgrowth(mgs) = .false. wetsfchl(mgs) = .false. wetgrowthhl(mgs) = .false. + end if ! ! shed all at temperatures > 273.15 @@ -21543,24 +23778,28 @@ subroutine nssl_2mom_gs & qsshr(mgs) = -qsdry(mgs) 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) + ENDIF vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs) vhlshdr(mgs) = -vhlacw(mgs) - vhlacr(mgs) qhwet(mgs) = 0.0 qhlwet(mgs) = 0.0 + end if ! ! if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) ! ENDIF + if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) @@ -21571,6 +23810,7 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) + chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding @@ -21580,6 +23820,7 @@ subroutine nssl_2mom_gs & ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + chlshr(mgs) = 0.0 @@ -21596,14 +23837,17 @@ subroutine nssl_2mom_gs & ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + ENDIF ! ( lhl > 1 ) + end do end if + ! ! final decisions ! @@ -21625,6 +23869,7 @@ subroutine nssl_2mom_gs & ! end if ! + ! graupel ! ! @@ -21669,18 +23914,23 @@ subroutine nssl_2mom_gs & chdpv(mgs) = 0.0 ! chsbv(mgs) = 0.0 + ! collection efficiency modification IF ( ehi(mgs) .gt. 0.0 ) THEN + IF ( incwet == 0 ) THEN qhaci(mgs) = Min(qimxd(mgs),qhaci0(mgs)) ! effectively sets collection eff to 1 chaci(mgs) = Min(cimxd(mgs),chaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF ENDIF IF ( ehs(mgs) .gt. 0.0 ) THEN ! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1 + IF ( incwet == 0 ) THEN qhacs(mgs) = Min(qsmxd(mgs),qhacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency chacs(mgs) = Min(csmxd(mgs),chacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency - ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)) ! plug it back in + ENDIF + ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it ENDIF ! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop @@ -21706,6 +23956,7 @@ subroutine nssl_2mom_gs & + IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN ! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN @@ -21746,7 +23997,7 @@ subroutine nssl_2mom_gs & ! vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr) ENDIF - IF ( ehli(mgs) .gt. 0.0 ) THEN + IF ( ehli(mgs) .gt. 0.0 .and. incwet == 0 ) THEN qhlaci(mgs) = Min(qimxd(mgs),qhlaci0(mgs)) ! effectively sets collection eff to 1 chlaci(mgs) = Min(cimxd(mgs),chlaci0(mgs)) ! effectively sets collection eff to 1 ENDIF @@ -21754,7 +24005,7 @@ subroutine nssl_2mom_gs & ! IF ( ehls(mgs) .gt. 0.0 ) THEN ! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) ! ENDIF - IF ( ehls(mgs) .gt. 0.0 ) THEN + IF ( ehls(mgs) .gt. 0.0 .and. incwet == 0 ) THEN qhlacs(mgs) = Min(qsmxd(mgs),qhlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency chlacs(mgs) = Min(csmxd(mgs),chlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency ehls(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it @@ -21773,6 +24024,7 @@ subroutine nssl_2mom_gs & ! qhlwet(mgs) = 0.0 end if + end do ! ! Ice -> graupel conversion @@ -21861,6 +24113,7 @@ subroutine nssl_2mom_gs & zhcnhl(:) = 0.0 + IF ( lhl .gt. 1 ) THEN IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN @@ -21880,14 +24133,21 @@ subroutine nssl_2mom_gs & ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter ENDIF + + ! if incwet > 0, then should use dhwet here to avoid calculating again 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 + IF ( temg(mgs) .le. tfr+hailcnvtoffset .and. & + (( (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & + .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 ) + IF ( incwet > 0 ) THEN + d = dhwet(mgs) + ELSE + ! First guess for dwet (not that good, but it is something) 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 @@ -21896,7 +24156,7 @@ subroutine nssl_2mom_gs & ELSE dwr = 1.e30 ENDIF - d = dwr + d = Min(dwr, dg0thresh + 0.0001) 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) @@ -21946,28 +24206,37 @@ subroutine nssl_2mom_gs & 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 + + d = Min( d, dg0thresh + 0.0001 ) + dhwet(mgs) = d + ENDIF ! dwr < 0.2 .and. dwr > 0.0 + ENDIF ! incwet - dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) + ! dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) + dg0(mgs) = 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 + ! IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr+hailcnvtoffset ) THEN + ! dg0(mgs) = dwmax + ! ELSE dg0(mgs) = dg0thresh + 0.0001 - ENDIF + ! 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 + .and. temg(mgs) .le. tfr+hailcnvtoffset .and. temg(mgs) > 238.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 ) +! dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 ) + dg0(mgs) = Min( dg0(mgs), dwmax ) ENDIF ENDIF + wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) IF ( ihlcnh == 1 ) THEN ! .or. iusedw == 0 THEN @@ -21977,7 +24246,7 @@ subroutine nssl_2mom_gs & & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! { ! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 THEN ! 0823.2008 erm test ! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN - IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN ! { + IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr+hailcnvtoffset ) THEN ! { ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05 ! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - ! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) @@ -21991,6 +24260,7 @@ subroutine nssl_2mom_gs & ELSE dh0 = 1.e30 ENDIF + dg0(mgs) = Min(dh0, dg0thresh + 0.0001) ENDIF ! wtest ! dh0 = Max( dh0, 5.e-3 ) @@ -22001,6 +24271,7 @@ 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) + qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) IF ( ipconc .ge. 5 ) THEN !{ @@ -22024,8 +24295,9 @@ 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 + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr+hailcnvtoffset .and. qx(mgs,lh) > hlcnhqmin ) ) THEN ! convert number, mass, and reflectivity for d > dw IF ( ipconc == 5 ) THEN ! dg0(mgs) = Min( dg0(mgs), hldia1 ) @@ -22074,31 +24346,96 @@ subroutine nssl_2mom_gs & 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 + + ! tmp4 is the Z from the converted particles assuming shape of alphamax + IF ( icorrecthaildbz >= 1 .and. zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + IF ( .true. ) THEN + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + tmp3 = g1x(mgs,lhl)*(rho0(mgs)*(qx(mgs,lhl)+qxd1))**2/((pi*xdn(mgs,lhl)/6.0)**2*(zx(mgs,lhl)+zxd1) ) + chlcnhhl(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,lhl) ) + ELSE + ! old version + tmp3 = g1xmax*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lh)/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new hail number to match zxd1 + ! increase cxd1 to make z,q,c rates consistent + ! cxd1 = g1xmax*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + chlcnhhl(mgs) = dtpinv*cxd1 + ENDIF + ENDIF + ENDIF ! t/f + ELSE zxd1 = 0 ENDIF + IF ( ipconc == 5 .and. icorrecthaildbz >= 1 ) THEN ! Adjust cxd1 by reflectivity removed from graupel + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + ! tmp5 is graupel reflectivity moment + tmp5 = g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh))**2/((pi*xdn(mgs,lh)/6.)**2*cx(mgs,lh)) + zxd1 = flim*(tmp3)*tmp5 + IF ( zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + IF ( .true. ) THEN + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + IF ( cx(mgs,lhl) > cxmin ) THEN + ! hail reflectivity + tmp = g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl))**2/((pi*xdn(mgs,lhl)/6.)**2*cx(mgs,lhl)) + ELSE + tmp = 0. + ENDIF + tmp3 = g1x(mgs,lhl)*(rho0(mgs)*(qx(mgs,lhl)+qxd1))**2/((pi*xdn(mgs,lhl)/6.0)**2*(tmp+zxd1) ) + chlcnhhl(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,lhl) ) + ELSE + ! tmp4 is the reflectivity of the newly-converted graupel particles (use g1x(lh) for loss term) + ! which we want to match zxd1 to prevent spurious increase in total reflectivity + tmp3 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lh)/6.0)**2) + tmp4 = tmp3/cxd1 + + IF ( tmp4 > zxd1 ) THEN ! calculate new hail number to match zxd1 + ! cxd1 = g1x(mgs,lhl)*(rho0(mgs)*qxd1)**2/(zxd1*pi*xdn(mgs,lh)/6.0) ! trial form results in tiny hail + ! want the adjust size of the new hail so that Z is conserved, so increase number of + ! particles to make qxd1,zxd1, and C consistent. + ! want zxd1 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/(c*(pi*xdn(mgs,lh)/6.0)**2) + ! Use g1x(mgs,lh) here instead of g1x(mgs,lhl) because rzxhlh will then multiply + ! by g1x(mgs,lhl)/g1x(mgs,lh) + ! cxd1 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + chlcnhhl(mgs) = dtpinv*cxd1 ! multiplied later by rzxhlh(mgs) + + ENDIF + ENDIF ! t/f + ENDIF + 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 ! @@ -22108,7 +24445,7 @@ subroutine nssl_2mom_gs & ! 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 + IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr+hailcnvtoffset .and. qx(mgs,lh) > qxmin(lh) ) THEN ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) ! number @@ -22122,6 +24459,7 @@ subroutine nssl_2mom_gs & 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) @@ -22130,6 +24468,7 @@ subroutine nssl_2mom_gs & 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)) @@ -22137,13 +24476,14 @@ subroutine nssl_2mom_gs & ENDDO ! ENDIF + ELSEIF ( ihlcnh == 0 ) THEN do mgs = 1,ngscnt ! qhlcnh(mgs) = 0.0 ! chlcnh(mgs) = 0.0 if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then - if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then + if ( qhacw(mgs).gt.1.e-6 .and. ( xdn(mgs,lh) > 700. .or. lvh == 0 ) ) then qhlcnh(mgs) = & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & *exp(-hldia1/xdia(mgs,lh,1)) & @@ -22181,6 +24521,7 @@ subroutine nssl_2mom_gs & ENDIF ! lhl > 1 + @@ -22236,6 +24577,7 @@ subroutine nssl_2mom_gs & dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs) a3 = 1./(rho0(mgs)*qx(mgs,ls)) + a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) !! EXP(-(ROS*XNS*VGRA/(RO*QI))) ! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet @@ -22372,10 +24714,12 @@ 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) @@ -22443,6 +24787,7 @@ subroutine nssl_2mom_gs & ENDIF + ! ! ! @@ -22457,6 +24802,7 @@ subroutine nssl_2mom_gs & qhmul1(:) = 0.0 qhlmul1(:) = 0.0 qsmul1(:) = 0.0 + do mgs = 1,ngscnt ltest = qx(mgs,lh) .gt. qxmin(lh) @@ -22513,6 +24859,7 @@ subroutine nssl_2mom_gs & ! chmul1(mgs) = Min( ft*ex1*chacw(mgs), ft*(30.*1.e+06)*rho0(mgs)*qhacw(mgs) ) ! 1.e+6 converts kg to mg; Saunders & Hosseini (2001) average of about 30 crystals per mg qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs) ENDIF + IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN chlmul1(mgs) = (ft*ex1*chlacw(mgs)) @@ -22527,6 +24874,7 @@ subroutine nssl_2mom_gs & chmul1(mgs) = chmul1(mgs) + tmp qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs) ENDIF + IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs) @@ -22536,6 +24884,7 @@ subroutine nssl_2mom_gs & ENDIF ENDIF ! itype1 + ENDIF ! ft @@ -22623,6 +24972,7 @@ subroutine nssl_2mom_gs & ! qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) + IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN tmp = fimt1(mgs)*(fimta(mgs) + & @@ -22683,7 +25033,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt qracif(mgs) = qraci(mgs) - cracif(mgs) = craci(mgs) +! cracif(mgs) = craci(mgs) ! ciacrf(mgs) = ciacr(mgs) end do ! @@ -22709,15 +25059,21 @@ subroutine nssl_2mom_gs & ! ! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation ! - cmassin = cimasn ! 6.88e-13 + cmassin = cimas1 ! 6.88e-13 do mgs = 1,ngscnt qiint(mgs) = 0.0 ciint(mgs) = 0.0 + qiintv(mgs) = 0.0 + qidint(mgs) = 0.0 + cidint(mgs) = 0.0 + qiintd(mgs) = 0.0 + ciintd(mgs) = 0.0 qicicnt(mgs) = 0.0 cicint(mgs) = 0.0 qipipnt(mgs) = 0.0 cipint(mgs) = 0.0 ccitmp = 0.0 + IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN if ( ( temg(mgs) .lt. 268.15 .or. & ! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. & @@ -22738,7 +25094,9 @@ subroutine nssl_2mom_gs & & idqis*il5(mgs) & & *(cmassin/rho0(mgs)) & & *max(0.0,wvel(mgs)) & + & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) & + & /((dzfacp+dzfacm)) qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) @@ -22795,9 +25153,10 @@ subroutine nssl_2mom_gs & - ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN + ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 6 .or. icenucopt == 10 ) THEN IF ( temg(mgs) .lt. 268.15 ) THEN IF ( lcin > 1 ) THEN + ! decrement available IN ciint(mgs) = Min(cnina(mgs), ccin(mgs)) ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx ccin(mgs) = ccin(mgs) - ciint(mgs) @@ -22809,16 +25168,46 @@ subroutine nssl_2mom_gs & ENDIF ENDIF + + IF ( icenucopt == 5 .or. icenucopt == 6 ) THEN + ! dust IN freezing droplets (immersion) + IF ( temg(mgs) .lt. 268.15 ) THEN + cidint(mgs) = Max( 0.0, cninda(mgs) - cinda(mgs) )*dtpinv + qidint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ENDIF + + ENDIF + ! - if ( xplate(mgs) .eq. 1 ) then - qipipnt(mgs) = qiint(mgs) - cipint(mgs) = ciint(mgs) - end if + IF ( inactopt >= 2 ) THEN ! IN are freezing droplets (immersion); need to expand to rain +! IF ( cx(mgs,lc) > 0. ) THEN + ! check overdepletion of droplets and rescale if needed + IF ( ciint(mgs) + cidint(mgs) > cx(mgs,lc)*dtpinv ) THEN + fac = cx(mgs,lc)*dtpinv / ( ciint(mgs) + cidint(mgs) ) + ciint(mgs) = fac*ciint(mgs) + cidint(mgs) = fac*cidint(mgs) + ENDIF + ! number and mass of frozen droplets + ciintd(mgs) = ciint(mgs) + cidint(mgs) + qiintd(mgs) = ciintd(mgs)*xmas(mgs,lc)*rhoinv(mgs) +! ENDIF + ciint(mgs) = 0.0 ! set to zero because ciint is used for vapor nucleation, but can recover from ciintd - cidint + qiint(mgs) = 0.0 + ELSE + ciint(mgs) = ciint(mgs) + cidint(mgs) + qiintv(mgs) = qiint(mgs) + qidint(mgs) + ! qiint(mgs) = 0.0 + ENDIF + +! if ( xplate(mgs) .eq. 1.0 ) then + qipipnt(mgs) = xplate(mgs)*Max( qiint(mgs), qiintd(mgs) ) + cipint(mgs) = xplate(mgs)*Max( ciint(mgs), ciintd(mgs) ) +! end if ! - if ( xcolmn(mgs) .eq. 1 ) then - qicicnt(mgs) = qiint(mgs) - cicint(mgs) = ciint(mgs) - end if +! if ( xcolmn(mgs) .eq. 1.0 ) then + qicicnt(mgs) = xcolmn(mgs)*Max( qiint(mgs), qiintd(mgs) ) + cicint(mgs) = xcolmn(mgs)*Max( ciint(mgs), ciintd(mgs) ) +! end if ! ! qipipnt(mgs) = 0.0 ! qicicnt(mgs) = qiint(mgs) @@ -22868,6 +25257,7 @@ subroutine nssl_2mom_gs & qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) + IF ( ipconc .ge. 3 ) THEN ! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) @@ -22905,11 +25295,12 @@ subroutine nssl_2mom_gs & pcswd(:) = 0.0 pchwi(:) = 0.0 pchwd(:) = 0.0 + pchli(:) = 0.0 pchld(:) = 0.0 ! ENDDO ! -! Cloud ice +! Cloud ice (columns) ! ! IF ( ipconc .ge. 1 ) THEN if (ndebug .gt. 0 ) write(0,*) 'cloud ice sum' @@ -22923,6 +25314,7 @@ subroutine nssl_2mom_gs & & +cicichr(mgs)) & & +chmul1(mgs) & & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) @@ -22933,14 +25325,16 @@ subroutine nssl_2mom_gs & & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & & -craci(mgs) & & -csaci(mgs) & + & -chaci(mgs) - chlaci(mgs) & & -chcni(mgs)) & & +il5(mgs)*cisbv(mgs) & & -(1.-il5(mgs))*cimlr(mgs) - pccin(mgs) = ciint(mgs) + pccin(mgs) = Max( ciint(mgs), ciintd(mgs) ) ! rate of IN activation + end do ENDIF ! ffrzs ELSEIF ( warmonly < 0.8 ) THEN @@ -22956,6 +25350,7 @@ subroutine nssl_2mom_gs & & +cicichr(mgs)) & & +chmul1(mgs) & & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) @@ -22969,7 +25364,9 @@ subroutine nssl_2mom_gs & & +il5(mgs)*cisbv(mgs) & & -(1.-il5(mgs))*cimlr(mgs) - pccin(mgs) = ciint(mgs) + pccin(mgs) = Max( ciint(mgs), ciintd(mgs) ) ! rate of IN activation + + ! cina(mgs) = cina(mgs) + (pccin(mgs) - cidint(mgs))*dtp end do ENDIF ! warmonly @@ -22988,8 +25385,10 @@ subroutine nssl_2mom_gs & pccwd(mgs) = & & - cautn(mgs) + & & il5(mgs)*(-ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & - & -cwctfzc(mgs) & + & -cwctfzc(mgs) - ciintd(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) @@ -22998,6 +25397,7 @@ subroutine nssl_2mom_gs & & - cautn(mgs) + & & il5(mgs)*( & & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & & ) & & -cracw(mgs) -chacw(mgs) -chlacw(mgs) @@ -23024,6 +25424,7 @@ subroutine nssl_2mom_gs & IF ( .false. .and. exwmindiam > 0.0 .and. ccwresv(mgs) > 0.0 ) THEN pccwdacc(mgs) = & & il5(mgs)*(-ciacw(mgs) & + & ) & & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) @@ -23033,11 +25434,14 @@ subroutine nssl_2mom_gs & pccwdacc(mgs) = -(cx(mgs,lc) - ccwresv(mgs) )*dtpinv ciacw(mgs) = frac*ciacw(mgs) + cracw(mgs) = frac*cracw(mgs) csacw(mgs) = frac*csacw(mgs) chacw(mgs) = frac*chacw(mgs) cautn(mgs) = frac*cautn(mgs) + + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) ! resum @@ -23045,8 +25449,11 @@ subroutine nssl_2mom_gs & & - cautn(mgs) + & & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & & -cwfrzc(mgs)-cwctfzc(mgs) & - & -il5(mgs)*(ciihr(mgs)) & +! & -il5(mgs)*(ciihr(mgs)) & + & -il5(mgs)*(qiihr(mgs)/Max(cimas1,xmas(mgs,lc))) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) ENDIF @@ -23065,18 +25472,25 @@ subroutine nssl_2mom_gs & pccwd(mgs) = -cx(mgs,lc)*dtpinv ciacw(mgs) = frac*ciacw(mgs) + cwfrz(mgs) = frac*cwfrz(mgs) cwfrzp(mgs) = frac*cwfrzp(mgs) cwctfzp(mgs) = frac*cwctfzp(mgs) cwfrzc(mgs) = frac*cwfrzc(mgs) cwctfzc(mgs) = frac*cwctfzc(mgs) - cwctfz(mgs) = frac*cwctfz(mgs) + ciintd(mgs) = frac*ciintd(mgs) + cidint(mgs) = frac*cidint(mgs) + + + cwctfz(mgs) = frac*cwctfz(mgs) cracw(mgs) = frac*cracw(mgs) csacw(mgs) = frac*csacw(mgs) chacw(mgs) = frac*chacw(mgs) cautn(mgs) = frac*cautn(mgs) + - pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs) + pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs)+ciintd(mgs))*(1. - ffrzs) + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) @@ -23099,6 +25513,7 @@ subroutine nssl_2mom_gs & ! > cracw(mgs) + & & crcnw(mgs) & & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & & -chlmlrr(mgs)/rzxhl(mgs) & ! & -csmlr(mgs)/rzxs(mgs) & @@ -23109,6 +25524,7 @@ subroutine nssl_2mom_gs & pcrwd(mgs) = & & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs)) ! > -csacr(mgs) & + & - chacr(mgs) - chlacr(mgs) & & +crcev(mgs) & & - Max(0.0,cracr(mgs)) @@ -23168,6 +25584,7 @@ subroutine nssl_2mom_gs & crcev(mgs) = frac*crcev(mgs) cracr(mgs) = frac*cracr(mgs) + ! STOP ENDIF @@ -23186,6 +25603,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt pcswi(mgs) = & & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & + & + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio & & + cscnh(mgs) @@ -23196,6 +25614,7 @@ subroutine nssl_2mom_gs & & +cicichr(mgs)) & & +chmul1(mgs) & & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) ) ENDIF @@ -23207,6 +25626,7 @@ subroutine nssl_2mom_gs & pcswd(mgs) = & ! : cracs(mgs) & + & -chacs(mgs) - chlacs(mgs) & & -chcns(mgs) & & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs) @@ -23228,6 +25648,7 @@ subroutine nssl_2mom_gs & csshr(mgs) = frac*csshr(mgs) cssbv(mgs) = frac*cssbv(mgs) csacs(mgs) = frac*csacs(mgs) + ENDIF ENDIF @@ -23263,10 +25684,12 @@ subroutine nssl_2mom_gs & & - il5(mgs)*chlcnh(mgs) & & - cscnh(mgs) + end do + ! ! @@ -23275,6 +25698,7 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN ! do mgs = 1,ngscnt pchli(mgs) = (ffrzh*(1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*ffrzh*(1.0-ifiacrg)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhlh(mgs) pchld(mgs) = & @@ -23298,6 +25722,7 @@ subroutine nssl_2mom_gs & ENDIF ENDIF + end do ENDIF @@ -23325,6 +25750,7 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) THEN ! do mgs = 1,ngscnt pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs)) & ! +il5(mgs)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhl(mgs)/rzxh(mgs) pchld(mgs) = & @@ -23354,6 +25780,7 @@ subroutine nssl_2mom_gs & & pcrwi(mgs) +pcrwd(mgs) + & & pcswi(mgs) +pcswd(mgs) + & & pchwi(mgs) +pchwd(mgs) + & + & pchli(mgs) +pchld(mgs) end do ! @@ -23375,6 +25802,7 @@ subroutine nssl_2mom_gs & pqcwdacc(:) = 0.0 pqcii(:) = 0.0 pqcid(:) = 0.0 + pqrwi(:) = 0.0 pqrwd(:) = 0.0 pqswi(:) = 0.0 @@ -23393,6 +25821,7 @@ subroutine nssl_2mom_gs & pqlwlghld(:) = 0.0 pqlwhli(:) = 0.0 pqlwhld(:) = 0.0 + IF ( ipconc > 5 ) THEN pzhwi(:) = 0.0 pzhwd(:) = 0.0 @@ -23413,20 +25842,25 @@ subroutine nssl_2mom_gs & pqwvi(mgs) = & & -Min(0.0, qrcev(mgs)) & & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & & -Min(0.0, qscev(mgs)) & ! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & & -qhsbv(mgs) - qhlsbv(mgs) & & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) & & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & & -Max(0.0, qscev(mgs)) & - & +il5(mgs)*(-qiint(mgs) & + & +il5(mgs)*(-qiintv(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) end do @@ -23437,11 +25871,13 @@ subroutine nssl_2mom_gs & & -Min(0.0, qrcev(mgs)) & & -il5(mgs)*qisbv(mgs) pqwvd(mgs) = & - & +il5(mgs)*(-qiint(mgs) & + & +il5(mgs)*(-qiintv(mgs) & ! & -qhdpv(mgs) ) & !- qhldpv(mgs)) & + & -qhdpv(mgs) - qhldpv(mgs)) & ! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & & -Max(0.0, qrcev(mgs)) & + & -il5(mgs)*qidpv(mgs) end do @@ -23464,7 +25900,9 @@ subroutine nssl_2mom_gs & IF ( warmonly < 0.5 ) THEN pqcwd(mgs) = & & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & - & -il5(mgs)*(qiihr(mgs)) & + + & -il5(mgs)*(qiihr(mgs) + qiintd(mgs) ) & + & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) !& ! & -il5(mgs)*(qwfrzp(mgs)) ELSEIF ( warmonly < 0.8 ) THEN @@ -23478,21 +25916,29 @@ subroutine nssl_2mom_gs & ENDIF + IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp) pqcwd(mgs) = -qx(mgs,lc)*dtpinv qiacw(mgs) = frac*qiacw(mgs) + ! qwfrzp(mgs) = frac*qwfrzp(mgs) ! qwctfzp(mgs) = frac*qwctfzp(mgs) qwfrzc(mgs) = frac*qwfrzc(mgs) qwfrz(mgs) = frac*qwfrz(mgs) qwctfzc(mgs) = frac*qwctfzc(mgs) + IF ( inactopt >= 2 ) THEN + qiintd(mgs) = frac*qiintd(mgs) + qicicnt(mgs) = frac*qicicnt(mgs) + ENDIF + qwctfz(mgs) = frac*qwctfz(mgs) qracw(mgs) = frac*qracw(mgs) qsacw(mgs) = frac*qsacw(mgs) qhacw(mgs) = frac*qhacw(mgs) + vhacw(mgs) = frac*vhacw(mgs) qrcnw(mgs) = frac*qrcnw(mgs) qwfrzp(mgs) = frac*qwfrzp(mgs) @@ -23520,6 +25966,7 @@ subroutine nssl_2mom_gs & & +il5(mgs)*(qicichr(mgs)) & & +qsmul(mgs) & & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) ! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) ENDIF @@ -23532,6 +25979,7 @@ subroutine nssl_2mom_gs & & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & & -qraci(mgs) & & -qsaci(mgs) ) & + & -qhaci(mgs) & & -qhlaci(mgs) & & +il5(mgs)*qisbv(mgs) & @@ -23539,6 +25987,7 @@ subroutine nssl_2mom_gs & & - qhcni(mgs) end do + ELSEIF ( warmonly < 0.8 ) THEN @@ -23580,25 +26029,30 @@ subroutine nssl_2mom_gs & pqrwi(mgs) = & & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included & -qsmlr(mgs) - qhlmlr(mgs) & & -qimlr(mgs)) & ! & -qsshr(mgs) & !null at this point when wet snow/graupel included + ! & -qhshr(mgs) & !null at this point when wet snow/graupel included ! & -qhlshr(mgs) & & - qrshr(mgs) pqrwd(mgs) = & & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & + & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & & + Min(0.0,qrcev(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pqrwi(mgs) = & & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & & +(1-il5(mgs))*( & + & -qhlmlr(mgs) & !null at this point when wet snow/graupel included & -qhmlr(mgs) ) & !null at this point when wet snow/graupel included & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) !null at this point when wet snow/graupel included pqrwd(mgs) = & & il5(mgs)*(-qrfrz(mgs)) & @@ -23639,6 +26093,7 @@ subroutine nssl_2mom_gs & qrcev(mgs) = frac*qrcev(mgs) qhlacr(mgs) = frac*qhlacr(mgs) vhlacr(mgs) = frac*vhlacr(mgs) + qhcev(mgs) = frac*qhcev(mgs) qhlcev(mgs) = frac*qhlcev(mgs) @@ -23647,10 +26102,12 @@ subroutine nssl_2mom_gs & pqrwd(mgs) = & & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) & & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pqrwd(mgs) = & & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & & - qhlacr(mgs) & & + Min(0.0,qrcev(mgs)) @@ -23668,8 +26125,10 @@ subroutine nssl_2mom_gs & & -Min(0.0, qhlcev(mgs)) & & -Min(0.0, qscev(mgs)) & ! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) pqwvd(mgs) = & @@ -23677,8 +26136,10 @@ subroutine nssl_2mom_gs & & -Max(0.0, qhcev(mgs)) & & -Max(0.0, qhlcev(mgs)) & & -Max(0.0, qscev(mgs)) & - & +il5(mgs)*(-qiint(mgs) & + & +il5(mgs)*(-qiintv(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) ENDIF @@ -23688,6 +26149,7 @@ subroutine nssl_2mom_gs & ENDIF + end do IF ( warmonly < 0.5 ) THEN @@ -23702,6 +26164,7 @@ subroutine nssl_2mom_gs & & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) & & + il5(mgs)*(( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs & & + (1.0 - ffrzs)*cwfrz2snowfrac*qwfrz(mgs) ) & + & + il2(mgs)*qsacr(mgs)) & & + il5(mgs)*qicicnt(mgs)*ffrzs & & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & ! only applies for ipconc <= 3 @@ -23713,6 +26176,7 @@ subroutine nssl_2mom_gs & pqswd(mgs) = & ! > -qfacs(mgs) ! -qwacs(mgs) & & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) & + & -qhcns(mgs) & & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included ! > +il5(mgs)*(qssbv(mgs)) & @@ -23735,6 +26199,7 @@ subroutine nssl_2mom_gs & qsshr(mgs) = frac*qsshr(mgs) qssbv(mgs) = frac*qssbv(mgs) qsmul(mgs) = frac*qsmul(mgs) + IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs) ENDIF @@ -23757,6 +26222,7 @@ subroutine nssl_2mom_gs & & +Max(0.0, qhcev(mgs)) & & +qhacr(mgs)+qhacw(mgs) & & +qhacs(mgs)+qhaci(mgs) & + & + f2h*qhcns(mgs) + f2h*qhcni(mgs) + qhcnhl(mgs) pqhwd(mgs) = & & qhshr(mgs) & !null at this point when wet graupel included @@ -23768,9 +26234,11 @@ subroutine nssl_2mom_gs & & - ffrzh*(qsplinter(mgs) + qsplinter2(mgs)) ! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + end do + ! ! Hail ! @@ -23782,6 +26250,7 @@ subroutine nssl_2mom_gs & & +Max(0.0, qhlcev(mgs)) & & +qhlacr(mgs)+qhlacw(mgs) & & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) pqhld(mgs) = & & qhlshr(mgs) & @@ -23842,6 +26311,7 @@ subroutine nssl_2mom_gs & & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & & +qhlacr(mgs)+qhlacw(mgs) & ! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) pqhld(mgs) = & & qhlshr(mgs) & @@ -23865,7 +26335,9 @@ subroutine nssl_2mom_gs & vhfzh(:) = 0.0 vhlfzhl(:) = 0.0 + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel ! vhshdr(:) = 0.0 @@ -23877,10 +26349,13 @@ subroutine nssl_2mom_gs & ! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) ! vhlsoak(:) = 0.0 + ENDIF ! mixedphase + + ! ! Graupel reflectivity ! @@ -23895,6 +26370,8 @@ subroutine nssl_2mom_gs & zhdsv(mgs) = 0.0 ! IF ( lf < 1 ) THEN IF ( ffrzh > 0.0 ) THEN + ! only initialize if frozen drops are turned off, otherwise is already set above + ! If ffrzh = 0, then ziacrf is zeroed out for graupel and can leave value set for diagnostics ziacr(mgs) = 0.0 ziacrf(mgs) = 0.0 ENDIF @@ -23921,10 +26398,15 @@ subroutine nssl_2mom_gs & 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) ) + zhmlr(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),xdn(mgs,lh),qx(mgs,lh), & + cx(mgs,lh),chmlr(mgs),qhmlr(mgs),1) + ! 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) ) + ! combined with zhacr + zhshr(mgs) = 0.0 !zrateqn(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),xdn(mgs,lh),qx(mgs,lh), & + ! cx(mgs,lh),chshr(mgs),qhshr(mgs)) +! 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 @@ -23959,14 +26441,6 @@ subroutine nssl_2mom_gs & 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) ) @@ -23986,17 +26460,13 @@ subroutine nssl_2mom_gs & ! 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) ) + qtmp = qhacr(mgs) + qhacw(mgs) + qhshr(mgs) - qhmul1(mgs) + ctmp = chshr(mgs) + zhacr(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),xdn(mgs,lh),qx(mgs,lh), & + cx(mgs,lh),ctmp,qtmp,1) +! 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) ) @@ -24007,28 +26477,28 @@ subroutine nssl_2mom_gs & ! : ((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 + ! combined with zracr + zhacw(mgs) = 0.0 !zrateq(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),xdn(mgs,lh),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) ) 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 +! 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) ) + zhlcnh(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),xdn(mgs,lh),qx(mgs,lh), & + cx(mgs,lh),chlcnh(mgs),qhlcnh(mgs),1) + ! zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) ) ENDIF ENDIF ! qsplinter(mgs) @@ -24041,12 +26511,17 @@ subroutine nssl_2mom_gs & 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) ) + ziacr(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lr),rho0(mgs),xdn0(lr),qx(mgs,lr), & + cx(mgs,lr),ciacr(mgs),qiacr(mgs),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) +! ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs) + ziacrf(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),rhofrz,qx(mgs,lh), & + cx(mgs,lh),ciacrf(mgs),qiacrf(mgs),1) + ! 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 @@ -24088,24 +26563,28 @@ subroutine nssl_2mom_gs & 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) ) + & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcnsh(mgs) ) + ELSE write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow - STOP + + ! STOP + ENDIF ENDIF - IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN + IF ( qhcni(mgs) > 0.0 .and. chcnih(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) ) + & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcnih(mgs) ) + ENDIF pzhwi(mgs) = & & +ifrzg*ffrzh*(zrfrzf(mgs) & - & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) & + & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) & ! ffrzh turns this off if FD are turned on ! : + zhcnsh(mgs) + zhcnih(mgs) & & + zhacw(mgs) & & + zhacr(mgs) & @@ -24122,14 +26601,6 @@ subroutine nssl_2mom_gs & & - 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 @@ -24168,10 +26639,12 @@ subroutine nssl_2mom_gs & 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) ) + zhlmlr(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lhl),rho0(mgs),xdn(mgs,lhl),qx(mgs,lhl), & + cx(mgs,lhl),chlmlr(mgs),qhlmlr(mgs),1) +! 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) ) + ! combine zhlshr into zhlacr below + zhlshr(mgs) = 0.0 ! 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) ) @@ -24193,14 +26666,7 @@ subroutine nssl_2mom_gs & 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) ) @@ -24217,7 +26683,11 @@ subroutine nssl_2mom_gs & 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) ) + qtmp = qhlacr(mgs) + qhlacw(mgs) + qhlshr(mgs) - qhlmul1(mgs) + ctmp = chlshr(mgs) + zhlacr(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lhl),rho0(mgs),xdn(mgs,lhl),qx(mgs,lhl), & + cx(mgs,lhl),ctmp,qtmp,1) +! 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 @@ -24230,29 +26700,29 @@ subroutine nssl_2mom_gs & ! 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 +! 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 +! 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 ! } @@ -24263,6 +26733,7 @@ subroutine nssl_2mom_gs & 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) & @@ -24301,7 +26772,7 @@ subroutine nssl_2mom_gs & DO mgs = 1,ngscnt zracw(mgs) = 0.0 - zracr(mgs) = 0.0 + ! zracr(mgs) = 0.0 ! already set to zero zrcev(mgs) = 0.0 zrach(mgs) = 0.0 zrachl(mgs) = 0.0 @@ -24310,6 +26781,7 @@ subroutine nssl_2mom_gs & ! 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) @@ -24356,6 +26828,7 @@ subroutine nssl_2mom_gs & ! 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 * & @@ -24391,9 +26864,14 @@ subroutine nssl_2mom_gs & 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 +! zracr is already done in breakup section +! IF ( ibincracr /= 2 .and. 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) ) + ! rewrite because original can overestimate zracr if -cracr*dtp is on the order of cx (i.e., + ! large increase in the number of drops, which violates differential assumption +! zracr(mgs) = dtpinv*g1x(mgs,lr)*(6.*rho0(mgs)*qx(mgs,lr)/(pi*1000.))**2 & +! * ( cracr(mgs) )/((cx(mgs,lr) - dtp*cracr(mgs))*(cx(mgs,lr))) +! ENDIF qtmp = qrcev(mgs) ctmp = crcev(mgs) @@ -24430,27 +26908,31 @@ subroutine nssl_2mom_gs & ENDIF + ENDIF - pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) & + pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + Max(0.0,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) - pzrwd(mgs) = 0.0 & + pzrwd(mgs) = Min(0.0,zracr(mgs)) & & + Min(0.,zrcev(mgs) ) & & - zrach(mgs) & & - zrachl(mgs) & + & - zrfrz(mgs) & & - il5(mgs)*(ziacr(mgs) ) + 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) @@ -24462,6 +26944,7 @@ subroutine nssl_2mom_gs & + ! ! Snow volume ! @@ -24535,7 +27018,9 @@ 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 + + IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) .and. & + vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) > rho0(mgs)*qxmin(lh)/900. ) THEN ! Calculate change in reflectivity due to density changes xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ & @@ -24562,6 +27047,7 @@ subroutine nssl_2mom_gs & ENDIF + IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN write(iunit,*) @@ -24633,6 +27119,7 @@ subroutine nssl_2mom_gs & ! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & ! changed to 500 instead of min graupel density to keep hail density from dropping too much & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & + & + vhlcnhl(mgs) + ((1.0-ifiacrg)*ffrzh*viacrf(mgs) + (1.0-ifrzg)*ffrzh*vrfrzf(mgs)) & & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) @@ -24644,7 +27131,9 @@ 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 + + IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) .and. & + vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) > rho0(mgs)*qxmin(lhl)/900. ) THEN ! Calculate change in reflectivity due to density changes xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ & @@ -24671,13 +27160,17 @@ subroutine nssl_2mom_gs & ENDIF + ENDDO ENDIF ENDIF + + if ( ndebug .ge. 1 ) then + do mgs = 1,ngscnt ! ptotal(mgs) = 0. @@ -24688,10 +27181,13 @@ subroutine nssl_2mom_gs & & + pqrwi(mgs) + pqrwd(mgs) & & + pqswi(mgs) + pqswd(mgs) & & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) ! + + ENDDO @@ -24725,7 +27221,7 @@ subroutine nssl_2mom_gs & write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) - write(iunit,*) 'temcg = ', temcg(mgs) + write(iunit,*) 'temcg, w = ', temcg(mgs),wvel(mgs) write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs) write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs) @@ -24734,12 +27230,14 @@ subroutine nssl_2mom_gs & write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs) write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs) write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs) + tmp = pqwvi(mgs) + pqwvd(mgs) & & + pqcwi(mgs) + pqcwd(mgs) & & + pqcii(mgs) + pqcid(mgs) & & + pqrwi(mgs) + pqrwd(mgs) & & + pqswi(mgs) + pqswd(mgs) & & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) write(iunit,*) 'total = ',tmp @@ -24761,12 +27259,13 @@ subroutine nssl_2mom_gs & write(iunit,*) -Max(0.0,qhcev(mgs)) write(iunit,*) -Max(0.0,qhlcev(mgs)) write(iunit,*) -Max(0.0,qscev(mgs)) - write(iunit,*) -il5(mgs)*qiint(mgs) + write(iunit,*) -il5(mgs)*qiintv(mgs) write(iunit,*) -il5(mgs)*qhdpv(mgs) write(iunit,*) -il5(mgs)*qhldpv(mgs) write(iunit,*) -il5(mgs)*qsdpv(mgs) write(iunit,*) -il5(mgs)*qidpv(mgs) write(iunit,*) 'pqwvd = ', pqwvd(mgs) + ! write(iunit,*) write(iunit,*) 'Cloud ice' @@ -24774,7 +27273,7 @@ subroutine nssl_2mom_gs & write(iunit,*) il5(mgs)*qicicnt(mgs) write(iunit,*) il5(mgs)*qidpv(mgs) write(iunit,*) il5(mgs)*qiacw(mgs) - write(iunit,*) il5(mgs)*qwfrzc(mgs) + write(iunit,*) il5(mgs)*qwfrzc(mgs), qiintd(mgs) write(iunit,*) il5(mgs)*qwctfzc(mgs) write(iunit,*) il5(mgs)*qicichr(mgs) write(iunit,*) qhmul1(mgs) @@ -24796,10 +27295,12 @@ subroutine nssl_2mom_gs & write(iunit,*) cwfrzc(mgs),cwctfzc(mgs) write(iunit,*) cicichr(mgs) write(iunit,*) chmul1(mgs) + write(iunit,*) chlmul1(mgs) write(iunit,*) csmul(mgs) ! ! + ! ! write(iunit,*) @@ -24807,8 +27308,9 @@ subroutine nssl_2mom_gs & ! write(iunit,*) 'pqcwi =', pqcwi(mgs) write(iunit,*) -il5(mgs)*qiacw(mgs) - write(iunit,*) -il5(mgs)*qwfrzc(mgs) + write(iunit,*) -il5(mgs)*qwfrz(mgs), qiintd(mgs) write(iunit,*) -il5(mgs)*qwctfzc(mgs) + ! write(iunit,*) -il5(mgs)*qwfrzp(mgs) ! write(iunit,*) -il5(mgs)*qwctfzp(mgs) write(iunit,*) -il5(mgs)*qiihr(mgs) @@ -24819,6 +27321,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -qrcnw(mgs) write(iunit,*) -qhacw(mgs) write(iunit,*) -qhlacw(mgs) + write(iunit,*) 'pqcwd = ', pqcwd(mgs) @@ -24828,6 +27331,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -cracw(mgs) write(iunit,*) -csacw(mgs) write(iunit,*) -chacw(mgs) + write(iunit,*) -ciacw(mgs) write(iunit,*) -cwfrzp(mgs) write(iunit,*) -cwctfzp(mgs) @@ -24857,6 +27361,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -qhlacr(mgs) write(iunit,*) qrcev(mgs) write(iunit,*) 'pqrwd = ', pqrwd(mgs) + write(iunit,*) 'qrzfac = ', qrzfac(mgs) ! @@ -24881,12 +27386,18 @@ subroutine nssl_2mom_gs & ! write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) write(iunit,*) il5(mgs)*qsaci(mgs) - write(iunit,*) il5(mgs)*qrfrzs(mgs) + write(iunit,*) il5(mgs)*qrfrzs(mgs), qiacrs(mgs) write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs) write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) - write(iunit,*) qsacw(mgs) + write(iunit,*) qsacw(mgs),qwfrzc(mgs), qwctfzc(mgs), qicichr(mgs) write(iunit,*) qsacr(mgs), qscnh(mgs) - write(iunit,*) 'pqswi = ',pqswi(mgs) + + write(iunit,*) il2(mgs)*qsacr(mgs) + write(iunit,*) il5(mgs)*qicicnt(mgs)*ffrzs + write(iunit,*) il3(mgs)*(qiacrf(mgs)+qracif(mgs)) ! only applies for ipconc <= 3 + write(iunit,*) Max(0.0, qscev(mgs)) + write(iunit,*) qsacw(mgs) + qscnh(mgs) + write(iunit,*) 'pqswi = ',pqswi(mgs) write(iunit,*) -qhcns(mgs) write(iunit,*) -qracs(mgs) write(iunit,*) -qhacs(mgs) @@ -24931,6 +27442,7 @@ subroutine nssl_2mom_gs & write(iunit,*) chcns(mgs) write(iunit,*) ciacrf(mgs) + ! write(iunit,*) write(iunit,*) 'Hail' @@ -24962,6 +27474,7 @@ subroutine nssl_2mom_gs & end do ! + end if ! ( nstep/12*12 .eq. nstep ) ! @@ -24972,31 +27485,38 @@ subroutine nssl_2mom_gs & pfrz(mgs) = & & (1-il5(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) ) & + & +il5(mgs)*qrfrzfrac(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)) ! 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) & - & +il5(mgs)*(qiint(mgs)) + + & +il5(mgs)*(qiintv(mgs)) pvap(mgs) = & & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + qfcev(mgs) pevap(mgs) = & @@ -25006,9 +27526,11 @@ subroutine nssl_2mom_gs & pdep(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & & + qidpv(mgs) ) & - & +il5(mgs)*(qiint(mgs)) + + & +il5(mgs)*(qiintv(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pfrz(mgs) = & & (1-il5(mgs))* & @@ -25024,6 +27546,7 @@ subroutine nssl_2mom_gs & & +qhacr(mgs) + qhlacr(mgs) ) psub(mgs) = 0.0 + & & il5(mgs)*( & + & + qsdpv(mgs) & & + qhdpv(mgs) & & + qhldpv(mgs) & & + qidpv(mgs) + qisbv(mgs) ) & @@ -25052,6 +27575,7 @@ subroutine nssl_2mom_gs & + ! ! sum the sources and sinks for qwvp, qcw, qci, qrw, qsw ! @@ -25059,25 +27583,30 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt + qwvp(mgs) = qwvp(mgs) + & & dtp*(pqwvi(mgs)+pqwvd(mgs)) + ! qcwresv(mgs) = qx(mgs,lc) ! temporary save of old qc value qx(mgs,lc) = qx(mgs,lc) + & & dtp*(pqcwi(mgs)+pqcwd(mgs)) qx(mgs,lr) = qx(mgs,lr) + & & dtp*(pqrwi(mgs)+pqrwd(mgs)) qx(mgs,li) = qx(mgs,li) + & & dtp*(pqcii(mgs)+pqcid(mgs)) + qx(mgs,ls) = qx(mgs,ls) + & & 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)) ENDIF + end do ! sum sources for particle volume @@ -25097,6 +27626,7 @@ subroutine nssl_2mom_gs & ! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) ENDIF + IF ( lhl .gt. 1 ) THEN IF ( lvol(lhl) .gt. 1 ) THEN vx(mgs,lhl) = vx(mgs,lhl) + & @@ -25118,10 +27648,13 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt cx(mgs,li) = cx(mgs,li) + & & dtp*(pccii(mgs)+pccid(mgs)) - cina(mgs) = cina(mgs) + pccin(mgs)*dtp + cina(mgs) = cina(mgs) + (pccin(mgs) - cidint(mgs))*dtp + cinda(mgs) = cinda(mgs) + cidint(mgs)*dtp + IF ( ipconc .ge. 2 ) THEN cx(mgs,lc) = cx(mgs,lc) + & & dtp*(pccwi(mgs)+pccwd(mgs)) + ENDIF IF ( ipconc .ge. 3 ) THEN cx(mgs,lr) = cx(mgs,lr) + & @@ -25134,15 +27667,18 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 5 ) THEN cx(mgs,lh) = cx(mgs,lh) + & & dtp*(pchwi(mgs)+pchwd(mgs)) + IF ( lhl .gt. 1 ) THEN cx(mgs,lhl) = cx(mgs,lhl) + & & dtp*(pchli(mgs)+pchld(mgs)) + ENDIF ENDIF + IF ( ipconc .ge. 6 ) THEN IF ( lzr .gt. 1 ) THEN zx(mgs,lr) = zx(mgs,lr) + & @@ -25156,17 +27692,17 @@ subroutine nssl_2mom_gs & 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 + ! ! ! @@ -25223,6 +27759,7 @@ subroutine nssl_2mom_gs & end if end do + ! ! @@ -25311,7 +27848,9 @@ subroutine nssl_2mom_gs & ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp ELSE cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn & + & /gz(igs(mgs),jgs,kgs(mgs)) + cx(mgs,lc) = cwccn ENDIF @@ -25358,11 +27897,11 @@ subroutine nssl_2mom_gs & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) -! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN @@ -25407,11 +27946,11 @@ subroutine nssl_2mom_gs & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) -! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) qss(mgs) = qvs(mgs) @@ -25574,11 +28113,12 @@ subroutine nssl_2mom_gs & tqvcon = temg(mgs)-cbw ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) -! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) @@ -25629,18 +28169,24 @@ subroutine nssl_2mom_gs & ! ! end of saturation adjustment + ! ! + ! !DIR$ IVDEP + do mgs = 1,ngscnt t0(igs(mgs),jy,kgs(mgs)) = temg(mgs) end do ! ! Load the save arrays ! + IF ( numproc > 1 ) THEN DO mgs = 1,ngscnt + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + IF ( ipconc > 2 ) THEN thproc(kzbeg-1+kgs(mgs),1) = thproc(kzbeg-1+kgs(mgs),1) + crfrzf(mgs)*dtp*dv ELSE @@ -25662,6 +28208,7 @@ subroutine nssl_2mom_gs & thproc(kzbeg-1+kgs(mgs),10) = thproc(kzbeg-1+kgs(mgs),10) + & & ( chmul1(mgs) + chlmul1(mgs) )*dtp*dv IF ( lf > 1 ) THEN + ELSE thproc(kzbeg-1+kgs(mgs),11) = thproc(kzbeg-1+kgs(mgs),11) + & & ( csplinter(mgs) + csplinter2(mgs) )*dtp*dv @@ -25700,25 +28247,29 @@ subroutine nssl_2mom_gs & thproc(kzbeg-1+kgs(mgs),32) = thproc(kzbeg-1+kgs(mgs),32) + qhlcnh(mgs)*rho0(mgs)*dtp*dv ! graupel mass conversion to hail IF ( ihrn > 0 ) THEN - thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + ciihr(mgs)*dtp*dv ! contact freezing of droplets + thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + ciihr(mgs)*dtp*dv ! Ferrier94 Hobbs-Ragno mulitplication process ELSE IF ( qwctfz(mgs)*dtp >= qxmin(li) ) THEN thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + cwctfz(mgs)*dtp*dv ! contact freezing of droplets ENDIF ENDIF thproc(kzbeg-1+kgs(mgs),34) = thproc(kzbeg-1+kgs(mgs),34) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate - IF ( qiint(mgs)*dtp >= qxmin(li) ) THEN - thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + ciint(mgs)*dtp*dv ! primary ice initiation - ENDIF + ! IF ( qiint(mgs)*dtp >= qxmin(li) ) THEN + thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + (ciintd(mgs)+ciint(mgs))*dtp*dv ! primary ice initiation + ! ENDIF IF ( lf > 1 ) THEN + ELSE thproc(kzbeg-1+kgs(mgs),38) = thproc(kzbeg-1+kgs(mgs),38) + (vhacw(mgs)+vhacr(mgs)+vhshdr(mgs))*dtp*dv ENDIF IF ( lhl > 1 ) THEN thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + chlcnhhl(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),37) = thproc(kzbeg-1+kgs(mgs),37) + (vhlacw(mgs)+vhlacr(mgs)+vhlshdr(mgs))*dtp*dv + ELSE IF ( lf > 1 ) THEN + ELSE thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + (pchwi(mgs))*dtp*dv thproc(kzbeg-1+kgs(mgs),39) = thproc(kzbeg-1+kgs(mgs),39) + (pchwd(mgs))*dtp*dv @@ -25728,10 +28279,13 @@ subroutine nssl_2mom_gs & ! IF ( numproc >= 44 ) THEN thproc(kzbeg-1+kgs(mgs),42) = thproc(kzbeg-1+kgs(mgs),42) - qhshr(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),43) = 0.0 + thproc(kzbeg-1+kgs(mgs),44) = thproc(kzbeg-1+kgs(mgs),44) - qhlshr(mgs)*dtp*dv ! ENDIF + ! thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate @@ -25746,11 +28300,14 @@ subroutine nssl_2mom_gs & ENDIF + + ! Sample code for using the axtra array to load microphysical rates or quantities for output ! ! Note that indices 1 and 2 are used in the nucond subroutine for condensation/evap of droplets (1) and ! condensation of rain (2) ! + ! IF ( io_flag .and. nxtra > 1 ) THEN ! DO mgs = 1,ngscnt ! axtra(igs(mgs),jy,kgs(mgs),3) = pfrz(mgs) ! @@ -25763,6 +28320,9 @@ subroutine nssl_2mom_gs & + + + if (ndebug .gt. 0 ) write(0,*) 'gs 11' do mgs = 1,ngscnt @@ -25792,6 +28352,13 @@ subroutine nssl_2mom_gs & an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs) ENDIF + IF ( lcinda > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lcinda) = cinda(mgs) + ENDIF + + + + @@ -25816,6 +28383,7 @@ subroutine nssl_2mom_gs & ENDDO ENDIF + ! end do ! @@ -25850,7 +28418,8 @@ subroutine nssl_2mom_gs & ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. & - & (il == ls .and. imusnow == 3 ) ) THEN + & (il == ls .and. imusnow == 3 ) .or. ( il >= lh .and. lh > 0 ) ) THEN +! IF ( imaxdiaopt == 1 .or. (il == lr .and. imurain == 3) .or. .not. (il == lr .and. imurain == 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)))) @@ -25880,6 +28449,7 @@ 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 @@ -26071,6 +28641,7 @@ subroutine nssl_2mom_gs & + 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) @@ -26104,6 +28675,7 @@ subroutine nssl_2mom_gs & ENDIF !} + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN zx(mgs,il) = 0.0 cx(mgs,il) = 0.0 @@ -26123,6 +28695,7 @@ subroutine nssl_2mom_gs & 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 !{ @@ -26135,6 +28708,7 @@ subroutine nssl_2mom_gs & 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))/ & @@ -26174,8 +28748,8 @@ subroutine nssl_2mom_gs & qr = qx(mgs,il) z = zx(mgs,il) - IF ( zx(mgs,il) .gt. 0. ) THEN !{ - + IF ( zx(mgs,il) .gt. zxmin .and. qr > qxmin(il) .and. chw > cxmin ) 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) @@ -26287,9 +28861,11 @@ subroutine nssl_2mom_gs & ENDIF ! !} + ENDIF !} + IF ( lzr > 1 ) THEN alpha2d(igs(mgs),kgs(mgs),1) = Max(alphamin, Min(alphamax, alpha(mgs,lr) )) ENDIF @@ -26300,6 +28876,7 @@ subroutine nssl_2mom_gs & 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) @@ -26310,6 +28887,7 @@ subroutine nssl_2mom_gs & 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) @@ -26329,6 +28907,7 @@ subroutine nssl_2mom_gs & ENDIF ! } } + ENDIF ! }} ENDIF ! } @@ -26346,6 +28925,7 @@ subroutine nssl_2mom_gs & ! an(igs(mgs),jy,kgs(mgs),lnhlf) = Min( cx(mgs,lhl), Max( chxf(mgs,lhl), 0.0) ) an(igs(mgs),jy,kgs(mgs),lnhlf) = Max( chxf(mgs,lhl), 0.0) ENDIF + ENDIF an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) ENDDO @@ -26367,6 +28947,7 @@ subroutine nssl_2mom_gs & IF ( lccn > 1 ) THEN an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) ENDIF + end do ENDIF @@ -26404,6 +28985,7 @@ subroutine nssl_2mom_gs & + if (ndebug .gt. 0 ) write(0,*) 'gs 13' 9998 continue @@ -26438,6 +29020,97 @@ end subroutine nssl_2mom_gs !-------------------------------------------------------------------------- ! + real function galpha(a_in) + implicit none + real :: a_in + galpha = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in)) + end function galpha +! +!-------------------------------------------------------------------------- +! + + real function dgalpha(a_in) + real :: a_in + dgalpha = (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) + end function dgalpha +! +!-------------------------------------------------------------------------- +! +! Calculate reflectivity change when only number changes +! Differential version can have large error when crate is big and time step is big + real function zraten(dtpinv,dtp,g1x,rho0,xdn,qx,cx,crate) + implicit none + real, intent(in) :: dtpinv,dtp,g1x,rho0,qx,cx,crate,xdn + real, parameter :: pi = 3.141592653589793 + real :: tmp1 + + IF ( cx > 1.e-8 ) THEN + IF ( cx + dtp*crate > 1.e-8 ) THEN + zraten = (6./pi)**2*dtpinv*g1x*(rho0*qx/xdn)**2 & + * crate /((cx + dtp*crate)*cx) + ELSE + ! differential form + tmp1 = qx/cx + zraten = (6./pi)**2*g1x*(rho0/xdn)**2*( - tmp1**2 * crate ) + ENDIF + ELSE + zraten = 0.0 + ENDIF + + end function zraten +! +!-------------------------------------------------------------------------- +! +! Calculate reflectivity change when only mass changes + real function zrateq(dtpinv,dtp,g1x,rho0,xdn,qx,cx,qrate) + implicit none + real, intent(in) :: dtpinv,dtp,g1x,rho0,qx,cx,qrate,xdn + real :: tmp1,tmp2 + real, parameter :: pi = 3.141592653589793 + + IF ( cx > 1.e-8 ) THEN + tmp1 = qx**2 + tmp2 = (qx+dtp*qrate)**2 + zrateq = (6./pi)**2*dtpinv*g1x*(rho0/xdn)**2*(tmp2 - tmp1)/cx + ELSE + zrateq = 0.0 + ENDIF + + end function zrateq +! +!-------------------------------------------------------------------------- +! +! Calculate reflectivity change when both mass and number change + real function zrateqn(dtpinv,dtp,g1x,rho0,xdn,qx,cx,crate,qrate,ioldnew) + implicit none + real, intent(in) :: dtpinv,dtp,g1x,rho0,qx,cx,crate,xdn,qrate + integer, intent(in) :: ioldnew + real :: tmp1,tmp2 + real, parameter :: pi = 3.141592653589793 + + IF ( cx > 1.e-8 ) THEN + IF ( ioldnew == 1 .and. cx + dtp*crate > 1.e-8 .and. qx+dtp*qrate > 0. ) THEN + ! final-initial + tmp1 = qx**2/cx + tmp2 = (qx+dtp*qrate)**2/(cx + dtp*crate) + zrateqn = (6./pi)**2*dtpinv*g1x*(rho0/xdn)**2*(tmp2 - tmp1) + ELSE + ! differential form + tmp1 = qx/cx + zrateqn = (6./pi)**2*g1x*(rho0/xdn)**2*( 2.*tmp1*qrate - tmp1**2 * crate ) + ENDIF + ELSE + zrateqn = 0.0 + ENDIF + + end function zrateqn +! +!-------------------------------------------------------------------------- +! + + + ! @@ -26446,3 +29119,4 @@ end subroutine nssl_2mom_gs END MODULE module_mp_nssl_2mom + diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 1e7103c..8ef032e 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -393,7 +393,7 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err bcn = 2. ! mean size for soft lambda_r limiter [microns] - dbrk = 3000.e-6 ! 600.0e-6 Mod by DTD + dbrk = 600.e-6 ! ratio of rain number produced to ice number loss from melting ! Note: this is not needed with the prognostic qi,liq nmltratio = 1. @@ -2774,7 +2774,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !is used as a proxy for winter/summer log_hmossopOn = t(i,kbot).lt.278. else - log_hmossopOn = .true. ! .true. (DTD turned off for testing) + log_hmossopOn = .true. endif if (debug_on) then @@ -12221,7 +12221,7 @@ subroutine find_lookupTable_indices_1b(dumj,dum3,rcollsize,qr,nr) ! find index for scaled mean rain size ! if no rain, then just choose dumj = 1 and do not calculate rain-ice collection processes ! DTD: should we change to nsmall instead of 0? - if (qr.ge.qsmall .and. nr.gt.nsmall) then ! DTD changed from 0 to nsmall + if (qr.ge.qsmall .and. nr.gt.0) then ! calculate scaled mean size for consistency with ice lookup table dumlr = (qr/(pi*rhow*nr))**thrd dum3 = (alog10(1.*dumlr)+5.)*10.70415 diff --git a/src/mp_driver.F b/src/mp_driver.F index 904b85d..6aa12c5 100644 --- a/src/mp_driver.F +++ b/src/mp_driver.F @@ -15,7 +15,7 @@ MODULE mp_driver_module subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & - mh,rmh,c1,c2,zh,mf,rmf,zf,rain,prate,pi0,th0,rho0,prs0,qv0, & + mh,rmh,c1,c2,zh,mf,rmf,zf,rain,hail,prate,pi0,th0,rho0,prs0,qv0, & rho,prs,dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8, & w3d,ppi,pp3d,ppten,sten,tha,th3d,thten,qa,q3d,qten, & p3a,p3o,dum2d1,dum2d2,dum2d3,dum2d4,dum2d5, & @@ -49,7 +49,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & real, intent(in), dimension(jb:je+1) :: yf,rvf real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: mh,rmh,c1,c2,zh real, intent(in), dimension(ib:ie,jb:je,kb:ke+1) :: mf,rmf,zf - real, intent(inout), dimension(ib:ie,jb:je,nrain) :: rain + real, intent(inout), dimension(ib:ie,jb:je,nrain) :: rain,hail real, intent(inout), dimension(ib:ie,jb:je) :: prate real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: pi0,th0,rho0,prs0,qv0 real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: rho,prs @@ -800,8 +800,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & cci = q3d(ib,jb,kb, lni), & csw = q3d(ib,jb,kb, lns), & chw = q3d(ib,jb,kb, lnh), & - zrw = q3d(ib,jb,kb, lzr), & - zhw = q3d(ib,jb,kb, lzh), & + zrw = q3d(ib,jb,kb, max(1,lzr)), & + zhw = q3d(ib,jb,kb, max(1,lzh)), & vhw = q3d(ib,jb,kb, lvh), & pii = dum1, & p = prs, & @@ -811,6 +811,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & dtp = dt, & itimestep = nstep, & RAIN = rain, & + hail = hail, & nrain = nrain, & prate = prate, & dbz = qdiag(ibdq,jbdq,kbdq,qd_dbz), & @@ -848,9 +849,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & csw = q3d(ib,jb,kb, lns), & chw = q3d(ib,jb,kb, lnh), & chl = q3d(ib,jb,kb, lnhl), & - zrw = q3d(ib,jb,kb, lzr), & - zhw = q3d(ib,jb,kb, lzh), & - zhl = q3d(ib,jb,kb, lzhl), & + zrw = q3d(ib,jb,kb, max(1,lzr)), & + zhw = q3d(ib,jb,kb, max(1,lzh)), & + zhl = q3d(ib,jb,kb, max(1,lzhl)), & vhw = q3d(ib,jb,kb, lvh), & vhl = q3d(ib,jb,kb, lvhl), & pii = dum1, & @@ -861,6 +862,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & dtp = dt, & itimestep = nstep, & RAIN = rain, & + hail = hail, & nrain = nrain, & prate = prate, & dbz = qdiag(ibdq,jbdq,kbdq,qd_dbz), & @@ -896,6 +898,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & dtp = dt, & itimestep = nstep, & RAIN = rain, & + hail = hail, & nrain = nrain, & prate = prate, & dbz = qdiag(ibdq,jbdq,kbdq,qd_dbz), & @@ -981,10 +984,11 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ELSEIF (ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.53 .or.ptype.eq.60) THEN ! for 1-ice-category configurations - ! ERM added this, I think - DO i = 1,numq - call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) - ENDDO + ! ERM added this, I think. If it is needed, probably should put it at front + ! of every p3 call. For now, commenting out. + ! DO i = 1,numq + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO ! ERM end rdt = 1.0/dt @@ -1424,9 +1428,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & !---------------------------------------------------------------------------! ! ERM begin - DO i = 1,numq - call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) - ENDDO + ! DO i = 1,numq + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO ! ERM end rdt = 1.0/dt @@ -1615,9 +1619,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category ! !---------------------------------------------------------------------------! ! ERM begin - DO i = 1,numq ! nqs2 - call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) - ENDDO + ! DO i = 1,numq ! nqs2 + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO ! ERM end rdt = 1.0/dt @@ -2272,9 +2276,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category, liq-frac ! !-------------------------------------------------------------------------------------! ! ERM begin - DO i = 1,numq - call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) - ENDDO + ! DO i = 1,numq + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO ! ERM end rdt = 1.0/dt @@ -2474,9 +2478,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 3-ice-category, liq-frac ! !-------------------------------------------------------------------------------------! ! ERM begin - DO i = 1,numq - call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) - ENDDO + ! DO i = 1,numq + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO ! ERM end rdt = 1.0/dt @@ -2707,9 +2711,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 4-ice-category, liq-frac ! !-------------------------------------------------------------------------------------! ! ERM begin - DO i = 1,numq - call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) - ENDDO + ! DO i = 1,numq + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO ! ERM end rdt = 1.0/dt diff --git a/src/param.F b/src/param.F index c7f5a92..a22d0ef 100644 --- a/src/param.F +++ b/src/param.F @@ -151,7 +151,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & logical :: doit,getfall logical :: nssl_hail_on = .false. - ! ERM begin for p3 parameters + ! ERM/DTD begin for p3 parameters real :: p3_cccn = 300.e6 real :: p3_nimax = 2000.e3 integer :: p3_iparam = 3 @@ -184,7 +184,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & integer :: p3_catdest_homorain_n2 = 2 integer :: p3_catdest_homorain_n3 = 2 integer :: p3_catdest_homorain_n4 = 2 - ! ERM end + ! ERM/DTD end #ifdef MPI integer :: ntmp1,ntmp2,ntmp3,ntmp4,reqs,reqs1,reqs2,reqs3,reqs4 integer, dimension(MPI_STATUS_SIZE) :: status @@ -217,7 +217,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dmrauto, & ioldlimiter, & ihlcnh - NAMELIST /p3_params/ & ! ERM add p3_params namelist + NAMELIST /p3_params/ & ! ERM/DTD add p3_params namelist p3_cccn, & p3_nimax, & p3_iparam, & @@ -596,6 +596,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(output_filetype,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(output_interp ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(output_rain ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(output_hail ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(output_sws ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(output_svs ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(output_sps ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) @@ -837,7 +838,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(nssl_3moment,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(nssl_density_on,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) ENDIF - ! ERM begin + ! ERM/DTD begin call MPI_BCAST(p3_cccn ,1,MPI_REAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_nimax ,1,MPI_REAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_iparam ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) @@ -870,7 +871,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(p3_catdest_homorain_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_catdest_homorain_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_catdest_homorain_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - ! ERM end + ! ERM/DTD end #endif open(unit=20,file='namelist.input',form='formatted',status='old', & @@ -4130,7 +4131,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! if(dowr) write(outfile,*) 'Calling graupel_init' ! if(dowr) write(outfile,*) - CALL nssl_2mom_init(ipctmp=0,mixphase=0,ihvol=-1,eqtset_tmp=eqtset) + CALL nssl_2mom_init(ipctmp=0,mixphase=0,nssl_hail_on=.false.,nssl_density_on=.false., & + eqtset_tmp=eqtset,myrank=myid,mpiroot=0) ! if(dowr) write(outfile,*) @@ -5762,6 +5764,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & output_interp = max(0,min(1,output_interp))*iterrain output_rain = max(0,min(1,output_rain)) + output_hail = max(0,min(1,output_hail)) output_sws = max(0,min(1,output_sws)) output_svs = max(0,min(1,output_svs)) output_sps = max(0,min(1,output_sps)) @@ -5839,6 +5842,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & !!! endif if(imoist.eq.0)then output_rain=0 + output_hail=0 output_srs=0 output_sgs=0 output_qv=0 @@ -5901,6 +5905,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & if(dowr) write(outfile,*) 'output_filetype =',output_filetype if(dowr) write(outfile,*) 'output_interp =',output_interp if(dowr) write(outfile,*) 'output_rain =',output_rain + if(dowr) write(outfile,*) 'output_hail =',output_hail if(dowr) write(outfile,*) 'output_sws =',output_sws if(dowr) write(outfile,*) 'output_svs =',output_svs if(dowr) write(outfile,*) 'output_sps =',output_sps diff --git a/src/solve3.F b/src/solve3.F index 2eab478..c539be5 100644 --- a/src/solve3.F +++ b/src/solve3.F @@ -83,7 +83,7 @@ subroutine solve3(nstep,num_soil_layers, & pi0,rho0,prs0,thv0,th0,rth0,qv0,qc0, & qi0,rr0,rf0,rrf0, & zs,gz,rgz,gzu,rgzu,gzv,rgzv,dzdx,dzdy, & - rain,sws,svs,sps,srs,sgs,sus,shs, & + rain,hail,sws,svs,sps,srs,sgs,sus,shs, & dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8, & divx,rho,rr,rf,prs, & u0,rru,ua,u3d,uten,uten1, & @@ -153,7 +153,7 @@ subroutine solve3(nstep,num_soil_layers, & real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: qi0,rr0,rf0,rrf0 real, intent(in), dimension(ib:ie,jb:je) :: zs real, intent(in), dimension(itb:ite,jtb:jte) :: gz,rgz,gzu,rgzu,gzv,rgzv,dzdx,dzdy - real, intent(inout), dimension(ib:ie,jb:je,nrain) :: rain,sws,svs,sps,srs,sgs,sus,shs + real, intent(inout), dimension(ib:ie,jb:je,nrain) :: rain,hail,sws,svs,sps,srs,sgs,sus,shs real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8 real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: divx,rho,rr,rf,prs real, intent(inout), dimension(ib:ie+1,jb:je,kb:ke) :: u0,rru,ua,u3d,uten,uten1 @@ -854,6 +854,17 @@ subroutine solve3(nstep,num_soil_layers, & ENDIF + IF( output_hail.eq.1 )THEN + + if(imove.eq.1.and.imoist.eq.1)then + weps = 10.0*epsilon + call movesfc(0.0,dt,weps,uh,vh,hail(ib,jb,2),dum1(ib,jb,1),dum1(ib,jb,2),dum1(ib,jb,3), & + reqs_s,sw31(1,1,1),sw32(1,1,1),se31(1,1,1),se32(1,1,1), & + ss31(1,1,1),ss32(1,1,1),sn31(1,1,1),sn32(1,1,1)) + endif + + ENDIF + !-------------------------------------------------------------------- ! Maximum horizontal wind speed at lowest model level: ! (include domain movement in calculation) diff --git a/src/writeout.F b/src/writeout.F index 72dd7ad..2792bb4 100644 --- a/src/writeout.F +++ b/src/writeout.F @@ -23,7 +23,7 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, xh,xf,uf,yh,yf,vf,xfref,yfref, & rds,sigma,rdsf,sigmaf,zh,zf,mf,gx,gy,wprof, & pi0,prs0,rho0,rr0,rf0,rrf0,th0,qv0,u0,v0,thv0,rth0,qc0,qi0, & - zs,rgzu,rgzv,rain,sws,svs,sps,srs,sgs,sus,shs,thflux,qvflux,psfc, & + zs,rgzu,rgzv,rain,hail,sws,svs,sps,srs,sgs,sus,shs,thflux,qvflux,psfc, & rxh,arh1,arh2,uh,ruh,rxf,arf1,arf2,vh,rvh,mh,rmh,rmf,rr,rf, & gz,rgz,gzu,gzv,gxu,gyv,dzdx,dzdy,c1,c2, & cd,ch,cq,tlh,f2d,psmth,prate,ustt,cm0, & @@ -101,7 +101,7 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, real, dimension(ib:ie,jb:je,kb:ke), intent(in) :: pi0,prs0,rho0,rr0,rf0,rrf0,th0,qv0,thv0,rth0,qc0,qi0 real, dimension(ib:ie,jb:je), intent(in) :: zs real, dimension(itb:ite,jtb:jte), intent(in) :: rgzu,rgzv - real, dimension(ib:ie,jb:je,nrain), intent(in) :: rain,sws,svs,sps,srs,sgs,sus,shs + real, dimension(ib:ie,jb:je,nrain), intent(in) :: rain,hail,sws,svs,sps,srs,sgs,sus,shs real, dimension(ib:ie,jb:je), intent(in) :: xland,psfc,psmth,thflux,qvflux,cd,ch,cq,tlh,f2d,prate,ustt,cm0 real, intent(in), dimension(ib:ie) :: rxh,arh1,arh2,uh,ruh real, intent(in), dimension(ib:ie+1) :: rxf,arf1,arf2 @@ -362,6 +362,19 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, call write2d(rain(ib,jb,1),fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) endif + !............................................. + + if(output_hail .eq.1)then + n_out = n_out + 1 + name_output(n_out) = 'hail ' + desc_output(n_out) = 'accumulated surface hailfall' + unit_output(n_out) = 'cm' + grid_output(n_out) = '2' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + cmpr_output(n_out) = .true. + + call write2d(hail(ib,jb,1),fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) + endif + !............................................. if(output_rain .eq.1)then @@ -543,6 +556,23 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, call write2d(dum2d,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) endif + if(output_hail .eq.1)then + n_out = n_out + 1 + name_output(n_out) = 'hail2 ' + desc_output(n_out) = 'translated surface hailfall' + unit_output(n_out) = 'cm' + grid_output(n_out) = '2' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j) + do j=1,nj + do i=1,ni + dum2d(i,j) = hail(i,j,2) + enddo + enddo + + call write2d(dum2d,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) + endif endif !............................................. @@ -3589,6 +3619,26 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, ENDIF ENDIF + ! for NSSL microphysics: + IF( ptype.ge.26 .and. ptype.le.28 )THEN + IF ( output_n_as_m3 > 0 ) THEN + ! convert output to number per m^3 + IF ( trim(qunit(n)) == '#/kg' ) THEN + unit_output(n_out) = '#/m3' + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = qa(i,j,k,n)*rho(i,j,k) + enddo + enddo + enddo + ENDIF + ENDIF + ENDIF + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) From 861737d7bf59fe24fa1b4408104425f7b4480e2d Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Sat, 25 Jul 2026 17:04:58 -0400 Subject: [PATCH 18/25] Added new per-category max Ni limiter for P3 from later versions. --- src/module_mp_p3.F | 60 +++++++++++++++++++++++++++++++++++++++++----- src/param.F | 22 ++++++++--------- 2 files changed, 65 insertions(+), 17 deletions(-) diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 8ef032e..419479e 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -150,7 +150,7 @@ MODULE microphy_p3 inv_rhow,qsmall,nsmall,bsmall,zsmall,cp,g,rd,rv,ep_2,inv_cp,mw,osm, & vi,epsm,rhoa,map,ma,rr,bact,inv_rm1,inv_rm2,sig1,nanew1,f11,f21,sig2, & nanew2,f12,f22,pi,thrd,sxth,piov3,piov6,rho_rimeMin, & - rho_rimeMax,inv_rho_rimeMax,max_total_Ni,dbrk,nmltratio,minVIS, & + rho_rimeMax,inv_rho_rimeMax,max_Ni,dbrk,nmltratio,minVIS, & maxVIS,mu_i_initial,mu_r_constant,inv_Drmax,ntiny,Dmin_HM,Dinit_HM real, parameter :: rho00 = 1.225 ! ERM integer :: n_iceCat = -1 !used for GEM interface @@ -190,7 +190,7 @@ MODULE microphy_p3 subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err,dowr, & nanew1_in,iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt,iparamice_in, & - rssflg_in,sssflg_in,max_total_Ni_in,cat_init_new_in, & + rssflg_in,sssflg_in,max_Ni_in,cat_init_new_in, & log_nislf_in, & log_iceice_interaction_in, & catdest_contact_n2_in,catdest_contact_n3_in,catdest_contact_n4_in, & @@ -224,7 +224,7 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err character(len=*), intent(in), optional :: model ! driving model logical, intent(in), optional :: dowr ! Added by ERM - real, intent(in), optional :: nanew1_in, max_total_Ni_in + real, intent(in), optional :: nanew1_in, max_Ni_in integer, intent(in), optional :: iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt, & iparamice_in,rssflg_in,sssflg_in logical, intent(in), optional :: cat_init_new_in @@ -290,9 +290,10 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err piov3 = pi*thrd piov6 = pi*sxth -! maximum total ice concentration (sum of all categories) - max_total_Ni = 2000.e+3 !(m) - IF ( present( max_total_Ni_in ) ) max_total_Ni = max_total_Ni_in ! Added by ERM +! maximum total ice concentration (per category). DTD NOTE: back ported this from a later P3 +! version for now in lieu of rebasing everything onto the latest version, which will happen soon. + max_Ni = 2000.e+3 !(m) + IF ( present( max_Ni_in ) ) max_Ni = max_Ni_in ! Added by ERM ! switch for warm-rain parameterization ! = 1 Seifert and Beheng 2001 @@ -3102,6 +3103,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi epsiw_totdp = 0.d0 ! DTD: turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) + ! DTD: added call to new per-category Ni limiter + call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) iice_loop1: do iice = 1,nCat Eii_fact(iice) = 1.0 ! DTD: set default value of ice-ice collection efficiency factor to 1.0 to avoid potential stale value issue @@ -5377,6 +5380,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qv(i,k) = max(0., qv(i,k)) ! DTD turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) + ! DTD: added call to new per-category Ni limiter + call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) !--------------------------------------------------------------------------------- @@ -6814,6 +6819,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ice: ! DTD turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) + ! DTD: added call to new per-category Ni limiter + call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) + ! (category-order-invariant: defer the shared qv/th increments from the ! ice clip, accumulate in double precision, apply once after the loop) @@ -12699,6 +12707,46 @@ subroutine impose_max_total_Ni(nitot_local,max_total_Ni,inv_rho_local) end subroutine impose_max_total_Ni + !=========================================================================================== + + subroutine impose_max_Ni(nitot_local,max_Ni,i_rho_local) + +!-------------------------------------------------------------------------------- +! Impose maximum ice number concentration on each ice category individually. +! Note, with this approach the maximum total concentration (sum of all categories) +! can in principle be nCat*max_Ni. +!-------------------------------------------------------------------------------- + + implicit none + +!arguments: + real, intent(inout), dimension(:) :: nitot_local !note: dimension (nCat) + real, intent(in) :: max_Ni,i_rho_local + +!local variables: + real :: dum + integer :: iice + + nitot_local(:) = min(nitot_local(:),max_Ni*i_rho_local) + +!--- +! Previous apporach: +! Impose maximum total ice number concentration (total of all ice categories). +! If the sum of all nitot(:) exceeds maximum allowable, each category to preserve +! ratio of number between categories. +! +! if (sum(nitot_local(:)).ge.1.e-20) then +! dum = max_total_Ni*i_rho_local/sum(nitot_local(:)) +! nitot_local(:) = nitot_local(:)*min(dum,1.) +! endif +! +! Potential problem: +! This following approach can decrease the number for a category that already has +! small number, thereby creating unrealistic mean sizes and reflectivty values. +!--- + + end subroutine impose_max_Ni + !=========================================================================================== real function qv_sat(t_atm,p_atm,i_wrt) diff --git a/src/param.F b/src/param.F index a22d0ef..b7692fd 100644 --- a/src/param.F +++ b/src/param.F @@ -4169,7 +4169,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & ! ERM added new p3 options (all calls) p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & @@ -4193,7 +4193,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & @@ -4217,7 +4217,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & @@ -4241,7 +4241,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & @@ -4265,7 +4265,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & @@ -4289,7 +4289,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & @@ -4313,7 +4313,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & @@ -4337,7 +4337,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & @@ -4361,7 +4361,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & @@ -4385,7 +4385,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & @@ -4409,7 +4409,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & - rssflg_in=rssflg, sssflg_in=sssflg, max_total_Ni_in=p3_nimax, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & log_iceice_interaction_in=log_iceice_interaction, & From cd0ecce5a01154489998f58cc2df8568e241ba8e Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Sat, 25 Jul 2026 17:14:51 -0400 Subject: [PATCH 19/25] Added switch to turn of Ni limiter by setting max_Ni parameter to -1 in code (or setting p3_nimax to -1 in namelist). Namelist setting overrides in-code setting. --- src/module_mp_p3.F | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 419479e..c8030af 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -292,6 +292,10 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err ! maximum total ice concentration (per category). DTD NOTE: back ported this from a later P3 ! version for now in lieu of rebasing everything onto the latest version, which will happen soon. +! The original approach here native to this version is to limit the total ice concentration across +! all categories proportionally, which creates issues for those categories that are just minding +! their own business and not trying to produce unholy amounts of ice particles ;). +! Note: set to a negative number to turn off the max Ni limiter. max_Ni = 2000.e+3 !(m) IF ( present( max_Ni_in ) ) max_Ni = max_Ni_in ! Added by ERM @@ -3104,7 +3108,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! DTD: turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) ! DTD: added call to new per-category Ni limiter - call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) + if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) iice_loop1: do iice = 1,nCat Eii_fact(iice) = 1.0 ! DTD: set default value of ice-ice collection efficiency factor to 1.0 to avoid potential stale value issue @@ -5381,7 +5385,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! DTD turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) ! DTD: added call to new per-category Ni limiter - call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) + if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) !--------------------------------------------------------------------------------- @@ -6820,7 +6824,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! DTD turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) ! DTD: added call to new per-category Ni limiter - call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) + if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) ! (category-order-invariant: defer the shared qv/th increments from the From 990adc9399b74196ef6826871abe26582927287c Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 27 Jul 2026 11:41:43 -0400 Subject: [PATCH 20/25] Add P3 ptypes 64-67: 5- and 6-ice-category configurations Four new P3 configurations, using the next free ptype numbers so existing ones are untouched: 64 = as ptype 57 (3-moment ice, no liqFrac) but 5 ice categories 65 = as ptype 57 but 6 ice categories 66 = as ptype 63 (3-moment ice, liqFrac) but 5 ice categories 67 = as ptype 63 but 6 ice categories P3 itself was already generic in nCat (allocatable per-category arrays, deltaD_init already has cases for 5 and 6+, and lookupTable_2 is indexed by size/rime/density bins rather than by category), so the work was in the category-destination dispatch and the CM1-side plumbing: - module_mp_p3.F: catdest_*_n5 / _n6 added for all six ice-initiation mechanisms (module vars, p3_init optional arguments with clamping, and nCat==5/6 branches at each of the six iice_dest dispatch sites). Without these, cat_init_new=.true. would have left iice_dest unset at nCat>4. Defaults continue the progressive split of the _n2..._n4 series so no category lacks a source: at nCat=5 deposition nucleation moves to its own category, at nCat=6 homogeneous rain freezing moves to its own. - module_mp_p3.F: mp_p3_wrapper_wrf extended with qit/qni/qir/qib/qzi/qli_5 and _6, diag_vmi/dmi/rhoi_5,_6 and diag_dhmax_5,_6, plus the corresponding gather/scatter blocks. diag_effi_ave's hard-coded nCat<=4 expressions replaced by a sequential loop over categories; the accumulation order is the same one the explicit sums used, so nCat<=4 is unchanged bit-for-bit. - param.F: p3_catdest_*_n5/_n6 namelist variables + MPI_BCAST, p3_init dispatch branches, ptype range tests extended to 67, and the numq/qname/qunit/qmag/cloudvar/np3a/np3o blocks for the four new ptypes. - mp_driver.F: four new per-ptype blocks (p3a pack, wrapper call at n_iceCat=5/6, q3d unpack, p3o and out2d/out3d fills). - writeout.F: ptypes 64-67 added to the category 1-4 P3 diagnostic blocks, plus new blocks for categories 5 and 6 (p3_vmi5/6, p3_dmi5/6, p3_rhoi5/6, p3_dhmax5/6). - radiation_driver.F: ptypes 64-67 added to the effc/effi list. - README.namelist: ptype list now documents 54, 56, 57 and 60-67 (it had only covered 50-53) and explains the p3_catdest_*_nN suffix convention. - run/namelist.input: the twelve new _n5/_n6 catdest keys. Verified: full build clean; all four ptypes run with the expected numq/nqs2/qname tables; a 2400 s ptype-65 run populates all six categories (qi5 via deposition nucleation, qi6 via homogeneous rain freezing) and emits all 24 per-category diagnostics. Regression: a 2400 s ptype-57 run is bit-identical (cm1out_s/u/v/w/stats) against a binary built from the parent commit. Note: older executables will reject a namelist containing the new _n5/_n6 keys, so A/B runs against an older binary need them stripped. Co-Authored-By: Claude Opus 5 --- README.namelist | 20 + run/namelist.input | 12 + src/module_mp_p3.F | 180 +++++-- src/mp_driver.F | 1132 ++++++++++++++++++++++++++++++++++++++++ src/param.F | 830 ++++++++++++++++++++++++++++- src/radiation_driver.F | 3 +- src/writeout.F | 163 +++++- 7 files changed, 2298 insertions(+), 42 deletions(-) diff --git a/README.namelist b/README.namelist index 8453750..2db565b 100644 --- a/README.namelist +++ b/README.namelist @@ -483,10 +483,30 @@ (ptype 26 or 27) (Note: P3 = Predicted Particle Property bulk microphysics scheme) + (options 50-54,56,57,60-67 use namelist p3_params, see below) 50 = P3 1-ice category, 1-moment cloud water 51 = P3 1-ice category plus double-moment cloud water 52 = P3 2-ice categories plus double-moment cloud water 53 = P3 1-ice category, 3-moment ice, plus double-moment cloud water + 54 = P3 2-ice categories, 3-moment ice + 56 = P3 3-ice categories, 3-moment ice + 57 = P3 4-ice categories, 3-moment ice + 60 = P3 1-ice category, 3-moment ice, predicted liquid fraction + 61 = P3 2-ice categories, 3-moment ice, predicted liquid fraction + 62 = P3 3-ice categories, 3-moment ice, predicted liquid fraction + 63 = P3 4-ice categories, 3-moment ice, predicted liquid fraction + 64 = P3 5-ice categories, 3-moment ice (as 57, but 5 categories) + 65 = P3 6-ice categories, 3-moment ice (as 57, but 6 categories) + 66 = P3 5-ice categories, 3-moment ice, predicted liquid fraction + (as 63, but 5 categories) + 67 = P3 6-ice categories, 3-moment ice, predicted liquid fraction + (as 63, but 6 categories) + (All P3 multi-category options use double-moment cloud water. With + p3_cat_init_new = .true. the destination category for each ice + initiation mechanism is set by the p3_catdest_* namelist variables; + the _nN suffix selects the value used when the configuration has N + ice categories, so ptypes 64/66 use the _n5 values and 65/67 the _n6 + values.) 55 = Jensen's ISHMAEL (Ice-Spheroids Habit Model with Aspect-ratio Evolution) nssl_3moment - logical (default = .false.) Works with ptype 26 and 27 to turn on diff --git a/run/namelist.input b/run/namelist.input index eb0f783..01a26ba 100644 --- a/run/namelist.input +++ b/run/namelist.input @@ -477,4 +477,16 @@ p3_catdest_homorain_n2 = 2, p3_catdest_homorain_n3 = 2, p3_catdest_homorain_n4 = 2, + p3_catdest_contact_n5 = 4, + p3_catdest_contact_n6 = 4, + p3_catdest_rainimm_n5 = 2, + p3_catdest_rainimm_n6 = 2, + p3_catdest_rimesplinter_n5 = 3, + p3_catdest_rimesplinter_n6 = 3, + p3_catdest_depnuc_n5 = 5, + p3_catdest_depnuc_n6 = 5, + p3_catdest_homocloud_n5 = 1, + p3_catdest_homocloud_n6 = 1, + p3_catdest_homorain_n5 = 2, + p3_catdest_homorain_n6 = 6, / diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index c8030af..4096281 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -165,24 +165,41 @@ MODULE microphy_p3 ! for merge_opt=0 with qrcol_opt=2 and ncat=2, this disables qrcol for iice=2 logical :: cat_init_new = .true. ! default for mechanism-based ice category initialization logical :: log_iceice_interaction = .true. ! default for allowing ice categories to interact + ! DTD: the _n5/_n6 defaults continue the progressive split of the _n2..._n4 + ! series: each additional category takes over one more initiation mechanism, + ! so that no category is left without a source. For nCat=5 deposition + ! nucleation moves to its own category (5), and for nCat=6 homogeneous + ! freezing of rain moves to its own category (6). integer :: catdest_contact_n2 = 1 integer :: catdest_contact_n3 = 3 integer :: catdest_contact_n4 = 4 + integer :: catdest_contact_n5 = 4 + integer :: catdest_contact_n6 = 4 integer :: catdest_rainimm_n2 = 2 integer :: catdest_rainimm_n3 = 2 integer :: catdest_rainimm_n4 = 2 + integer :: catdest_rainimm_n5 = 2 + integer :: catdest_rainimm_n6 = 2 integer :: catdest_rimesplinter_n2 = 1 integer :: catdest_rimesplinter_n3 = 3 integer :: catdest_rimesplinter_n4 = 3 + integer :: catdest_rimesplinter_n5 = 3 + integer :: catdest_rimesplinter_n6 = 3 integer :: catdest_depnuc_n2 = 1 integer :: catdest_depnuc_n3 = 3 integer :: catdest_depnuc_n4 = 4 + integer :: catdest_depnuc_n5 = 5 + integer :: catdest_depnuc_n6 = 5 integer :: catdest_homocloud_n2 = 1 integer :: catdest_homocloud_n3 = 1 integer :: catdest_homocloud_n4 = 1 + integer :: catdest_homocloud_n5 = 1 + integer :: catdest_homocloud_n6 = 1 integer :: catdest_homorain_n2 = 2 integer :: catdest_homorain_n3 = 2 integer :: catdest_homorain_n4 = 2 + integer :: catdest_homorain_n5 = 2 + integer :: catdest_homorain_n6 = 6 ! End ERM contains @@ -199,7 +216,13 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err catdest_rimesplinter_n4_in,catdest_depnuc_n2_in,catdest_depnuc_n3_in, & catdest_depnuc_n4_in,catdest_homocloud_n2_in,catdest_homocloud_n3_in, & catdest_homocloud_n4_in,catdest_homorain_n2_in,catdest_homorain_n3_in, & - catdest_homorain_n4_in) + catdest_homorain_n4_in, & + catdest_contact_n5_in,catdest_contact_n6_in, & + catdest_rainimm_n5_in,catdest_rainimm_n6_in, & + catdest_rimesplinter_n5_in,catdest_rimesplinter_n6_in, & + catdest_depnuc_n5_in,catdest_depnuc_n6_in, & + catdest_homocloud_n5_in,catdest_homocloud_n6_in, & + catdest_homorain_n5_in,catdest_homorain_n6_in) !------------------------------------------------------------------------------------------! ! This subroutine initializes all physical constants and parameters needed by the P3 ! @@ -236,6 +259,12 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err integer, intent(in), optional :: catdest_depnuc_n2_in,catdest_depnuc_n3_in,catdest_depnuc_n4_in integer, intent(in), optional :: catdest_homocloud_n2_in,catdest_homocloud_n3_in,catdest_homocloud_n4_in integer, intent(in), optional :: catdest_homorain_n2_in,catdest_homorain_n3_in,catdest_homorain_n4_in + integer, intent(in), optional :: catdest_contact_n5_in,catdest_contact_n6_in + integer, intent(in), optional :: catdest_rainimm_n5_in,catdest_rainimm_n6_in + integer, intent(in), optional :: catdest_rimesplinter_n5_in,catdest_rimesplinter_n6_in + integer, intent(in), optional :: catdest_depnuc_n5_in,catdest_depnuc_n6_in + integer, intent(in), optional :: catdest_homocloud_n5_in,catdest_homocloud_n6_in + integer, intent(in), optional :: catdest_homorain_n5_in,catdest_homorain_n6_in ! End ERM ! Local variables and parameters: logical, save :: is_init = .false. @@ -335,6 +364,18 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err IF ( present( catdest_homorain_n2_in ) ) catdest_homorain_n2 = min(2,max(1,catdest_homorain_n2_in)) IF ( present( catdest_homorain_n3_in ) ) catdest_homorain_n3 = min(3,max(1,catdest_homorain_n3_in)) IF ( present( catdest_homorain_n4_in ) ) catdest_homorain_n4 = min(4,max(1,catdest_homorain_n4_in)) + IF ( present( catdest_contact_n5_in ) ) catdest_contact_n5 = min(5,max(1,catdest_contact_n5_in)) + IF ( present( catdest_contact_n6_in ) ) catdest_contact_n6 = min(6,max(1,catdest_contact_n6_in)) + IF ( present( catdest_rainimm_n5_in ) ) catdest_rainimm_n5 = min(5,max(1,catdest_rainimm_n5_in)) + IF ( present( catdest_rainimm_n6_in ) ) catdest_rainimm_n6 = min(6,max(1,catdest_rainimm_n6_in)) + IF ( present( catdest_rimesplinter_n5_in ) ) catdest_rimesplinter_n5 = min(5,max(1,catdest_rimesplinter_n5_in)) + IF ( present( catdest_rimesplinter_n6_in ) ) catdest_rimesplinter_n6 = min(6,max(1,catdest_rimesplinter_n6_in)) + IF ( present( catdest_depnuc_n5_in ) ) catdest_depnuc_n5 = min(5,max(1,catdest_depnuc_n5_in)) + IF ( present( catdest_depnuc_n6_in ) ) catdest_depnuc_n6 = min(6,max(1,catdest_depnuc_n6_in)) + IF ( present( catdest_homocloud_n5_in ) ) catdest_homocloud_n5 = min(5,max(1,catdest_homocloud_n5_in)) + IF ( present( catdest_homocloud_n6_in ) ) catdest_homocloud_n6 = min(6,max(1,catdest_homocloud_n6_in)) + IF ( present( catdest_homorain_n5_in ) ) catdest_homorain_n5 = min(5,max(1,catdest_homorain_n5_in)) + IF ( present( catdest_homorain_n6_in ) ) catdest_homorain_n6 = min(6,max(1,catdest_homorain_n6_in)) log_maxnsmall = .true. !flag for resetting n up to nsmall ! Primary ice nucleation @@ -909,8 +950,11 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes qit_2, qni_2, qir_2, qib_2, diag_vmi_2, diag_dmi_2, diag_rhoi_2, qzi_2, qli_2, & qit_3, qni_3, qir_3, qib_3, diag_vmi_3, diag_dmi_3, diag_rhoi_3, qzi_3, qli_3, & qit_4, qni_4, qir_4, qib_4, diag_vmi_4, diag_dmi_4, diag_rhoi_4, qzi_4, qli_4, & + qit_5, qni_5, qir_5, qib_5, diag_vmi_5, diag_dmi_5, diag_rhoi_5, qzi_5, qli_5, & ! DTD added categories 5 and 6 + qit_6, qni_6, qir_6, qib_6, diag_vmi_6, diag_dmi_6, diag_rhoi_6, qzi_6, qli_6, & nc, cn, diag2d_01, diag2d_02, diag3d_01, diag3d_02, diag3d_03, & ! ERM added cn - diag_dhmax_1, diag_dhmax_2, diag_dhmax_3, diag_dhmax_4, diagflag, j_index) ! DTD added j index for debugging, ERM added diagflag + diag_dhmax_1, diag_dhmax_2, diag_dhmax_3, diag_dhmax_4, & + diag_dhmax_5, diag_dhmax_6, diagflag, j_index) ! DTD added j index for debugging, ERM added diagflag !------------------------------------------------------------------------------------------! ! This is the main WRF interface with the P3 microphysics scheme. ! @@ -998,15 +1042,32 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qzi_4 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qli_4 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qit_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qni_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qir_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qib_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qzi_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qli_5 + + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qit_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qni_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qir_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qib_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qzi_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qli_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(out) :: diag_effi_ave real, dimension(ims:ime, kms:kme, jms:jme), intent(out) :: diag_vmi_1, diag_dmi_1, diag_rhoi_1 real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_vmi_2, diag_dmi_2, diag_rhoi_2 real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_vmi_3, diag_dmi_3, diag_rhoi_3 real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_vmi_4, diag_dmi_4, diag_rhoi_4 + real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_vmi_5, diag_dmi_5, diag_rhoi_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_vmi_6, diag_dmi_6, diag_rhoi_6 real, dimension(ims:ime, jms:jme), intent(out), optional :: diag2d_01, diag2d_02 real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag3d_01, diag3d_02, diag3d_03 real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_dhmax_1, diag_dhmax_2, diag_dhmax_3, diag_dhmax_4 + real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_dhmax_5, diag_dhmax_6 real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: pii,p,dz,w real, dimension(ims:ime, jms:jme), intent(inout) :: rainnc,rainncv,sr,snownc,snowncv @@ -1033,6 +1094,7 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes real, dimension(its:ite) :: pcprt_liq,pcprt_sol real :: dum1,dum2,dum3,dum4 integer :: i,k,j + integer :: iice_ave ! category index for the effective-radius weighting integer :: j_model ! true model j-slab index for the checksum/point ! dumps: CM1 calls this wrapper once per j with ! 2D slabs (jts=jte=1) and the real j in j_index, @@ -1124,6 +1186,24 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes birim(:,:,4) = qib_4(:,:,j) if (log_3momIce) zitot(:,:,4) = qzi_4(:,:,j) if (log_liqFrac) qiliq(:,:,4) = qli_4(:,:,j) + + if (n_iceCat.ge.5) then + qitot(:,:,5) = qit_5(:,:,j) + qirim(:,:,5) = qir_5(:,:,j) + nitot(:,:,5) = qni_5(:,:,j) + birim(:,:,5) = qib_5(:,:,j) + if (log_3momIce) zitot(:,:,5) = qzi_5(:,:,j) + if (log_liqFrac) qiliq(:,:,5) = qli_5(:,:,j) + + if (n_iceCat.ge.6) then + qitot(:,:,6) = qit_6(:,:,j) + qirim(:,:,6) = qir_6(:,:,j) + nitot(:,:,6) = qni_6(:,:,j) + birim(:,:,6) = qib_6(:,:,j) + if (log_3momIce) zitot(:,:,6) = qzi_6(:,:,j) + if (log_liqFrac) qiliq(:,:,6) = qli_6(:,:,j) + endif ! >=6 + endif ! >=5 endif ! >=4 endif ! >=3 endif ! >=2 @@ -1226,6 +1306,32 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes if (log_3momIce) qzi_4(:,:,j) = zitot(:,:,4) if (log_liqFrac) qli_4(:,:,j) = qiliq(:,:,4) if (present(diag_dhmax_4)) diag_dhmax_4(:,:,j) = diag_dhmax(:,:,4) + + if (n_iceCat.ge.5) then + qit_5(:,:,j) = qitot(:,:,5) + qir_5(:,:,j) = qirim(:,:,5) + qni_5(:,:,j) = nitot(:,:,5) + qib_5(:,:,j) = birim(:,:,5) + diag_vmi_5(:,:,j) = diag_vmi(:,:,5) + diag_dmi_5(:,:,j) = diag_dmi(:,:,5) + diag_rhoi_5(:,:,j) = diag_rhoi(:,:,5) + if (log_3momIce) qzi_5(:,:,j) = zitot(:,:,5) + if (log_liqFrac) qli_5(:,:,j) = qiliq(:,:,5) + if (present(diag_dhmax_5)) diag_dhmax_5(:,:,j) = diag_dhmax(:,:,5) + + if (n_iceCat.ge.6) then + qit_6(:,:,j) = qitot(:,:,6) + qir_6(:,:,j) = qirim(:,:,6) + qni_6(:,:,j) = nitot(:,:,6) + qib_6(:,:,j) = birim(:,:,6) + diag_vmi_6(:,:,j) = diag_vmi(:,:,6) + diag_dmi_6(:,:,j) = diag_dmi(:,:,6) + diag_rhoi_6(:,:,j) = diag_rhoi(:,:,6) + if (log_3momIce) qzi_6(:,:,j) = zitot(:,:,6) + if (log_liqFrac) qli_6(:,:,j) = qiliq(:,:,6) + if (present(diag_dhmax_6)) diag_dhmax_6(:,:,j) = diag_dhmax(:,:,6) + endif ! >=6 + endif ! >=5 endif ! >=4 endif ! >=3 endif ! >=2 @@ -1235,40 +1341,28 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes do i=its,ite do k=kts,kte - dum1 = 0. - dum2 = 0. - dum3 = 0. - dum4 = 0. + !DTD: generalized from the previous hard-coded nCat<=4 expressions to a + ! sequential loop over categories, so that 5- and 6-category + ! configurations are covered. The accumulation order (left to + ! right over the category index) is the same one the old explicit + ! sums used, so results for nCat<=4 are unchanged bit-for-bit. + dum1 = 0. ! sum over categories of qitot/effi (the weighting denominator) + dum2 = 0. ! sum over categories of qitot (the numerator) diag_effi_ave(i,k,j) = 25.e-6 ! set to default 25 microns if (n_iceCat.ge.2) then - if (qitot(i,k,1).ge.qsmall) dum1 = qitot(i,k,1)/diag_effi(i,k,1) - if (qitot(i,k,2).ge.qsmall) dum2 = qitot(i,k,2)/diag_effi(i,k,2) - if (n_iceCat.ge.3) then - if (qitot(i,k,3).ge.qsmall) dum3 = qitot(i,k,3)/diag_effi(i,k,3) - if (n_iceCat.ge.4) then - if (qitot(i,k,4).ge.qsmall) dum4 = qitot(i,k,4)/diag_effi(i,k,4) - endif - endif + do iice_ave = 1,n_iceCat + dum2 = dum2 + qitot(i,k,iice_ave) + if (qitot(i,k,iice_ave).ge.qsmall) dum1 = dum1 + qitot(i,k,iice_ave)/diag_effi(i,k,iice_ave) + enddo + !guard against 0/0 at ice-free points (division previously ran + !unconditionally, silently filling diag_effi_ave with NaNs there; + !the 25-micron default set above is retained instead) + if (dum1.gt.0.) diag_effi_ave(i,k,j) = dum2/dum1 + else + diag_effi_ave(i,k,j) = diag_effi(i,k,1) endif - !guard against 0/0 at ice-free points (division previously ran - !unconditionally, silently filling diag_effi_ave with NaNs there; - !the 25-micron default set above is retained instead) - select case (n_iceCat) - case (1) - diag_effi_ave(i,k,j) = diag_effi(i,k,1) - case (2) - if (dum1+dum2.gt.0.) & - diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2))/(dum1+dum2) - case (3) - if (dum1+dum2+dum3.gt.0.) & - diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2)+qitot(i,k,3))/(dum1+dum2+dum3) - case (4) - if (dum1+dum2+dum3+dum4.gt.0.) & - diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2)+qitot(i,k,3)+qitot(i,k,4))/(dum1+dum2+dum3+dum4) - end select - enddo !k-loop enddo !i-loop @@ -3867,6 +3961,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_dest = catdest_contact_n3 elseif (nCat == 4) then iice_dest = catdest_contact_n4 + elseif (nCat == 5) then + iice_dest = catdest_contact_n5 + elseif (nCat == 6) then + iice_dest = catdest_contact_n6 endif endif @@ -3916,6 +4014,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_dest = catdest_rainimm_n3 elseif (nCat == 4) then iice_dest = catdest_rainimm_n4 + elseif (nCat == 5) then + iice_dest = catdest_rainimm_n5 + elseif (nCat == 6) then + iice_dest = catdest_rainimm_n6 endif endif if (global_status /= STATUS_OK) return @@ -3955,6 +4057,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_dest = catdest_rimesplinter_n3 elseif (nCat == 4) then iice_dest = catdest_rimesplinter_n4 + elseif (nCat == 5) then + iice_dest = catdest_rimesplinter_n5 + elseif (nCat == 6) then + iice_dest = catdest_rimesplinter_n6 endif endif if (global_status /= STATUS_OK) return @@ -4391,6 +4497,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_dest = catdest_depnuc_n3 elseif (nCat == 4) then iice_dest = catdest_depnuc_n4 + elseif (nCat == 5) then + iice_dest = catdest_depnuc_n5 + elseif (nCat == 6) then + iice_dest = catdest_depnuc_n6 endif endif if (global_status /= STATUS_OK) return @@ -6548,6 +6658,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_dest = catdest_homocloud_n3 elseif (nCat == 4) then iice_dest = catdest_homocloud_n4 + elseif (nCat == 5) then + iice_dest = catdest_homocloud_n5 + elseif (nCat == 6) then + iice_dest = catdest_homocloud_n6 endif endif if (global_status /= STATUS_OK) return @@ -6600,6 +6714,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_dest = catdest_homorain_n3 elseif (nCat == 4) then iice_dest = catdest_homorain_n4 + elseif (nCat == 5) then + iice_dest = catdest_homorain_n5 + elseif (nCat == 6) then + iice_dest = catdest_homorain_n6 endif endif if (global_status /= STATUS_OK) return diff --git a/src/mp_driver.F b/src/mp_driver.F index 6aa12c5..997d117 100644 --- a/src/mp_driver.F +++ b/src/mp_driver.F @@ -2965,6 +2965,1138 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & if (timestats.ge.1) time_microphy = time_microphy+mytime() + ELSEIF (ptype.eq.64) THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 5-ice-category ! +!-------------------------------------------------------------------------------------! + + rdt = 1.0/dt + + p3_jloop9: DO j=1,nj + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,10 ) ! qnr + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,15) = q3d(i,j,k,9 ) ! nc + p3a(i,k,17) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,18) = q3d(i,j,k,11 ) ! qni_1 + p3a(i,k,19) = q3d(i,j,k,12 ) ! qir_1 + p3a(i,k,20) = q3d(i,j,k,13 ) ! qib_1 + p3a(i,k,21) = q3d(i,j,k,26 ) ! qzi_1 + p3a(i,k,25) = q3d(i,j,k,5 ) ! qit_2 + p3a(i,k,26) = q3d(i,j,k,14 ) ! qni_2 + p3a(i,k,27) = q3d(i,j,k,15 ) ! qir_2 + p3a(i,k,28) = q3d(i,j,k,16 ) ! qib_2 + p3a(i,k,29) = q3d(i,j,k,27 ) ! qzi_2 + p3a(i,k,33) = q3d(i,j,k,6 ) ! qit_3 + p3a(i,k,34) = q3d(i,j,k,17 ) ! qni_3 + p3a(i,k,35) = q3d(i,j,k,18 ) ! qir_3 + p3a(i,k,36) = q3d(i,j,k,19 ) ! qib_3 + p3a(i,k,37) = q3d(i,j,k,28 ) ! qzi_3 + p3a(i,k,41) = q3d(i,j,k,7 ) ! qit_4 + p3a(i,k,42) = q3d(i,j,k,20 ) ! qni_4 + p3a(i,k,43) = q3d(i,j,k,21 ) ! qir_4 + p3a(i,k,44) = q3d(i,j,k,22 ) ! qib_4 + p3a(i,k,45) = q3d(i,j,k,29 ) ! qzi_4 + p3a(i,k,49) = q3d(i,j,k,8 ) ! qit_5 + p3a(i,k,50) = q3d(i,j,k,23 ) ! qni_5 + p3a(i,k,51) = q3d(i,j,k,24 ) ! qir_5 + p3a(i,k,52) = q3d(i,j,k,25 ) ! qib_5 + p3a(i,k,53) = q3d(i,j,k,30 ) ! qzi_5 + enddo + enddo + + do i=1,ni + p3a(i,1,16) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,16), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 5, & + nc = p3a(1,1,15), & + qit_1 = p3a(1,1,17), & + qni_1 = p3a(1,1,18), & + qir_1 = p3a(1,1,19), & + qib_1 = p3a(1,1,20), & + qzi_1 = p3a(1,1,21), & + diag_vmi_1 = p3a(1,1,22), & + diag_dmi_1 = p3a(1,1,23), & + diag_rhoi_1 = p3a(1,1,24), & + qit_2 = p3a(1,1,25), & + qni_2 = p3a(1,1,26), & + qir_2 = p3a(1,1,27), & + qib_2 = p3a(1,1,28), & + qzi_2 = p3a(1,1,29), & + diag_vmi_2 = p3a(1,1,30), & + diag_dmi_2 = p3a(1,1,31), & + diag_rhoi_2 = p3a(1,1,32), & + qit_3 = p3a(1,1,33), & + qni_3 = p3a(1,1,34), & + qir_3 = p3a(1,1,35), & + qib_3 = p3a(1,1,36), & + qzi_3 = p3a(1,1,37), & + diag_vmi_3 = p3a(1,1,38), & + diag_dmi_3 = p3a(1,1,39), & + diag_rhoi_3 = p3a(1,1,40), & + qit_4 = p3a(1,1,41), & + qni_4 = p3a(1,1,42), & + qir_4 = p3a(1,1,43), & + qib_4 = p3a(1,1,44), & + qzi_4 = p3a(1,1,45), & + diag_vmi_4 = p3a(1,1,46), & + diag_dmi_4 = p3a(1,1,47), & + diag_rhoi_4 = p3a(1,1,48), & + qit_5 = p3a(1,1,49), & + qni_5 = p3a(1,1,50), & + qir_5 = p3a(1,1,51), & + qib_5 = p3a(1,1,52), & + qzi_5 = p3a(1,1,53), & + diag_vmi_5 = p3a(1,1,54), & + diag_dmi_5 = p3a(1,1,55), & + diag_rhoi_5 = p3a(1,1,56), & + diag_dhmax_1 = p3a(1,1,57), & + diag_dhmax_2 = p3a(1,1,58), & + diag_dhmax_3 = p3a(1,1,59), & + diag_dhmax_4 = p3a(1,1,60), & + diag_dhmax_5 = p3a(1,1,61), & + diag2d_01 = p3a(1,1,62), & + diag2d_02 = p3a(1,1,63), & + diag3d_01 = p3a(1,1,64), & + diag3d_02 = p3a(1,1,65), & + diag3d_03 = p3a(1,1,66), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,16) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr + q3d(i,j,k,10 ) = p3a(i,k, 5) ! qnr + q3d(i,j,k,9 ) = p3a(i,k,15) ! nc + q3d(i,j,k,nqi) = p3a(i,k,17) ! qit_1 + q3d(i,j,k,11 ) = p3a(i,k,18) ! qni_1 + q3d(i,j,k,12 ) = p3a(i,k,19) ! qir_1 + q3d(i,j,k,13 ) = p3a(i,k,20) ! qib_1 + q3d(i,j,k,26 ) = p3a(i,k,21) ! qzi_1 + q3d(i,j,k,5 ) = p3a(i,k,25) ! qit_2 + q3d(i,j,k,14 ) = p3a(i,k,26) ! qni_2 + q3d(i,j,k,15 ) = p3a(i,k,27) ! qir_2 + q3d(i,j,k,16 ) = p3a(i,k,28) ! qib_2 + q3d(i,j,k,27 ) = p3a(i,k,29) ! qzi_2 + q3d(i,j,k,6 ) = p3a(i,k,33) ! qit_3 + q3d(i,j,k,17 ) = p3a(i,k,34) ! qni_3 + q3d(i,j,k,18 ) = p3a(i,k,35) ! qir_3 + q3d(i,j,k,19 ) = p3a(i,k,36) ! qib_3 + q3d(i,j,k,28 ) = p3a(i,k,37) ! qzi_3 + q3d(i,j,k,7 ) = p3a(i,k,41) ! qit_4 + q3d(i,j,k,20 ) = p3a(i,k,42) ! qni_4 + q3d(i,j,k,21 ) = p3a(i,k,43) ! qir_4 + q3d(i,j,k,22 ) = p3a(i,k,44) ! qib_4 + q3d(i,j,k,29 ) = p3a(i,k,45) ! qzi_4 + q3d(i,j,k,8 ) = p3a(i,k,49) ! qit_5 + q3d(i,j,k,23 ) = p3a(i,k,50) ! qni_5 + q3d(i,j,k,24 ) = p3a(i,k,51) ! qir_5 + q3d(i,j,k,25 ) = p3a(i,k,52) ! qib_5 + q3d(i,j,k,30 ) = p3a(i,k,53) ! qzi_5 + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,22) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,23) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,24) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,57) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,30) ! vmi_2 + p3o(i,j,k, 6) = p3a(i,k,31) ! dmi_2 + p3o(i,j,k, 7) = p3a(i,k,32) ! rhoi_2 + p3o(i,j,k, 8) = p3a(i,k,58) ! dhmax_2 + + p3o(i,j,k, 9) = p3a(i,k,38) ! vmi_3 + p3o(i,j,k,10) = p3a(i,k,39) ! dmi_3 + p3o(i,j,k,11) = p3a(i,k,40) ! rhoi_3 + p3o(i,j,k,12) = p3a(i,k,59) ! dhmax_3 + + p3o(i,j,k,13) = p3a(i,k,46) ! vmi_4 + p3o(i,j,k,14) = p3a(i,k,47) ! dmi_4 + p3o(i,j,k,15) = p3a(i,k,48) ! rhoi_4 + p3o(i,j,k,16) = p3a(i,k,60) ! dhmax_4 + + p3o(i,j,k,17) = p3a(i,k,54) ! vmi_5 + p3o(i,j,k,18) = p3a(i,k,55) ! dmi_5 + p3o(i,j,k,19) = p3a(i,k,56) ! rhoi_5 + p3o(i,j,k,20) = p3a(i,k,61) ! dhmax_5 + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,62) + out2d(i,j,2) = p3a(i,1,63) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,64) + out3d(i,j,k,2) = p3a(i,k,65) + out3d(i,j,k,3) = p3a(i,k,66) + enddo + enddo + + ENDDO p3_jloop9 + + if (timestats.ge.1) time_microphy = time_microphy+mytime() + + ELSEIF (ptype.eq.65) THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 6-ice-category ! +!-------------------------------------------------------------------------------------! + + rdt = 1.0/dt + + p3_jloop10: DO j=1,nj + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,11 ) ! qnr + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,15) = q3d(i,j,k,10 ) ! nc + p3a(i,k,17) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,18) = q3d(i,j,k,12 ) ! qni_1 + p3a(i,k,19) = q3d(i,j,k,13 ) ! qir_1 + p3a(i,k,20) = q3d(i,j,k,14 ) ! qib_1 + p3a(i,k,21) = q3d(i,j,k,30 ) ! qzi_1 + p3a(i,k,25) = q3d(i,j,k,5 ) ! qit_2 + p3a(i,k,26) = q3d(i,j,k,15 ) ! qni_2 + p3a(i,k,27) = q3d(i,j,k,16 ) ! qir_2 + p3a(i,k,28) = q3d(i,j,k,17 ) ! qib_2 + p3a(i,k,29) = q3d(i,j,k,31 ) ! qzi_2 + p3a(i,k,33) = q3d(i,j,k,6 ) ! qit_3 + p3a(i,k,34) = q3d(i,j,k,18 ) ! qni_3 + p3a(i,k,35) = q3d(i,j,k,19 ) ! qir_3 + p3a(i,k,36) = q3d(i,j,k,20 ) ! qib_3 + p3a(i,k,37) = q3d(i,j,k,32 ) ! qzi_3 + p3a(i,k,41) = q3d(i,j,k,7 ) ! qit_4 + p3a(i,k,42) = q3d(i,j,k,21 ) ! qni_4 + p3a(i,k,43) = q3d(i,j,k,22 ) ! qir_4 + p3a(i,k,44) = q3d(i,j,k,23 ) ! qib_4 + p3a(i,k,45) = q3d(i,j,k,33 ) ! qzi_4 + p3a(i,k,49) = q3d(i,j,k,8 ) ! qit_5 + p3a(i,k,50) = q3d(i,j,k,24 ) ! qni_5 + p3a(i,k,51) = q3d(i,j,k,25 ) ! qir_5 + p3a(i,k,52) = q3d(i,j,k,26 ) ! qib_5 + p3a(i,k,53) = q3d(i,j,k,34 ) ! qzi_5 + p3a(i,k,57) = q3d(i,j,k,9 ) ! qit_6 + p3a(i,k,58) = q3d(i,j,k,27 ) ! qni_6 + p3a(i,k,59) = q3d(i,j,k,28 ) ! qir_6 + p3a(i,k,60) = q3d(i,j,k,29 ) ! qib_6 + p3a(i,k,61) = q3d(i,j,k,35 ) ! qzi_6 + enddo + enddo + + do i=1,ni + p3a(i,1,16) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,16), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 6, & + nc = p3a(1,1,15), & + qit_1 = p3a(1,1,17), & + qni_1 = p3a(1,1,18), & + qir_1 = p3a(1,1,19), & + qib_1 = p3a(1,1,20), & + qzi_1 = p3a(1,1,21), & + diag_vmi_1 = p3a(1,1,22), & + diag_dmi_1 = p3a(1,1,23), & + diag_rhoi_1 = p3a(1,1,24), & + qit_2 = p3a(1,1,25), & + qni_2 = p3a(1,1,26), & + qir_2 = p3a(1,1,27), & + qib_2 = p3a(1,1,28), & + qzi_2 = p3a(1,1,29), & + diag_vmi_2 = p3a(1,1,30), & + diag_dmi_2 = p3a(1,1,31), & + diag_rhoi_2 = p3a(1,1,32), & + qit_3 = p3a(1,1,33), & + qni_3 = p3a(1,1,34), & + qir_3 = p3a(1,1,35), & + qib_3 = p3a(1,1,36), & + qzi_3 = p3a(1,1,37), & + diag_vmi_3 = p3a(1,1,38), & + diag_dmi_3 = p3a(1,1,39), & + diag_rhoi_3 = p3a(1,1,40), & + qit_4 = p3a(1,1,41), & + qni_4 = p3a(1,1,42), & + qir_4 = p3a(1,1,43), & + qib_4 = p3a(1,1,44), & + qzi_4 = p3a(1,1,45), & + diag_vmi_4 = p3a(1,1,46), & + diag_dmi_4 = p3a(1,1,47), & + diag_rhoi_4 = p3a(1,1,48), & + qit_5 = p3a(1,1,49), & + qni_5 = p3a(1,1,50), & + qir_5 = p3a(1,1,51), & + qib_5 = p3a(1,1,52), & + qzi_5 = p3a(1,1,53), & + diag_vmi_5 = p3a(1,1,54), & + diag_dmi_5 = p3a(1,1,55), & + diag_rhoi_5 = p3a(1,1,56), & + qit_6 = p3a(1,1,57), & + qni_6 = p3a(1,1,58), & + qir_6 = p3a(1,1,59), & + qib_6 = p3a(1,1,60), & + qzi_6 = p3a(1,1,61), & + diag_vmi_6 = p3a(1,1,62), & + diag_dmi_6 = p3a(1,1,63), & + diag_rhoi_6 = p3a(1,1,64), & + diag_dhmax_1 = p3a(1,1,65), & + diag_dhmax_2 = p3a(1,1,66), & + diag_dhmax_3 = p3a(1,1,67), & + diag_dhmax_4 = p3a(1,1,68), & + diag_dhmax_5 = p3a(1,1,69), & + diag_dhmax_6 = p3a(1,1,70), & + diag2d_01 = p3a(1,1,71), & + diag2d_02 = p3a(1,1,72), & + diag3d_01 = p3a(1,1,73), & + diag3d_02 = p3a(1,1,74), & + diag3d_03 = p3a(1,1,75), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,16) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr + q3d(i,j,k,11 ) = p3a(i,k, 5) ! qnr + q3d(i,j,k,10 ) = p3a(i,k,15) ! nc + q3d(i,j,k,nqi) = p3a(i,k,17) ! qit_1 + q3d(i,j,k,12 ) = p3a(i,k,18) ! qni_1 + q3d(i,j,k,13 ) = p3a(i,k,19) ! qir_1 + q3d(i,j,k,14 ) = p3a(i,k,20) ! qib_1 + q3d(i,j,k,30 ) = p3a(i,k,21) ! qzi_1 + q3d(i,j,k,5 ) = p3a(i,k,25) ! qit_2 + q3d(i,j,k,15 ) = p3a(i,k,26) ! qni_2 + q3d(i,j,k,16 ) = p3a(i,k,27) ! qir_2 + q3d(i,j,k,17 ) = p3a(i,k,28) ! qib_2 + q3d(i,j,k,31 ) = p3a(i,k,29) ! qzi_2 + q3d(i,j,k,6 ) = p3a(i,k,33) ! qit_3 + q3d(i,j,k,18 ) = p3a(i,k,34) ! qni_3 + q3d(i,j,k,19 ) = p3a(i,k,35) ! qir_3 + q3d(i,j,k,20 ) = p3a(i,k,36) ! qib_3 + q3d(i,j,k,32 ) = p3a(i,k,37) ! qzi_3 + q3d(i,j,k,7 ) = p3a(i,k,41) ! qit_4 + q3d(i,j,k,21 ) = p3a(i,k,42) ! qni_4 + q3d(i,j,k,22 ) = p3a(i,k,43) ! qir_4 + q3d(i,j,k,23 ) = p3a(i,k,44) ! qib_4 + q3d(i,j,k,33 ) = p3a(i,k,45) ! qzi_4 + q3d(i,j,k,8 ) = p3a(i,k,49) ! qit_5 + q3d(i,j,k,24 ) = p3a(i,k,50) ! qni_5 + q3d(i,j,k,25 ) = p3a(i,k,51) ! qir_5 + q3d(i,j,k,26 ) = p3a(i,k,52) ! qib_5 + q3d(i,j,k,34 ) = p3a(i,k,53) ! qzi_5 + q3d(i,j,k,9 ) = p3a(i,k,57) ! qit_6 + q3d(i,j,k,27 ) = p3a(i,k,58) ! qni_6 + q3d(i,j,k,28 ) = p3a(i,k,59) ! qir_6 + q3d(i,j,k,29 ) = p3a(i,k,60) ! qib_6 + q3d(i,j,k,35 ) = p3a(i,k,61) ! qzi_6 + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,22) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,23) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,24) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,65) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,30) ! vmi_2 + p3o(i,j,k, 6) = p3a(i,k,31) ! dmi_2 + p3o(i,j,k, 7) = p3a(i,k,32) ! rhoi_2 + p3o(i,j,k, 8) = p3a(i,k,66) ! dhmax_2 + + p3o(i,j,k, 9) = p3a(i,k,38) ! vmi_3 + p3o(i,j,k,10) = p3a(i,k,39) ! dmi_3 + p3o(i,j,k,11) = p3a(i,k,40) ! rhoi_3 + p3o(i,j,k,12) = p3a(i,k,67) ! dhmax_3 + + p3o(i,j,k,13) = p3a(i,k,46) ! vmi_4 + p3o(i,j,k,14) = p3a(i,k,47) ! dmi_4 + p3o(i,j,k,15) = p3a(i,k,48) ! rhoi_4 + p3o(i,j,k,16) = p3a(i,k,68) ! dhmax_4 + + p3o(i,j,k,17) = p3a(i,k,54) ! vmi_5 + p3o(i,j,k,18) = p3a(i,k,55) ! dmi_5 + p3o(i,j,k,19) = p3a(i,k,56) ! rhoi_5 + p3o(i,j,k,20) = p3a(i,k,69) ! dhmax_5 + + p3o(i,j,k,21) = p3a(i,k,62) ! vmi_6 + p3o(i,j,k,22) = p3a(i,k,63) ! dmi_6 + p3o(i,j,k,23) = p3a(i,k,64) ! rhoi_6 + p3o(i,j,k,24) = p3a(i,k,70) ! dhmax_6 + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,71) + out2d(i,j,2) = p3a(i,1,72) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,73) + out3d(i,j,k,2) = p3a(i,k,74) + out3d(i,j,k,3) = p3a(i,k,75) + enddo + enddo + + ENDDO p3_jloop10 + + if (timestats.ge.1) time_microphy = time_microphy+mytime() + + ELSEIF (ptype.eq.66) THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 5-ice-category, liq-frac ! +!-------------------------------------------------------------------------------------! + + rdt = 1.0/dt + + p3_jloop11: DO j=1,nj + + dum1(:,:,:) = 0.0 + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,10 ) ! qnr + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,15) = q3d(i,j,k,9 ) ! nc + p3a(i,k,17) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,18) = q3d(i,j,k,11 ) ! qni_1 + p3a(i,k,19) = q3d(i,j,k,12 ) ! qir_1 + p3a(i,k,20) = q3d(i,j,k,13 ) ! qib_1 + p3a(i,k,21) = q3d(i,j,k,14 ) ! qzi_1 + p3a(i,k,22) = q3d(i,j,k,15 ) ! qli_1 + p3a(i,k,26) = q3d(i,j,k,5 ) ! qit_2 + p3a(i,k,27) = q3d(i,j,k,16 ) ! qni_2 + p3a(i,k,28) = q3d(i,j,k,17 ) ! qir_2 + p3a(i,k,29) = q3d(i,j,k,18 ) ! qib_2 + p3a(i,k,30) = q3d(i,j,k,19 ) ! qzi_2 + p3a(i,k,31) = q3d(i,j,k,20 ) ! qli_2 + p3a(i,k,35) = q3d(i,j,k,6 ) ! qit_3 + p3a(i,k,36) = q3d(i,j,k,21 ) ! qni_3 + p3a(i,k,37) = q3d(i,j,k,22 ) ! qir_3 + p3a(i,k,38) = q3d(i,j,k,23 ) ! qib_3 + p3a(i,k,39) = q3d(i,j,k,24 ) ! qzi_3 + p3a(i,k,40) = q3d(i,j,k,25 ) ! qli_3 + p3a(i,k,44) = q3d(i,j,k,7 ) ! qit_4 + p3a(i,k,45) = q3d(i,j,k,26 ) ! qni_4 + p3a(i,k,46) = q3d(i,j,k,27 ) ! qir_4 + p3a(i,k,47) = q3d(i,j,k,28 ) ! qib_4 + p3a(i,k,48) = q3d(i,j,k,29 ) ! qzi_4 + p3a(i,k,49) = q3d(i,j,k,30 ) ! qli_4 + p3a(i,k,53) = q3d(i,j,k,8 ) ! qit_5 + p3a(i,k,54) = q3d(i,j,k,31 ) ! qni_5 + p3a(i,k,55) = q3d(i,j,k,32 ) ! qir_5 + p3a(i,k,56) = q3d(i,j,k,33 ) ! qib_5 + p3a(i,k,57) = q3d(i,j,k,34 ) ! qzi_5 + p3a(i,k,58) = q3d(i,j,k,35 ) ! qli_5 + enddo + enddo + + do i=1,ni + p3a(i,1,16) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,16), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 5, & + nc = p3a(1,1,15), & + qit_1 = p3a(1,1,17), & + qni_1 = p3a(1,1,18), & + qir_1 = p3a(1,1,19), & + qib_1 = p3a(1,1,20), & + qzi_1 = p3a(1,1,21), & + qli_1 = p3a(1,1,22), & + diag_vmi_1 = p3a(1,1,23), & + diag_dmi_1 = p3a(1,1,24), & + diag_rhoi_1 = p3a(1,1,25), & + qit_2 = p3a(1,1,26), & + qni_2 = p3a(1,1,27), & + qir_2 = p3a(1,1,28), & + qib_2 = p3a(1,1,29), & + qzi_2 = p3a(1,1,30), & + qli_2 = p3a(1,1,31), & + diag_vmi_2 = p3a(1,1,32), & + diag_dmi_2 = p3a(1,1,33), & + diag_rhoi_2 = p3a(1,1,34), & + qit_3 = p3a(1,1,35), & + qni_3 = p3a(1,1,36), & + qir_3 = p3a(1,1,37), & + qib_3 = p3a(1,1,38), & + qzi_3 = p3a(1,1,39), & + qli_3 = p3a(1,1,40), & + diag_vmi_3 = p3a(1,1,41), & + diag_dmi_3 = p3a(1,1,42), & + diag_rhoi_3 = p3a(1,1,43), & + qit_4 = p3a(1,1,44), & + qni_4 = p3a(1,1,45), & + qir_4 = p3a(1,1,46), & + qib_4 = p3a(1,1,47), & + qzi_4 = p3a(1,1,48), & + qli_4 = p3a(1,1,49), & + diag_vmi_4 = p3a(1,1,50), & + diag_dmi_4 = p3a(1,1,51), & + diag_rhoi_4 = p3a(1,1,52), & + qit_5 = p3a(1,1,53), & + qni_5 = p3a(1,1,54), & + qir_5 = p3a(1,1,55), & + qib_5 = p3a(1,1,56), & + qzi_5 = p3a(1,1,57), & + qli_5 = p3a(1,1,58), & + diag_vmi_5 = p3a(1,1,59), & + diag_dmi_5 = p3a(1,1,60), & + diag_rhoi_5 = p3a(1,1,61), & + diag_dhmax_1 = p3a(1,1,62), & + diag_dhmax_2 = p3a(1,1,63), & + diag_dhmax_3 = p3a(1,1,64), & + diag_dhmax_4 = p3a(1,1,65), & + diag_dhmax_5 = p3a(1,1,66), & + diag2d_01 = p3a(1,1,67), & + diag2d_02 = p3a(1,1,68), & + diag3d_01 = p3a(1,1,69), & + diag3d_02 = p3a(1,1,70), & + diag3d_03 = p3a(1,1,71), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,16) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr + q3d(i,j,k,10 ) = p3a(i,k, 5) ! qnr + q3d(i,j,k,9 ) = p3a(i,k,15) ! nc + q3d(i,j,k,nqi) = p3a(i,k,17) ! qit_1 + q3d(i,j,k,11 ) = p3a(i,k,18) ! qni_1 + q3d(i,j,k,12 ) = p3a(i,k,19) ! qir_1 + q3d(i,j,k,13 ) = p3a(i,k,20) ! qib_1 + q3d(i,j,k,14 ) = p3a(i,k,21) ! qzi_1 + q3d(i,j,k,15 ) = p3a(i,k,22) ! qli_1 + q3d(i,j,k,5 ) = p3a(i,k,26) ! qit_2 + q3d(i,j,k,16 ) = p3a(i,k,27) ! qni_2 + q3d(i,j,k,17 ) = p3a(i,k,28) ! qir_2 + q3d(i,j,k,18 ) = p3a(i,k,29) ! qib_2 + q3d(i,j,k,19 ) = p3a(i,k,30) ! qzi_2 + q3d(i,j,k,20 ) = p3a(i,k,31) ! qli_2 + q3d(i,j,k,6 ) = p3a(i,k,35) ! qit_3 + q3d(i,j,k,21 ) = p3a(i,k,36) ! qni_3 + q3d(i,j,k,22 ) = p3a(i,k,37) ! qir_3 + q3d(i,j,k,23 ) = p3a(i,k,38) ! qib_3 + q3d(i,j,k,24 ) = p3a(i,k,39) ! qzi_3 + q3d(i,j,k,25 ) = p3a(i,k,40) ! qli_3 + q3d(i,j,k,7 ) = p3a(i,k,44) ! qit_4 + q3d(i,j,k,26 ) = p3a(i,k,45) ! qni_4 + q3d(i,j,k,27 ) = p3a(i,k,46) ! qir_4 + q3d(i,j,k,28 ) = p3a(i,k,47) ! qib_4 + q3d(i,j,k,29 ) = p3a(i,k,48) ! qzi_4 + q3d(i,j,k,30 ) = p3a(i,k,49) ! qli_4 + q3d(i,j,k,8 ) = p3a(i,k,53) ! qit_5 + q3d(i,j,k,31 ) = p3a(i,k,54) ! qni_5 + q3d(i,j,k,32 ) = p3a(i,k,55) ! qir_5 + q3d(i,j,k,33 ) = p3a(i,k,56) ! qib_5 + q3d(i,j,k,34 ) = p3a(i,k,57) ! qzi_5 + q3d(i,j,k,35 ) = p3a(i,k,58) ! qli_5 + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,23) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,24) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,25) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,62) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,32) ! vmi_2 + p3o(i,j,k, 6) = p3a(i,k,33) ! dmi_2 + p3o(i,j,k, 7) = p3a(i,k,34) ! rhoi_2 + p3o(i,j,k, 8) = p3a(i,k,63) ! dhmax_2 + + p3o(i,j,k, 9) = p3a(i,k,41) ! vmi_3 + p3o(i,j,k,10) = p3a(i,k,42) ! dmi_3 + p3o(i,j,k,11) = p3a(i,k,43) ! rhoi_3 + p3o(i,j,k,12) = p3a(i,k,64) ! dhmax_3 + + p3o(i,j,k,13) = p3a(i,k,50) ! vmi_4 + p3o(i,j,k,14) = p3a(i,k,51) ! dmi_4 + p3o(i,j,k,15) = p3a(i,k,52) ! rhoi_4 + p3o(i,j,k,16) = p3a(i,k,65) ! dhmax_4 + + p3o(i,j,k,17) = p3a(i,k,59) ! vmi_5 + p3o(i,j,k,18) = p3a(i,k,60) ! dmi_5 + p3o(i,j,k,19) = p3a(i,k,61) ! rhoi_5 + p3o(i,j,k,20) = p3a(i,k,66) ! dhmax_5 + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,67) + out2d(i,j,2) = p3a(i,1,68) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,69) + out3d(i,j,k,2) = p3a(i,k,70) + out3d(i,j,k,3) = p3a(i,k,71) + enddo + enddo + + ENDDO p3_jloop11 + + if (timestats.ge.1) time_microphy = time_microphy+mytime() + + ELSEIF (ptype.eq.67) THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 6-ice-category, liq-frac ! +!-------------------------------------------------------------------------------------! + + rdt = 1.0/dt + + p3_jloop12: DO j=1,nj + + dum1(:,:,:) = 0.0 + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,11 ) ! qnr + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,15) = q3d(i,j,k,10 ) ! nc + p3a(i,k,17) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,18) = q3d(i,j,k,12 ) ! qni_1 + p3a(i,k,19) = q3d(i,j,k,13 ) ! qir_1 + p3a(i,k,20) = q3d(i,j,k,14 ) ! qib_1 + p3a(i,k,21) = q3d(i,j,k,15 ) ! qzi_1 + p3a(i,k,22) = q3d(i,j,k,16 ) ! qli_1 + p3a(i,k,26) = q3d(i,j,k,5 ) ! qit_2 + p3a(i,k,27) = q3d(i,j,k,17 ) ! qni_2 + p3a(i,k,28) = q3d(i,j,k,18 ) ! qir_2 + p3a(i,k,29) = q3d(i,j,k,19 ) ! qib_2 + p3a(i,k,30) = q3d(i,j,k,20 ) ! qzi_2 + p3a(i,k,31) = q3d(i,j,k,21 ) ! qli_2 + p3a(i,k,35) = q3d(i,j,k,6 ) ! qit_3 + p3a(i,k,36) = q3d(i,j,k,22 ) ! qni_3 + p3a(i,k,37) = q3d(i,j,k,23 ) ! qir_3 + p3a(i,k,38) = q3d(i,j,k,24 ) ! qib_3 + p3a(i,k,39) = q3d(i,j,k,25 ) ! qzi_3 + p3a(i,k,40) = q3d(i,j,k,26 ) ! qli_3 + p3a(i,k,44) = q3d(i,j,k,7 ) ! qit_4 + p3a(i,k,45) = q3d(i,j,k,27 ) ! qni_4 + p3a(i,k,46) = q3d(i,j,k,28 ) ! qir_4 + p3a(i,k,47) = q3d(i,j,k,29 ) ! qib_4 + p3a(i,k,48) = q3d(i,j,k,30 ) ! qzi_4 + p3a(i,k,49) = q3d(i,j,k,31 ) ! qli_4 + p3a(i,k,53) = q3d(i,j,k,8 ) ! qit_5 + p3a(i,k,54) = q3d(i,j,k,32 ) ! qni_5 + p3a(i,k,55) = q3d(i,j,k,33 ) ! qir_5 + p3a(i,k,56) = q3d(i,j,k,34 ) ! qib_5 + p3a(i,k,57) = q3d(i,j,k,35 ) ! qzi_5 + p3a(i,k,58) = q3d(i,j,k,36 ) ! qli_5 + p3a(i,k,62) = q3d(i,j,k,9 ) ! qit_6 + p3a(i,k,63) = q3d(i,j,k,37 ) ! qni_6 + p3a(i,k,64) = q3d(i,j,k,38 ) ! qir_6 + p3a(i,k,65) = q3d(i,j,k,39 ) ! qib_6 + p3a(i,k,66) = q3d(i,j,k,40 ) ! qzi_6 + p3a(i,k,67) = q3d(i,j,k,41 ) ! qli_6 + enddo + enddo + + do i=1,ni + p3a(i,1,16) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,16), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 6, & + nc = p3a(1,1,15), & + qit_1 = p3a(1,1,17), & + qni_1 = p3a(1,1,18), & + qir_1 = p3a(1,1,19), & + qib_1 = p3a(1,1,20), & + qzi_1 = p3a(1,1,21), & + qli_1 = p3a(1,1,22), & + diag_vmi_1 = p3a(1,1,23), & + diag_dmi_1 = p3a(1,1,24), & + diag_rhoi_1 = p3a(1,1,25), & + qit_2 = p3a(1,1,26), & + qni_2 = p3a(1,1,27), & + qir_2 = p3a(1,1,28), & + qib_2 = p3a(1,1,29), & + qzi_2 = p3a(1,1,30), & + qli_2 = p3a(1,1,31), & + diag_vmi_2 = p3a(1,1,32), & + diag_dmi_2 = p3a(1,1,33), & + diag_rhoi_2 = p3a(1,1,34), & + qit_3 = p3a(1,1,35), & + qni_3 = p3a(1,1,36), & + qir_3 = p3a(1,1,37), & + qib_3 = p3a(1,1,38), & + qzi_3 = p3a(1,1,39), & + qli_3 = p3a(1,1,40), & + diag_vmi_3 = p3a(1,1,41), & + diag_dmi_3 = p3a(1,1,42), & + diag_rhoi_3 = p3a(1,1,43), & + qit_4 = p3a(1,1,44), & + qni_4 = p3a(1,1,45), & + qir_4 = p3a(1,1,46), & + qib_4 = p3a(1,1,47), & + qzi_4 = p3a(1,1,48), & + qli_4 = p3a(1,1,49), & + diag_vmi_4 = p3a(1,1,50), & + diag_dmi_4 = p3a(1,1,51), & + diag_rhoi_4 = p3a(1,1,52), & + qit_5 = p3a(1,1,53), & + qni_5 = p3a(1,1,54), & + qir_5 = p3a(1,1,55), & + qib_5 = p3a(1,1,56), & + qzi_5 = p3a(1,1,57), & + qli_5 = p3a(1,1,58), & + diag_vmi_5 = p3a(1,1,59), & + diag_dmi_5 = p3a(1,1,60), & + diag_rhoi_5 = p3a(1,1,61), & + qit_6 = p3a(1,1,62), & + qni_6 = p3a(1,1,63), & + qir_6 = p3a(1,1,64), & + qib_6 = p3a(1,1,65), & + qzi_6 = p3a(1,1,66), & + qli_6 = p3a(1,1,67), & + diag_vmi_6 = p3a(1,1,68), & + diag_dmi_6 = p3a(1,1,69), & + diag_rhoi_6 = p3a(1,1,70), & + diag_dhmax_1 = p3a(1,1,71), & + diag_dhmax_2 = p3a(1,1,72), & + diag_dhmax_3 = p3a(1,1,73), & + diag_dhmax_4 = p3a(1,1,74), & + diag_dhmax_5 = p3a(1,1,75), & + diag_dhmax_6 = p3a(1,1,76), & + diag2d_01 = p3a(1,1,77), & + diag2d_02 = p3a(1,1,78), & + diag3d_01 = p3a(1,1,79), & + diag3d_02 = p3a(1,1,80), & + diag3d_03 = p3a(1,1,81), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,16) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr + q3d(i,j,k,11 ) = p3a(i,k, 5) ! qnr + q3d(i,j,k,10 ) = p3a(i,k,15) ! nc + q3d(i,j,k,nqi) = p3a(i,k,17) ! qit_1 + q3d(i,j,k,12 ) = p3a(i,k,18) ! qni_1 + q3d(i,j,k,13 ) = p3a(i,k,19) ! qir_1 + q3d(i,j,k,14 ) = p3a(i,k,20) ! qib_1 + q3d(i,j,k,15 ) = p3a(i,k,21) ! qzi_1 + q3d(i,j,k,16 ) = p3a(i,k,22) ! qli_1 + q3d(i,j,k,5 ) = p3a(i,k,26) ! qit_2 + q3d(i,j,k,17 ) = p3a(i,k,27) ! qni_2 + q3d(i,j,k,18 ) = p3a(i,k,28) ! qir_2 + q3d(i,j,k,19 ) = p3a(i,k,29) ! qib_2 + q3d(i,j,k,20 ) = p3a(i,k,30) ! qzi_2 + q3d(i,j,k,21 ) = p3a(i,k,31) ! qli_2 + q3d(i,j,k,6 ) = p3a(i,k,35) ! qit_3 + q3d(i,j,k,22 ) = p3a(i,k,36) ! qni_3 + q3d(i,j,k,23 ) = p3a(i,k,37) ! qir_3 + q3d(i,j,k,24 ) = p3a(i,k,38) ! qib_3 + q3d(i,j,k,25 ) = p3a(i,k,39) ! qzi_3 + q3d(i,j,k,26 ) = p3a(i,k,40) ! qli_3 + q3d(i,j,k,7 ) = p3a(i,k,44) ! qit_4 + q3d(i,j,k,27 ) = p3a(i,k,45) ! qni_4 + q3d(i,j,k,28 ) = p3a(i,k,46) ! qir_4 + q3d(i,j,k,29 ) = p3a(i,k,47) ! qib_4 + q3d(i,j,k,30 ) = p3a(i,k,48) ! qzi_4 + q3d(i,j,k,31 ) = p3a(i,k,49) ! qli_4 + q3d(i,j,k,8 ) = p3a(i,k,53) ! qit_5 + q3d(i,j,k,32 ) = p3a(i,k,54) ! qni_5 + q3d(i,j,k,33 ) = p3a(i,k,55) ! qir_5 + q3d(i,j,k,34 ) = p3a(i,k,56) ! qib_5 + q3d(i,j,k,35 ) = p3a(i,k,57) ! qzi_5 + q3d(i,j,k,36 ) = p3a(i,k,58) ! qli_5 + q3d(i,j,k,9 ) = p3a(i,k,62) ! qit_6 + q3d(i,j,k,37 ) = p3a(i,k,63) ! qni_6 + q3d(i,j,k,38 ) = p3a(i,k,64) ! qir_6 + q3d(i,j,k,39 ) = p3a(i,k,65) ! qib_6 + q3d(i,j,k,40 ) = p3a(i,k,66) ! qzi_6 + q3d(i,j,k,41 ) = p3a(i,k,67) ! qli_6 + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,23) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,24) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,25) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,71) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,32) ! vmi_2 + p3o(i,j,k, 6) = p3a(i,k,33) ! dmi_2 + p3o(i,j,k, 7) = p3a(i,k,34) ! rhoi_2 + p3o(i,j,k, 8) = p3a(i,k,72) ! dhmax_2 + + p3o(i,j,k, 9) = p3a(i,k,41) ! vmi_3 + p3o(i,j,k,10) = p3a(i,k,42) ! dmi_3 + p3o(i,j,k,11) = p3a(i,k,43) ! rhoi_3 + p3o(i,j,k,12) = p3a(i,k,73) ! dhmax_3 + + p3o(i,j,k,13) = p3a(i,k,50) ! vmi_4 + p3o(i,j,k,14) = p3a(i,k,51) ! dmi_4 + p3o(i,j,k,15) = p3a(i,k,52) ! rhoi_4 + p3o(i,j,k,16) = p3a(i,k,74) ! dhmax_4 + + p3o(i,j,k,17) = p3a(i,k,59) ! vmi_5 + p3o(i,j,k,18) = p3a(i,k,60) ! dmi_5 + p3o(i,j,k,19) = p3a(i,k,61) ! rhoi_5 + p3o(i,j,k,20) = p3a(i,k,75) ! dhmax_5 + + p3o(i,j,k,21) = p3a(i,k,68) ! vmi_6 + p3o(i,j,k,22) = p3a(i,k,69) ! dmi_6 + p3o(i,j,k,23) = p3a(i,k,70) ! rhoi_6 + p3o(i,j,k,24) = p3a(i,k,76) ! dhmax_6 + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,77) + out2d(i,j,2) = p3a(i,1,78) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,79) + out3d(i,j,k,2) = p3a(i,k,80) + out3d(i,j,k,3) = p3a(i,k,81) + enddo + enddo + + ENDDO p3_jloop12 + + if (timestats.ge.1) time_microphy = time_microphy+mytime() ! --- END OF CODE FOR P3 SCHEME --- diff --git a/src/param.F b/src/param.F index b7692fd..8691fe4 100644 --- a/src/param.F +++ b/src/param.F @@ -184,6 +184,22 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & integer :: p3_catdest_homorain_n2 = 2 integer :: p3_catdest_homorain_n3 = 2 integer :: p3_catdest_homorain_n4 = 2 + ! DTD: destinations for the 5- and 6-category configurations (ptype 64-67). + ! Defaults continue the progressive split of the _n2..._n4 series: with 5 + ! categories deposition nucleation gets its own category, and with 6 + ! homogeneous freezing of rain gets its own as well. + integer :: p3_catdest_contact_n5 = 4 + integer :: p3_catdest_contact_n6 = 4 + integer :: p3_catdest_rainimm_n5 = 2 + integer :: p3_catdest_rainimm_n6 = 2 + integer :: p3_catdest_rimesplinter_n5 = 3 + integer :: p3_catdest_rimesplinter_n6 = 3 + integer :: p3_catdest_depnuc_n5 = 5 + integer :: p3_catdest_depnuc_n6 = 5 + integer :: p3_catdest_homocloud_n5 = 1 + integer :: p3_catdest_homocloud_n6 = 1 + integer :: p3_catdest_homorain_n5 = 2 + integer :: p3_catdest_homorain_n6 = 6 ! ERM/DTD end #ifdef MPI integer :: ntmp1,ntmp2,ntmp3,ntmp4,reqs,reqs1,reqs2,reqs3,reqs4 @@ -249,7 +265,19 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_catdest_homocloud_n4, & p3_catdest_homorain_n2, & p3_catdest_homorain_n3, & - p3_catdest_homorain_n4 + p3_catdest_homorain_n4, & + p3_catdest_contact_n5, & + p3_catdest_contact_n6, & + p3_catdest_rainimm_n5, & + p3_catdest_rainimm_n6, & + p3_catdest_rimesplinter_n5, & + p3_catdest_rimesplinter_n6, & + p3_catdest_depnuc_n5, & + p3_catdest_depnuc_n6, & + p3_catdest_homocloud_n5, & + p3_catdest_homocloud_n6, & + p3_catdest_homorain_n5, & + p3_catdest_homorain_n6 NAMELIST /forcing/ & iforce, & @@ -411,7 +439,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & rewind(20) ENDIF ! ERM/DTD for p3_params - IF ( (ptype.ge.50 .and. ptype.le.54) .or. (ptype.ge.56 .and. ptype.le.63) ) THEN + IF ( (ptype.ge.50 .and. ptype.le.54) .or. (ptype.ge.56 .and. ptype.le.67) ) THEN read(20,nml=p3_params,end=752) 752 continue rewind(20) @@ -871,6 +899,18 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(p3_catdest_homorain_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_catdest_homorain_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_catdest_homorain_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_contact_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_contact_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rainimm_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rainimm_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rimesplinter_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rimesplinter_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_depnuc_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_depnuc_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homocloud_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homocloud_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homorain_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homorain_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) ! ERM/DTD end #endif @@ -1145,7 +1185,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ENDIF !----- IF( (ptype.eq.4.or.ptype.eq.50.or.ptype.eq.51.or.ptype.eq.52.or.ptype.eq.53.or.ptype.eq.54.or.ptype.eq.55.or.ptype.eq.56 & - .or.ptype.eq.57 .or.ptype.eq.60.or.ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) .and. eqtset.eq.2 )THEN + .or.ptype.eq.57 .or.ptype.eq.60.or.ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63 & + .or.ptype.eq.64 .or.ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) .and. eqtset.eq.2 )THEN if(myid.eq.0)then print *,' -------------------------------- ' print * @@ -2932,6 +2973,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & if( ptype.eq.61 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.62 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.63 ) param_mp = 'Predicted Particle Property (P3)' + if( ptype.eq.64 ) param_mp = 'Predicted Particle Property (P3)' + if( ptype.eq.65 ) param_mp = 'Predicted Particle Property (P3)' + if( ptype.eq.66 ) param_mp = 'Predicted Particle Property (P3)' + if( ptype.eq.67 ) param_mp = 'Predicted Particle Property (P3)' endif if( idoles )then ! LES subgrid: @@ -3233,7 +3278,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! write(outfile,*) 'ioldlimiter=',ioldlimiter ENDIF ! ERM/DTD for p3 - IF ( (ptype.ge.50 .and. ptype.le.54) .or. (ptype.ge.56 .and. ptype.le.63) ) THEN + IF ( (ptype.ge.50 .and. ptype.le.54) .or. (ptype.ge.56 .and. ptype.le.67) ) THEN write(outfile,NML=p3_params) ENDIF !-------------------------------------------------------------- @@ -4152,7 +4197,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ELSEIF( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.56 & - .or. ptype.eq.57 .or. ptype.eq.60 .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) THEN ! P3 + .or. ptype.eq.57 .or. ptype.eq.60 .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63 & + .or. ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) THEN ! P3 !----- initialize the P3 scheme ----- @@ -4423,6 +4469,130 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) + elseif( ptype.eq.64 )then + call p3_init(lookup_file_dir='.', & + nCat=5, & + trplMomI=.true., & + liqFrac=.false., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4, & + catdest_contact_n5_in=p3_catdest_contact_n5,catdest_contact_n6_in=p3_catdest_contact_n6, & + catdest_rainimm_n5_in=p3_catdest_rainimm_n5,catdest_rainimm_n6_in=p3_catdest_rainimm_n6, & + catdest_rimesplinter_n5_in=p3_catdest_rimesplinter_n5, & + catdest_rimesplinter_n6_in=p3_catdest_rimesplinter_n6, & + catdest_depnuc_n5_in=p3_catdest_depnuc_n5,catdest_depnuc_n6_in=p3_catdest_depnuc_n6, & + catdest_homocloud_n5_in=p3_catdest_homocloud_n5,catdest_homocloud_n6_in=p3_catdest_homocloud_n6, & + catdest_homorain_n5_in=p3_catdest_homorain_n5,catdest_homorain_n6_in=p3_catdest_homorain_n6 ) + elseif( ptype.eq.65 )then + call p3_init(lookup_file_dir='.', & + nCat=6, & + trplMomI=.true., & + liqFrac=.false., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4, & + catdest_contact_n5_in=p3_catdest_contact_n5,catdest_contact_n6_in=p3_catdest_contact_n6, & + catdest_rainimm_n5_in=p3_catdest_rainimm_n5,catdest_rainimm_n6_in=p3_catdest_rainimm_n6, & + catdest_rimesplinter_n5_in=p3_catdest_rimesplinter_n5, & + catdest_rimesplinter_n6_in=p3_catdest_rimesplinter_n6, & + catdest_depnuc_n5_in=p3_catdest_depnuc_n5,catdest_depnuc_n6_in=p3_catdest_depnuc_n6, & + catdest_homocloud_n5_in=p3_catdest_homocloud_n5,catdest_homocloud_n6_in=p3_catdest_homocloud_n6, & + catdest_homorain_n5_in=p3_catdest_homorain_n5,catdest_homorain_n6_in=p3_catdest_homorain_n6 ) + elseif( ptype.eq.66 )then + call p3_init(lookup_file_dir='.', & + nCat=5, & + trplMomI=.true., & + liqFrac=.true., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4, & + catdest_contact_n5_in=p3_catdest_contact_n5,catdest_contact_n6_in=p3_catdest_contact_n6, & + catdest_rainimm_n5_in=p3_catdest_rainimm_n5,catdest_rainimm_n6_in=p3_catdest_rainimm_n6, & + catdest_rimesplinter_n5_in=p3_catdest_rimesplinter_n5, & + catdest_rimesplinter_n6_in=p3_catdest_rimesplinter_n6, & + catdest_depnuc_n5_in=p3_catdest_depnuc_n5,catdest_depnuc_n6_in=p3_catdest_depnuc_n6, & + catdest_homocloud_n5_in=p3_catdest_homocloud_n5,catdest_homocloud_n6_in=p3_catdest_homocloud_n6, & + catdest_homorain_n5_in=p3_catdest_homorain_n5,catdest_homorain_n6_in=p3_catdest_homorain_n6 ) + elseif( ptype.eq.67 )then + call p3_init(lookup_file_dir='.', & + nCat=6, & + trplMomI=.true., & + liqFrac=.true., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4, & + catdest_contact_n5_in=p3_catdest_contact_n5,catdest_contact_n6_in=p3_catdest_contact_n6, & + catdest_rainimm_n5_in=p3_catdest_rainimm_n5,catdest_rainimm_n6_in=p3_catdest_rainimm_n6, & + catdest_rimesplinter_n5_in=p3_catdest_rimesplinter_n5, & + catdest_rimesplinter_n6_in=p3_catdest_rimesplinter_n6, & + catdest_depnuc_n5_in=p3_catdest_depnuc_n5,catdest_depnuc_n6_in=p3_catdest_depnuc_n6, & + catdest_homocloud_n5_in=p3_catdest_homocloud_n5,catdest_homocloud_n6_in=p3_catdest_homocloud_n6, & + catdest_homorain_n5_in=p3_catdest_homorain_n5,catdest_homorain_n6_in=p3_catdest_homorain_n6 ) endif if(dowr) write(outfile,*) 'Returned from P3_INIT' @@ -5472,6 +5642,653 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & np3a = np3a + nout2d + nout3d + 4 !(4 for dhmax_x) np3o = 16 ! 4 x nCat for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) + ELSEIF( ptype.eq.64 )THEN + + numq = 30 ! there are 30 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 8 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .true. + cloudvar( 8) = .true. + cloudvar( 9) = .false. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + cloudvar(21) = .false. + cloudvar(22) = .false. + cloudvar(23) = .false. + cloudvar(24) = .false. + cloudvar(25) = .false. + cloudvar(26) = .false. + cloudvar(27) = .false. + cloudvar(28) = .false. + cloudvar(29) = .false. + cloudvar(30) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'qi4' + qname( 8) = 'qi5' + qname( 9) = 'nc ' + qname(10) = 'nr ' + qname(11) = 'ni1' + qname(12) = 'ri1' + qname(13) = 'bi1' + qname(14) = 'ni2' + qname(15) = 'ri2' + qname(16) = 'bi2' + qname(17) = 'ni3' + qname(18) = 'ri3' + qname(19) = 'bi3' + qname(20) = 'ni4' + qname(21) = 'ri4' + qname(22) = 'bi4' + qname(23) = 'ni5' + qname(24) = 'ri5' + qname(25) = 'bi5' + qname(26) = 'zi1' + qname(27) = 'zi2' + qname(28) = 'zi3' + qname(29) = 'zi4' + qname(30) = 'zi5' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = 'kg/kg' + qunit( 8) = 'kg/kg' + qunit( 9) = '#/kg' + qunit(10) = '#/kg' + qunit(11) = '#/kg' + qunit(12) = 'kg/kg' + qunit(13) = 'm^-3 kg^-1' + qunit(14) = '#/kg' + qunit(15) = 'kg/kg' + qunit(16) = 'm^-3 kg^-1' + qunit(17) = '#/kg' + qunit(18) = 'kg/kg' + qunit(19) = 'm^-3 kg^-1' + qunit(20) = '#/kg' + qunit(21) = 'kg/kg' + qunit(22) = 'm^-3 kg^-1' + qunit(23) = '#/kg' + qunit(24) = 'kg/kg' + qunit(25) = 'm^-3 kg^-1' + qunit(26) = 'm^6/kg' + qunit(27) = 'm^6/kg' + qunit(28) = 'm^6/kg' + qunit(29) = 'm^6/kg' + qunit(30) = 'm^6/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 0.01 + qmag( 8) = 0.01 + qmag( 9) = 1.0e5 + qmag(10) = 1.0e5 + qmag(11) = 1.0e5 + qmag(12) = 0.01 + qmag(13) = 1.0e-5 + qmag(14) = 1.0e5 + qmag(15) = 0.01 + qmag(16) = 1.0e-5 + qmag(17) = 1.0e5 + qmag(18) = 0.01 + qmag(19) = 1.0e-5 + qmag(20) = 1.0e5 + qmag(21) = 0.01 + qmag(22) = 1.0e-5 + qmag(23) = 1.0e5 + qmag(24) = 0.01 + qmag(25) = 1.0e-5 + qmag(26) = 1.0e-3 + qmag(27) = 1.0e-3 + qmag(28) = 1.0e-3 + qmag(29) = 1.0e-3 + qmag(30) = 1.0e-3 + + ! for p3 arrays: + np3a = 56 ! 3-mom, no_liqfrac, 5-cat (no extra output) + np3a = np3a + nout2d + nout3d + 5 !(5 for dhmax_x) + np3o = 20 ! 4 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) + + ELSEIF( ptype.eq.65 )THEN + + numq = 35 ! there are 35 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 9 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .true. + cloudvar( 8) = .true. + cloudvar( 9) = .true. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + cloudvar(21) = .false. + cloudvar(22) = .false. + cloudvar(23) = .false. + cloudvar(24) = .false. + cloudvar(25) = .false. + cloudvar(26) = .false. + cloudvar(27) = .false. + cloudvar(28) = .false. + cloudvar(29) = .false. + cloudvar(30) = .false. + cloudvar(31) = .false. + cloudvar(32) = .false. + cloudvar(33) = .false. + cloudvar(34) = .false. + cloudvar(35) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'qi4' + qname( 8) = 'qi5' + qname( 9) = 'qi6' + qname(10) = 'nc ' + qname(11) = 'nr ' + qname(12) = 'ni1' + qname(13) = 'ri1' + qname(14) = 'bi1' + qname(15) = 'ni2' + qname(16) = 'ri2' + qname(17) = 'bi2' + qname(18) = 'ni3' + qname(19) = 'ri3' + qname(20) = 'bi3' + qname(21) = 'ni4' + qname(22) = 'ri4' + qname(23) = 'bi4' + qname(24) = 'ni5' + qname(25) = 'ri5' + qname(26) = 'bi5' + qname(27) = 'ni6' + qname(28) = 'ri6' + qname(29) = 'bi6' + qname(30) = 'zi1' + qname(31) = 'zi2' + qname(32) = 'zi3' + qname(33) = 'zi4' + qname(34) = 'zi5' + qname(35) = 'zi6' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = 'kg/kg' + qunit( 8) = 'kg/kg' + qunit( 9) = 'kg/kg' + qunit(10) = '#/kg' + qunit(11) = '#/kg' + qunit(12) = '#/kg' + qunit(13) = 'kg/kg' + qunit(14) = 'm^-3 kg^-1' + qunit(15) = '#/kg' + qunit(16) = 'kg/kg' + qunit(17) = 'm^-3 kg^-1' + qunit(18) = '#/kg' + qunit(19) = 'kg/kg' + qunit(20) = 'm^-3 kg^-1' + qunit(21) = '#/kg' + qunit(22) = 'kg/kg' + qunit(23) = 'm^-3 kg^-1' + qunit(24) = '#/kg' + qunit(25) = 'kg/kg' + qunit(26) = 'm^-3 kg^-1' + qunit(27) = '#/kg' + qunit(28) = 'kg/kg' + qunit(29) = 'm^-3 kg^-1' + qunit(30) = 'm^6/kg' + qunit(31) = 'm^6/kg' + qunit(32) = 'm^6/kg' + qunit(33) = 'm^6/kg' + qunit(34) = 'm^6/kg' + qunit(35) = 'm^6/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 0.01 + qmag( 8) = 0.01 + qmag( 9) = 0.01 + qmag(10) = 1.0e5 + qmag(11) = 1.0e5 + qmag(12) = 1.0e5 + qmag(13) = 0.01 + qmag(14) = 1.0e-5 + qmag(15) = 1.0e5 + qmag(16) = 0.01 + qmag(17) = 1.0e-5 + qmag(18) = 1.0e5 + qmag(19) = 0.01 + qmag(20) = 1.0e-5 + qmag(21) = 1.0e5 + qmag(22) = 0.01 + qmag(23) = 1.0e-5 + qmag(24) = 1.0e5 + qmag(25) = 0.01 + qmag(26) = 1.0e-5 + qmag(27) = 1.0e5 + qmag(28) = 0.01 + qmag(29) = 1.0e-5 + qmag(30) = 1.0e-3 + qmag(31) = 1.0e-3 + qmag(32) = 1.0e-3 + qmag(33) = 1.0e-3 + qmag(34) = 1.0e-3 + qmag(35) = 1.0e-3 + + ! for p3 arrays: + np3a = 64 ! 3-mom, no_liqfrac, 6-cat (no extra output) + np3a = np3a + nout2d + nout3d + 6 !(6 for dhmax_x) + np3o = 24 ! 4 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) + + ELSEIF( ptype.eq.66 )THEN + + numq = 35 ! there are 35 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 8 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .true. + cloudvar( 8) = .true. + cloudvar( 9) = .false. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + cloudvar(21) = .false. + cloudvar(22) = .false. + cloudvar(23) = .false. + cloudvar(24) = .false. + cloudvar(25) = .false. + cloudvar(26) = .false. + cloudvar(27) = .false. + cloudvar(28) = .false. + cloudvar(29) = .false. + cloudvar(30) = .false. + cloudvar(31) = .false. + cloudvar(32) = .false. + cloudvar(33) = .false. + cloudvar(34) = .false. + cloudvar(35) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'qi4' + qname( 8) = 'qi5' + qname( 9) = 'nc ' + qname(10) = 'nr ' + qname(11) = 'ni1' + qname(12) = 'ri1' + qname(13) = 'bi1' + qname(14) = 'zi1' + qname(15) = 'li1' + qname(16) = 'ni2' + qname(17) = 'ri2' + qname(18) = 'bi2' + qname(19) = 'zi2' + qname(20) = 'li2' + qname(21) = 'ni3' + qname(22) = 'ri3' + qname(23) = 'bi3' + qname(24) = 'zi3' + qname(25) = 'li3' + qname(26) = 'ni4' + qname(27) = 'ri4' + qname(28) = 'bi4' + qname(29) = 'zi4' + qname(30) = 'li4' + qname(31) = 'ni5' + qname(32) = 'ri5' + qname(33) = 'bi5' + qname(34) = 'zi5' + qname(35) = 'li5' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = 'kg/kg' + qunit( 8) = 'kg/kg' + qunit( 9) = '#/kg' + qunit(10) = '#/kg' + qunit(11) = '#/kg' + qunit(12) = 'kg/kg' + qunit(13) = 'm^-3 kg^-1' + qunit(14) = 'm^6 kg^-1' + qunit(15) = 'kg/kg' + qunit(16) = '#/kg' + qunit(17) = 'kg/kg' + qunit(18) = 'm^-3 kg^-1' + qunit(19) = 'm^6 kg^-1' + qunit(20) = 'kg/kg' + qunit(21) = '#/kg' + qunit(22) = 'kg/kg' + qunit(23) = 'm^-3 kg^-1' + qunit(24) = 'm^6 kg^-1' + qunit(25) = 'kg/kg' + qunit(26) = '#/kg' + qunit(27) = 'kg/kg' + qunit(28) = 'm^-3 kg^-1' + qunit(29) = 'm^6 kg^-1' + qunit(30) = 'kg/kg' + qunit(31) = '#/kg' + qunit(32) = 'kg/kg' + qunit(33) = 'm^-3 kg^-1' + qunit(34) = 'm^6 kg^-1' + qunit(35) = 'kg/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 0.01 + qmag( 8) = 0.01 + qmag( 9) = 1.0e5 + qmag(10) = 1.0e5 + qmag(11) = 1.0e5 + qmag(12) = 0.01 + qmag(13) = 1.0e-5 + qmag(14) = 1.0e-3 + qmag(15) = 0.01 + qmag(16) = 1.0e5 + qmag(17) = 0.01 + qmag(18) = 1.0e-5 + qmag(19) = 1.0e-3 + qmag(20) = 0.01 + qmag(21) = 1.0e5 + qmag(22) = 0.01 + qmag(23) = 1.0e-5 + qmag(24) = 1.0e-3 + qmag(25) = 0.01 + qmag(26) = 1.0e5 + qmag(27) = 0.01 + qmag(28) = 1.0e-5 + qmag(29) = 1.0e-3 + qmag(30) = 0.01 + qmag(31) = 1.0e5 + qmag(32) = 0.01 + qmag(33) = 1.0e-5 + qmag(34) = 1.0e-3 + qmag(35) = 0.01 + + ! for p3 arrays: + np3a = 61 ! 3-mom, liqfrac, 5-cat (no extra output) + np3a = np3a + nout2d + nout3d + 5 !(5 for dhmax_x) + np3o = 20 ! 4 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) + + ELSEIF( ptype.eq.67 )THEN + + numq = 41 ! there are 41 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 9 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .true. + cloudvar( 8) = .true. + cloudvar( 9) = .true. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + cloudvar(21) = .false. + cloudvar(22) = .false. + cloudvar(23) = .false. + cloudvar(24) = .false. + cloudvar(25) = .false. + cloudvar(26) = .false. + cloudvar(27) = .false. + cloudvar(28) = .false. + cloudvar(29) = .false. + cloudvar(30) = .false. + cloudvar(31) = .false. + cloudvar(32) = .false. + cloudvar(33) = .false. + cloudvar(34) = .false. + cloudvar(35) = .false. + cloudvar(36) = .false. + cloudvar(37) = .false. + cloudvar(38) = .false. + cloudvar(39) = .false. + cloudvar(40) = .false. + cloudvar(41) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'qi4' + qname( 8) = 'qi5' + qname( 9) = 'qi6' + qname(10) = 'nc ' + qname(11) = 'nr ' + qname(12) = 'ni1' + qname(13) = 'ri1' + qname(14) = 'bi1' + qname(15) = 'zi1' + qname(16) = 'li1' + qname(17) = 'ni2' + qname(18) = 'ri2' + qname(19) = 'bi2' + qname(20) = 'zi2' + qname(21) = 'li2' + qname(22) = 'ni3' + qname(23) = 'ri3' + qname(24) = 'bi3' + qname(25) = 'zi3' + qname(26) = 'li3' + qname(27) = 'ni4' + qname(28) = 'ri4' + qname(29) = 'bi4' + qname(30) = 'zi4' + qname(31) = 'li4' + qname(32) = 'ni5' + qname(33) = 'ri5' + qname(34) = 'bi5' + qname(35) = 'zi5' + qname(36) = 'li5' + qname(37) = 'ni6' + qname(38) = 'ri6' + qname(39) = 'bi6' + qname(40) = 'zi6' + qname(41) = 'li6' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = 'kg/kg' + qunit( 8) = 'kg/kg' + qunit( 9) = 'kg/kg' + qunit(10) = '#/kg' + qunit(11) = '#/kg' + qunit(12) = '#/kg' + qunit(13) = 'kg/kg' + qunit(14) = 'm^-3 kg^-1' + qunit(15) = 'm^6 kg^-1' + qunit(16) = 'kg/kg' + qunit(17) = '#/kg' + qunit(18) = 'kg/kg' + qunit(19) = 'm^-3 kg^-1' + qunit(20) = 'm^6 kg^-1' + qunit(21) = 'kg/kg' + qunit(22) = '#/kg' + qunit(23) = 'kg/kg' + qunit(24) = 'm^-3 kg^-1' + qunit(25) = 'm^6 kg^-1' + qunit(26) = 'kg/kg' + qunit(27) = '#/kg' + qunit(28) = 'kg/kg' + qunit(29) = 'm^-3 kg^-1' + qunit(30) = 'm^6 kg^-1' + qunit(31) = 'kg/kg' + qunit(32) = '#/kg' + qunit(33) = 'kg/kg' + qunit(34) = 'm^-3 kg^-1' + qunit(35) = 'm^6 kg^-1' + qunit(36) = 'kg/kg' + qunit(37) = '#/kg' + qunit(38) = 'kg/kg' + qunit(39) = 'm^-3 kg^-1' + qunit(40) = 'm^6 kg^-1' + qunit(41) = 'kg/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 0.01 + qmag( 8) = 0.01 + qmag( 9) = 0.01 + qmag(10) = 1.0e5 + qmag(11) = 1.0e5 + qmag(12) = 1.0e5 + qmag(13) = 0.01 + qmag(14) = 1.0e-5 + qmag(15) = 1.0e-3 + qmag(16) = 0.01 + qmag(17) = 1.0e5 + qmag(18) = 0.01 + qmag(19) = 1.0e-5 + qmag(20) = 1.0e-3 + qmag(21) = 0.01 + qmag(22) = 1.0e5 + qmag(23) = 0.01 + qmag(24) = 1.0e-5 + qmag(25) = 1.0e-3 + qmag(26) = 0.01 + qmag(27) = 1.0e5 + qmag(28) = 0.01 + qmag(29) = 1.0e-5 + qmag(30) = 1.0e-3 + qmag(31) = 0.01 + qmag(32) = 1.0e5 + qmag(33) = 0.01 + qmag(34) = 1.0e-5 + qmag(35) = 1.0e-3 + qmag(36) = 0.01 + qmag(37) = 1.0e5 + qmag(38) = 0.01 + qmag(39) = 1.0e-5 + qmag(40) = 1.0e-3 + qmag(41) = 0.01 + + ! for p3 arrays: + np3a = 70 ! 3-mom, liqfrac, 6-cat (no extra output) + np3a = np3a + nout2d + nout3d + 6 !(6 for dhmax_x) + np3o = 24 ! 4 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) ENDIF !cccccccccccccccccccccccccccccccccccccccccccccccccccc! @@ -6331,7 +7148,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & if( imoist.eq.1 .and. ( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. & ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.55 .or. ptype.eq.56 .or. & ptype.eq.57 .or. ptype.eq.60 .or. & - ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) )then + ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63 .or. & + ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) )then ibp3 = 1 iep3 = ni jbp3 = 1 diff --git a/src/radiation_driver.F b/src/radiation_driver.F index 3e9b506..204b719 100644 --- a/src/radiation_driver.F +++ b/src/radiation_driver.F @@ -478,7 +478,8 @@ subroutine radiation_driver(mtime,radtim,dt,rbufsz,xh,yh,xf,yf,zf,rmh,c1,c2, endif if( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. & ptype.eq.56 .or. ptype.eq.57 .or. ptype.eq.60 & - .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63)then + .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63 & + .or. ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67)then ! P3 microphysics ! use eff arrays from P3 scheme: mp_physics = ptype diff --git a/src/writeout.F b/src/writeout.F index 2792bb4..e1239f5 100644 --- a/src/writeout.F +++ b/src/writeout.F @@ -3658,7 +3658,7 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, if (output_q.eq.1) then if ( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. & ptype.eq.56 .or. ptype.eq.57 .or.ptype.eq.60 .or. ptype.eq.61 .or. ptype.eq.62 .or. & - ptype.eq.63) then + ptype.eq.63 .or. ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi1' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 1' @@ -3730,7 +3730,8 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then if (ptype.eq.52 .or. ptype.eq.54 .or. ptype.eq.56 .or. ptype.eq.57 .or.ptype.eq.61 .or. & - ptype.eq. 62 .or. ptype.eq.63) then + ptype.eq. 62 .or. ptype.eq.63 .or. ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. & + ptype.eq.67) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi2' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 2' @@ -3802,7 +3803,8 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then - if (ptype.eq. 56 .or. ptype.eq.57 .or. ptype.eq.62 .or. ptype.eq.63) then + if (ptype.eq. 56 .or. ptype.eq.57 .or. ptype.eq.62 .or. ptype.eq.63 .or. & + ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi3' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 3' @@ -3876,7 +3878,8 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then - if (ptype.eq. 57 .or. ptype.eq.63) then + if (ptype.eq. 57 .or. ptype.eq.63 .or. & + ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi4' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 4' @@ -3947,6 +3950,158 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, endif ENDIF + !............................................. + + IF( imoist.eq.1 .and. numq.gt.1 )THEN + if (output_q.eq.1) then + if (ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) then + n_out = n_out + 1 + name_output(n_out) = 'p3_vmi5' + desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 5' + unit_output(n_out) = 'm/s' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,17) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_dmi5' + desc_output(n_out) = 'P3: mass-weighted mean diameter, ice category 5' + unit_output(n_out) = 'm' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,18) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_rhoi5' + desc_output(n_out) = 'P3: mean ice density, ice category 5' + unit_output(n_out) = 'kg/m3' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,19) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_dhmax5' + desc_output(n_out) = 'P3: max. hail size, ice category 5' + unit_output(n_out) = 'm' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,20) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + endif + endif + ENDIF + + !............................................. + + IF( imoist.eq.1 .and. numq.gt.1 )THEN + if (output_q.eq.1) then + if (ptype.eq.65 .or. ptype.eq.67) then + n_out = n_out + 1 + name_output(n_out) = 'p3_vmi6' + desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 6' + unit_output(n_out) = 'm/s' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,21) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_dmi6' + desc_output(n_out) = 'P3: mass-weighted mean diameter, ice category 6' + unit_output(n_out) = 'm' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,22) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_rhoi6' + desc_output(n_out) = 'P3: mean ice density, ice category 6' + unit_output(n_out) = 'kg/m3' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,23) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_dhmax6' + desc_output(n_out) = 'P3: max. hail size, ice category 6' + unit_output(n_out) = 'm' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,24) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + endif + endif + ENDIF + ! end P3 diagnostics !-------------------------------------------------------------------------------- ! begin ISHMAEL diagnostics From aff34133bffaedef57383fa83d81935b7264edad Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 27 Jul 2026 11:41:51 -0400 Subject: [PATCH 21/25] Add CLAUDE.md and ignore machine-specific Claude Code settings CLAUDE.md records the things that are non-obvious from the tree: that src/Makefile is the active build config and needs NETCDFC_DIR/NETCDF4_DIR/ HDF5_DIR in the environment, that src/*.f90 and run/onefile.F are generated and must not be edited, the P3 ptype table and the set of files a new configuration touches, the run-directory lookup-table requirements, and a pointer to NOTES.md plus the surviving p3_chksum/p3_chkpts tooling. .gitignore: .claude/settings.local.json holds the netCDF/HDF5 paths for whichever machine the checkout lives on, so it stays untracked. Co-Authored-By: Claude Opus 5 --- .gitignore | 3 ++ CLAUDE.md | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 93 insertions(+) create mode 100644 CLAUDE.md diff --git a/.gitignore b/.gitignore index 280e4c4..47dced5 100644 --- a/.gitignore +++ b/.gitignore @@ -42,3 +42,6 @@ qr_acr*dat # CM1 processes the .F files into .f90 during the build process so we should ignore # these too *.f90 + +# Claude Code machine-specific settings (netCDF/HDF5 paths differ per machine) +.claude/settings.local.json diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..0b7c180 --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,90 @@ +# CM1 r21.0 — P3 microphysics working copy + +CM1 (Bryan cloud model) with heavy local modifications to the P3 (Predicted +Particle Properties) microphysics scheme. Working branch `P3_work`; main branch +is `master`. Several sibling worktrees of the same repo exist under +`~/Projects/cm1r21.0*` — check `git worktree list` before assuming a path. + +## Building + +```bash +cd src && make +``` + +Links the executable to `run/cm1.exe`. + +- `src/Makefile` is the **active** build config — a copy of one of the + `Makefile_` variants with the hardware section uncommented. Current + settings: `mpif90` (gfortran), `-ffree-form -ffree-line-length-none -O2 + -finline-functions`, `-DMPI`. Variants in the tree: `Makefile_laptop_mpi`, + `Makefile_laptop_single`, `Makefile_bell`, `Makefile_derecho`. +- The laptop Makefiles need `NETCDFC_DIR`, `NETCDF4_DIR` and `HDF5_DIR` in the + environment. These are Homebrew prefixes on this machine and are supplied to + Claude Code via `.claude/settings.local.json` (gitignored, machine-specific). + Without them the netCDF-using files fail with `Cannot open module file + 'netcdf.mod'`. `Makefile_bell` uses different variable names + (`NETCDF_FORTRAN_HOME` etc.); `Makefile_derecho` uses `NETCDF`. +- Debug builds (used for FP-trap hunts) swap `OPTS` for + `-O0 -g -ffpe-trap=invalid -fcheck=bounds` and require a full rebuild. + +### Generated files — never edit these + +- `src/*.f90` — cpp output from the corresponding `.F`. Edit only the `.F`. +- `run/onefile.F` — a concatenation of all sources, regenerated by every `make`. + Gitignored. Grep hits here are duplicates of `src/`; ignore them. + +## P3 configurations (`ptype` in `¶m2`) + +All are 2-moment cloud water and rain. Ice-category count, moment count and +liquid-fraction prediction are baked into the ptype: + +| ptype | ice cats | ice moments | liqFrac | +|-------|----------|-------------|---------| +| 50–53 | 1–2 | 1–3 mom | no | +| 54, 56, 57 | 2, 3, 4 | 3-mom | no | +| 60–63 | 1, 2, 3, 4 | 3-mom | yes | +| 64, 65 | 5, 6 | 3-mom | no | +| 66, 67 | 5, 6 | 3-mom | yes | + +Adding or changing a P3 configuration touches, at minimum: `src/param.F` +(ptype range tests, `param_mp` name, the `p3_init` dispatch, and the +`numq`/`qname`/`qunit`/`qmag`/`cloudvar`/`np3a`/`np3o` block), `src/mp_driver.F` +(the per-ptype `p3a` pack/unpack and `mp_p3_wrapper_wrf` call), +`src/writeout.F` (per-category diagnostic output), and +`src/radiation_driver.F` (effective-radius ptype list). + +Scheme options live in the `&p3_params` namelist group (declared and broadcast +in `param.F`, applied in `p3_init`). With `p3_cat_init_new = .true.` the +destination category for each of the six ice-initiation mechanisms is set by +`p3_catdest__n`, where `N` is the number of ice categories in the +active configuration — so ptype 57 reads the `_n4` values, 64/66 the `_n5` +values, and 65/67 the `_n6` values. + +## Running + +`run/` needs the P3 lookup tables (`p3_lookupTable_1.dat-v6.7-{2,3}momI`, +`p3_lookupTable_2.dat-v6.1`) alongside `cm1.exe` and `namelist.input`. +`run/namelist.input` is a default/reference copy — it does **not** track the +configuration of any particular production run. + +Note that older executables will refuse a namelist containing `&p3_params` +keys they were not compiled with (`Cannot match namelist object name ...`), so +A/B runs against an older binary need the newer keys stripped. + +## Category-swap / bit-reproducibility investigation + +`NOTES.md` and `p3_category_swap_audit.md` are the running record of a long +investigation into why permuting P3 ice-category destination assignments broke +bit-identity. Read `NOTES.md` before touching category reductions or the +tendency-application code — several fixes there are load-bearing. In-tree +tooling kept from that work: + +- `p3_chksum` / `p3_chkpts` in `&p3_params` — per-timestep field checksums and + per-point raw dumps, written PRE and POST each `p3_main` call. +- `compare_p3_chksum.py` and `decode_point.sh` in the repo root. +- `qsum_invariant` in `&p3_params` — permutation-invariant host-side moisture + sums; needed for swap/invariance runs, default off. + +The general fix pattern for a category-order dependence is: replace a +fixed-slot-order category sum with a double-precision accumulate-then-round, or +a value-sorted `sortsumq` on the host side. From b9ba7899b1f77b69fb098007a85607c455f7ca84 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 27 Jul 2026 12:08:03 -0400 Subject: [PATCH 22/25] Bring NOTES.md current: ptypes 64-67, post-07-20 tree changes, deferred swap variance NOTES.md had not been touched since 11300ba and did not reflect four subsequent commits or this session's work. Added a dated section at the top (the file is newest-first) covering: - The new ptypes 64-67 (5- and 6-ice-category configurations), what had to change to support nCat>4, and the verification performed. Flags that the _n5/_n6 catdest defaults are a science choice needing review, and that ptype 64 is therefore not literally "ptype 57 with an inert 5th category". - The deferred swap-variance investigation: recorded as reported (smaller than the pre-fix divergence, cause unknown, log_iceice_interaction the first hypothesis rather than an established cause) so it is not lost. - The 07-21..07-25 commits: the Bell Makefile, the NSSL3M_Feb_2025 merge, log_maxnsmall, and the per-category max-Ni limiter (max_total_Ni -> max_Ni, impose_max_Ni, p3_nimax = -1 to disable). - That log_iceice_interaction now defaults .true., which the 07-20 bit-identity result did not cover -- the restructured cross-category path is invariant-ready but has never been verified under a swap test. Also flags three DTD-authored P3 changes that the NSSL3M merge reverted (the pre-P3 pdefq loops, dbrk 3000e-6 -> 600e-6, and the coll_3mom_LF rain gate nsmall -> 0, the last of which runs against the 2.1 gate-alignment work) as needing confirmation that the reversion was intended. Co-Authored-By: Claude Opus 5 --- NOTES.md | 114 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 113 insertions(+), 1 deletion(-) diff --git a/NOTES.md b/NOTES.md index faf068a..2d6f35b 100644 --- a/NOTES.md +++ b/NOTES.md @@ -2,7 +2,119 @@ Companion file to `p3_category_swap_audit.md` (the full audit report). This file records the follow-up discussion and the practical plan, for continuing work in -Claude Code. +Claude Code. Newest entries first. + +Build/run conventions that used to live only in people's heads are now in +`CLAUDE.md` (active Makefile, required netCDF/HDF5 environment variables, +generated files that must not be edited, the P3 ptype table). + +--- + +## UPDATE (2026-07-27) — new P3 configurations; state of the tree since 07-20 + +### New ptypes 64-67: 5- and 6-ice-category configurations + +Four new P3 configurations, taking the next free ptype numbers so existing ones +are untouched: + +| ptype | ice cats | ice moments | liqFrac | equivalent to | +|-------|----------|-------------|---------|---------------| +| 64 | 5 | 3-mom | no | ptype 57 + 1 category | +| 65 | 6 | 3-mom | no | ptype 57 + 2 categories | +| 66 | 5 | 3-mom | yes | ptype 63 + 1 category | +| 67 | 6 | 3-mom | yes | ptype 63 + 2 categories | + +P3's core was already generic in `nCat` — per-category arrays are allocatable, +`deltaD_init` already had `case (5)` and `case (6:)`, and `lookupTable_2` is +indexed by size/rime/density bins rather than by category — so the work was in +the category-destination dispatch and the CM1-side plumbing. The one real gap: +with `cat_init_new = .true.` the six `iice_dest` dispatch blocks only had +`nCat == 2/3/4` branches, so at nCat>4 `iice_dest` would have been left unset. +`catdest_*_n5` / `_n6` were added throughout (module vars, `p3_init` optional +args + clamping, all six dispatch sites, `param.F` namelist plumbing). + +**The `_n5`/`_n6` defaults are a science choice that should be reviewed before +these ptypes are used in anger.** They continue the progressive split of the +`_n2..._n4` series so that no category is left without a source: at nCat=5 +deposition nucleation moves to its own category (5), and at nCat=6 homogeneous +freezing of rain moves to its own as well (6). Everything else keeps its `_n4` +value. Consequence: **ptype 64 is not literally "ptype 57 with an inert 5th +category"** — depnuc moves from cat 4 to cat 5. Override via `&p3_params` +(`p3_catdest__n5` / `_n6`) if a different assignment is wanted. + +Also in this change: `mp_p3_wrapper_wrf` gained the `_5`/`_6` argument sets; +`diag_effi_ave`'s hard-coded `nCat<=4` expressions became a sequential loop +(same accumulation order, so nCat<=4 is unchanged bit-for-bit); `writeout.F` +gained `p3_{vmi,dmi,rhoi,dhmax}5/6`; ptype lists extended in `param.F`, +`writeout.F` and `radiation_driver.F`; `README.namelist` now documents 54, 56, +57 and 60-67 (it had only covered 50-53). + +Verification performed: full build clean; all four ptypes run with the expected +`numq`/`nqs2`/`qname` tables; a 2400 s ptype-65 run populates all six categories +(qi5 via deposition nucleation, qi6 via homogeneous rain freezing) and emits all +24 per-category diagnostics; **a 2400 s ptype-57 run is bit-identical +(`cm1out_s/u/v/w/stats`) against a binary built from the parent commit** — the +existing configurations are unaffected. + +Gotcha for A/B work: older executables reject a namelist containing `&p3_params` +keys they were not compiled with (`Cannot match namelist object name ...`), so +comparisons against an older binary need the new `_n5`/`_n6` keys stripped. + +### DEFERRED — swap variance has returned (smaller than before) + +Swapped-destination runs are once again showing some variance. Per DTD it is +**not as serious as the pre-fix divergence** and the investigation is +**deliberately deferred**. It may or may not be related to +`log_iceice_interaction` now defaulting to `.true.` (see below) — that is the +first hypothesis to test, not an established cause. No onset timestep, point or +field pattern has been recorded yet. + +When picking this up, the method from the 2026-07-20 handoff still applies +(`p3_chksum` bisection → `p3_chkpts` bracket → walk the tendency backwards), +and the ice-ice-specific guidance near the end of that section names the prime +suspects if interaction is indeed implicated. + +### Tree changes since NOTES.md was last updated (07-21 → 07-25) + +NOTES.md previously ended at commit `11300ba`. Four commits landed after it that +this file did not record: + +- `137e439` — Makefile for Bell. +- `b7dcda3` — manual merge of the NSSL3M_Feb_2025 branch. Mostly + `module_mp_nssl_2mom.F` plus a new `hail` accumulation array threaded through + `mp_driver.F` / `param.F` / `writeout.F` (`output_hail`). **It also touched + P3, reverting several DTD-authored changes — confirm these were intended:** + - the `pdefq` loops that ran ahead of every P3 call site in `mp_driver.F` are + now commented out (5 sites); + - `dbrk` went back to `600.e-6` (was `3000.e-6`, "Mod by DTD"); + - the rain gate in `access_lookup_table_coll_3mom_LF` went back to + `nr.gt.0` (was `nr.gt.nsmall`, "DTD changed from 0 to nsmall"). + + Note the last one runs against the 2.1 gate-alignment work recorded below, + which deliberately moved these thresholds onto `nsmall`. +- `84b472e` — `log_maxnsmall` back to `.true.` by default. +- `861737d` + `cd0ecce` — **per-category max-Ni limiter**, back-ported from a + later P3 version. `max_total_Ni` renamed `max_Ni`; new `impose_max_Ni` does a + straight `min(nitot, max_Ni*inv_rho)` per category, replacing the old + proportional across-all-categories rescaling (which could shrink the number of + a category that was already small, producing unrealistic mean sizes and + reflectivity). Called at the three sites where `impose_max_total_Ni` had been + commented out. Set `p3_nimax = -1` in the namelist (or `max_Ni` negative in + code) to disable the limiter entirely; the namelist value overrides the + in-code default. Note the maximum *total* concentration is now up to + `nCat*max_Ni`. + +### `log_iceice_interaction` now defaults `.true.` + +Both the `param.F` default and `run/namelist.input` now enable ice-ice +interaction. **The 2026-07-20 bit-identity result below was obtained with it +OFF.** The `iice_loop3` cross-category transfer and clip/densify code was +restructured to be invariant-*ready*, but that path has never been verified +under a swap test, so swap runs with interaction on are exercising untested +ground — a plausible connection to the deferred variance above. + +Also note `run/namelist.input` is a default/reference copy and does **not** +track the configuration of any particular production run. --- From d7fc86db302dbb1bc608f8fbff5ec8e0b5bf03cf Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Mon, 27 Jul 2026 12:55:58 -0400 Subject: [PATCH 23/25] Correct the subroutine name in the NSSL3M merge notes The 07-27 NOTES entry attributed the reverted scaled-mean-rain-size gate (nr.gt.nsmall -> nr.gt.0) to access_lookup_table_coll_3mom_LF. It is actually in find_lookupTable_indices_1b (module_mp_p3.F ~12354); the name came from a git diff hunk header, whose Fortran function detection had latched onto a much earlier subroutine. Also drops the claim that this revert runs against the 2.1 gate-alignment work. It does not: 2.1 moved the process-block and sedimentation gates onto nsmall, and this lookup-index gate was not among them. Reframes all three NSSL3M-merge reverts as deliberate, per DTD. Co-Authored-By: Claude Opus 5 --- NOTES.md | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/NOTES.md b/NOTES.md index 2d6f35b..a3e60f6 100644 --- a/NOTES.md +++ b/NOTES.md @@ -82,16 +82,17 @@ this file did not record: - `137e439` — Makefile for Bell. - `b7dcda3` — manual merge of the NSSL3M_Feb_2025 branch. Mostly `module_mp_nssl_2mom.F` plus a new `hail` accumulation array threaded through - `mp_driver.F` / `param.F` / `writeout.F` (`output_hail`). **It also touched - P3, reverting several DTD-authored changes — confirm these were intended:** + `mp_driver.F` / `param.F` / `writeout.F` (`output_hail`). It also reverted + three earlier DTD changes to P3 — **all three reversions were deliberate + (confirmed by DTD 2026-07-27)**, recorded here only so they are not later + mistaken for merge accidents: - the `pdefq` loops that ran ahead of every P3 call site in `mp_driver.F` are now commented out (5 sites); - `dbrk` went back to `600.e-6` (was `3000.e-6`, "Mod by DTD"); - - the rain gate in `access_lookup_table_coll_3mom_LF` went back to - `nr.gt.0` (was `nr.gt.nsmall`, "DTD changed from 0 to nsmall"). - - Note the last one runs against the 2.1 gate-alignment work recorded below, - which deliberately moved these thresholds onto `nsmall`. + - the scaled-mean-rain-size gate in `find_lookupTable_indices_1b` + (`module_mp_p3.F` ~12354) went back to `nr.gt.0` (was `nr.gt.nsmall`). + Note this is a lookup-index gate, distinct from the process-block and + sedimentation gates that the §2.1 fixes below moved onto `nsmall`. - `84b472e` — `log_maxnsmall` back to `.true.` by default. - `861737d` + `cd0ecce` — **per-category max-Ni limiter**, back-ported from a later P3 version. `max_total_Ni` renamed `max_Ni`; new `impose_max_Ni` does a From 48092bafb8dfad4bcb5517024d3ba98c392e5274 Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Sun, 2 Aug 2026 00:47:25 -0400 Subject: [PATCH 24/25] Add small-value gating switches and limiter instrumentation for P3 Grid-point noise in ptype-54 runs traces to a single pattern: the host delivers a hydrometeor species with mass but no number, and P3 manufactures the missing number (nsmall) rather than declining to act. That implies an absurd mean particle size, which the lookup-table index clamp then silently absorbs, so the failure is laundered into a legal table index and never reported. Confirmed independently for ice, rain and cloud; the root cause is upstream, in the host's transport of number concentration, and is untouched here. Two temporary A/B switches, both defaulting to existing behaviour: p3_nifloor .false. disables every nitot/nc floor (21 guarded sites) p3_nrfloor .false. disables every nr floor (15 guarded sites) With a floor off, the affected point keeps its mass and is rejected by nitot/nc/nr conditions on the downstream gates instead of running at an absurd size. Both exit clips were restructured so that their mass-clearing else branch still fires only on q < qsmall -- attaching the number condition to the outer test would relocate the clipping rather than remove it. Every floor is now owned by the switch for the variable it floors, including the log_maxnsmall floors. A floor sitting under a gate that tests a different variable silently breaks the invariant the downstream gates depend on; one such line produced -Inf + Inf and a hard fault. Instrumentation, following the existing p3_chksum/p3_chkpts pattern: p3_limlog, p3_limlog_rat per-firing log of every point-local limiter p3_dbg_i/j/k, p3_dbg_halo targeted point dump with phase checkpoints Also fixes an out-of-bounds access in mp_driver.F: qunit(lccn) was evaluated with lccn = 0 whenever p3_ccn_on = 0, and in an optimised build the guarded branch would then read and write q3d(i,j,k,0), a full 3-D slab before the array. Never A/B'd against an unpatched binary, so whether it was firing in production runs is unknown. Full record, including the wrong turns and the open items, is in p3_smallvalue_gating_notes.md. Co-Authored-By: Claude Opus 5 --- p3_smallvalue_gating_notes.md | 384 +++++++++++++++++++ src/module_mp_p3.F | 694 ++++++++++++++++++++++++++++++---- src/mp_driver.F | 53 ++- src/param.F | 41 +- 4 files changed, 1091 insertions(+), 81 deletions(-) create mode 100644 p3_smallvalue_gating_notes.md diff --git a/p3_smallvalue_gating_notes.md b/p3_smallvalue_gating_notes.md new file mode 100644 index 0000000..2286384 --- /dev/null +++ b/p3_smallvalue_gating_notes.md @@ -0,0 +1,384 @@ +# P3 small-value gating: grid-point noise investigation + +Running record of the 2026-08-01 session. Companion to `NOTES.md` (which covers +the separate category-swap / bit-reproducibility work). Read this before +touching any `qsmall` / `nsmall` test, floor, or gate in `src/module_mp_p3.F`. + +**Status:** all changes are uncommitted, syntax-checked, and exercised in short +(1500 s, 200-step) runs of the 2 km ptype-54 case. Nothing is committed. + +--- + +## 1. The problem + +Grid-point ("checkerboard") noise in ptype-54 storm simulations: isolated +spikes in pressure perturbation and theta, holes in the predicted moments, and +isolated bright pixels in diagnosed reflectivity — mostly aloft around the +edges of the ice field, but not only there. Not seen with the NSSL scheme in +the same model setup. + +## 2. The central insight + +Nearly every symptom traced to one structural pattern: + +> **The host delivers a hydrometeor species with mass but no number, and P3 +> responds by manufacturing the missing number rather than declining to act.** + +The manufactured number is always `nsmall = 1e-8 #/kg`, which for any real +mass implies an absurd mean particle size. Downstream, the lookup-table index +clamp (`dum1 = min(dum1, real(isize))`) silently absorbs the result, so the +failure is *laundered into a legal table index* and never reported. + +Three independent confirmations of the same shape: + +| species | how the broken state arrives | what P3 did about it | +|---|---|---| +| ice | host advection delivers `qitot > 0`, `nitot < 0` | `where(nitot<0) nitot=0`, then entry clip floors to `nsmall` | +| rain | same, `qr > 0`, `nr <= 0` | entry clip floors `nr` to `nsmall` | +| cloud | same, `qc > 0`, `nc = 0` | entry clip floors `nc` to `nsmall` | + +Measured: `PREQN` fired ~47,000 times/run for ice (100% with **negative** +`nitot` at the pack, before P3's own clamp zeroes it). `PREQR` fired ~49,000 +times for rain, a third of them with genuinely negative `nr`. + +**The root cause is upstream of P3, in the host's transport of number +concentration.** It is not fixed. Everything done this session changes how P3 +*responds* to it. + +## 3. `qsmall` / `nsmall` — the logic that matters + +Current values (`module_mp_p3.F`): + +``` +qsmall = 1.e-12 ! raised from P3's original 1.e-14 by ERM +nsmall = 1.e-8 ! raised from 1.e-16 by ERM +ntiny = nsmall ! comment suggests intent was nsmall*1e-8, i.e. smaller +``` + +### 3.1 Two alternative protections, and why that matters + +A hazard (division by number, `log` of number, a lookup keyed on `q/n`) can be +protected in two different ways: + +1. **A floor** — `n = max(n, nsmall)` — makes the value safe but *invents + number*, producing an absurd size. +2. **A gate** — `if (q >= qsmall .and. n >= nsmall)` — declines to act. + +The original upstream P3 had only floors. ERM and DTD added gates over time, so +the current tree has **both** in most places. That redundancy is why the floors +can be removed: the gates already do the job. But it is *not* uniform, and the +exceptions are where every bug in this session lived. + +### 3.2 The invariant, and how it breaks + +With floors disabled, the intended invariant after the entry clip is: + +> either `(q = 0, n = 0)` or `(q >= qsmall .and. n >= nsmall)` + +Every downstream gate depends on it. **A floor sitting under a gate that tests +a *different* variable silently breaks it.** That is the single most important +thing to know before editing this code. + +Concrete instance (cost a NaN crash and most of an evening): +`if (log_maxnsmall) nr(i,k) = max(nr(i,k),ntiny)` inside `qitot_notsmall_1`, +whose gate tests **`qitot`/`nitot` only**. Sequence: + +1. `get_rain_dsd2` declines (`nr < nsmall`) → `cdistr = 0`, `lamr = 0`. +2. That line floors `nr` to exactly `nsmall`. +3. A later consumer gate tests `nr >= nsmall` → passes on a DSD that was declined. +4. `log(cdistr=0) + (-6*log(lamr=0))` = `-Inf + Inf` = NaN → invalid operation. + +**Rule: a floor on variable X must be gated by the same switch that controls +X's floors, no matter which block it sits in.** All 6 `nr` floors are now under +`log_nrfloor`; all 8 `nitot` floors and the `nc` floors under `log_nifloor`. + +### 3.3 `if/else` structure is load-bearing + +Several `if (q >= qsmall …)` tests have an **`else` that destroys the mass** +(returns it to vapour). Attaching an `n` condition to such a test does not make +the point inert — it *destroys* it. Both exit clips are like this. + +Correct pattern (used in both exit blocks now): + +```fortran +if (q >= qsmall) then ! else clears the category + if (log_Xfloor .or. n >= nsmall) then ! guards lookups/diagnostics only + … + endif +else + …clear… +endif +``` + +I got this wrong on the rain exit block first time round; Daniel caught it. + +### 3.4 Threshold edits that cancelled each other + +- `qsmall` was raised to `1e-12` while the secondary clip criteria still read + `q < 1.e-12 .and. sup < -0.1`. Since `qsmall == 1e-12` the second clause is a + **no-op** — the "only clip if subsaturated" safety valve is dead. +- `if (qitot >= qsmall .and. qitot < 1.e-12 …)` is an **empty set**. That + small-warm-ice-to-rain conversion never fires. Originates in ERM's file. +- `log_maxnsmall` gates the *wrong* floors: the ones it switches sit inside + gates already requiring `n >= nsmall` (and `ntiny == nsmall`), so they are + provable no-ops; the entry-clip floors that actually act are **not** switched + by it. Setting `log_maxnsmall = .false.` is therefore not a test of anything. + +## 4. Code changes (all uncommitted) + +`src/module_mp_p3.F` (+694 lines), `src/mp_driver.F`, `src/param.F`. +`src/input.F` has unrelated whitespace-only changes that predate this session. + +### 4.1 New namelist options (`&p3_params`) + +| option | default | purpose | +|---|---|---| +| `p3_limlog` | `.false.` | limiter-firing log → `p3_limlog_NNNN.out` | +| `p3_limlog_rat` | `0.9` | record conservation-limiter firings only below this ratio | +| `p3_dbg_i/j/k` | `0` | targeted point dump → `p3_dbgpt_NNNN.out` (`<=0` disables) | +| `p3_dbg_halo` | `1` | half-width of the dumped block | +| **`p3_nifloor`** | `.true.` | **TEMPORARY** — `.false.` disables all `nitot`/`nc` floors | +| **`p3_nrfloor`** | `.true.` | **TEMPORARY** — `.false.` disables all `nr` floors | + +Both floor switches use the `log_Xfloor .or. …` short-circuit form so `.true.` +reproduces original behaviour. **Verified bit-identical for `p3_nifloor`.** +`p3_nrfloor = .true.` was verified bit-identical *before* the final +restructuring of the ice exit block — **re-verify both after the next build.** + +### 4.2 `p3_nifloor = .false.` — 21 guarded sites + +Entry-clip `nc` and `nitot` floors; `nc` conditions on five cloud gates +(`Vt_qc`/`D_c`, the `t<=269.15` block, `1./lamc**bcn`, `qc_not_small_1`, +`diag_effc`); `qc_not_small_2` (homogeneous freezing); `nitot` conditions on +the `k_loop_fz` and `qi_not_small_merge` gates; the restructured exit ice +block; and 8 `log_maxnsmall` `nitot` floors. Search `TEMPORARY (log_nifloor)`. + +### 4.3 `p3_nrfloor = .false.` — 15 guarded sites + +Entry-clip `nr` floor; `get_rain_dsd2`'s internal guard; `nr` conditions on the +three ice-collects-rain blocks, the `t<=269.15` rain-freezing block, rain +evaporation (`epsr`), and the exit rain block's DSD/`ze_rain` sub-block; and +6 `log_maxnsmall` `nr` floors. + +### 4.4 Bug fixed in passing + +`mp_driver.F`: `IF (trim(qunit(lccn)) /= 'none')` evaluated `qunit(0)` whenever +`p3_ccn_on = 0` (which sets `lccn = 0`). Out-of-bounds read; in an optimised +build the branch would then read *and write* `q3d(i,j,k,0)` — a full 3-D slab +before the array. Now `lccn > 0 .and. trim(qunit(max(lccn,1))) /= 'none'` at +four sites. **Never A/B'd against an unpatched binary**, so it is unknown +whether it was firing in production runs. + +### 4.5 `get_rain_dsd2` — `mu_r` was unset on the else path + +Its `else` set `lamr`, `cdistr`, `logn0r` but **not** `mu_r` (unlike +`get_cloud_dsd2`, which sets `mu_c = 0`). Harmless while the else only fired on +`qr < qsmall`; widening the guard would have left `mu_r` stale. Now sets +`mu_r = 0.`. + +## 5. Instrumentation + +### 5.1 Limiter-firing log (`p3_limlog`) + +`event it i j k (full grid) iice ratio v1 v2 v3 v4`, one line per firing. +Read-only; `.false.` leaves every path bit-identical. Events: + +- **`PREQN` / `PREQR`** *(host-side, `mp_driver`)* — what the host hands P3. + `PREQN` is a **sign** test (ice mass with `nitot <= 0`); `PREQR` a **ratio** + test (rain mean-mass diameter > `preqr_dmax = 1 mm`, hardcoded parameter). + The distinction matters: `PREQN` stayed silent through the entire 50 dBZ + episode because that rain had *small* number, not *zero*. +- **`NFLRC` / `NFLRR` / `NFLRI`** — an entry-clip floor condition was met. + Logged *before* the floor, so they record the condition, not the action. +- **`NGATE`** — ice category rejected by the `nitot >= nsmall` gate. +- **`CLIPR`** — now provably dead; kept as a canary. +- **`MAXNI`** — `impose_max_Ni` clipped `nitot`. +- **`RLAMX` / `RLAMN`** — rain lambda limiter pinned the spectrum at max/min + mean diameter. `iice` column carries the call site (1 = k-loop, + 2 = sedimentation, **3 = final diagnostics, the one feeding `ze_rain`**). + Useful identity: **`ratio` = the reflectivity factor**, so + `ΔdBZ = 10·log10(ratio)`. +- **`CLOUD`/`RAIN`/`ICE`/`VAPOR`/`SATC0`/`SATCR`/`SATER`/`SATD0`/`SATDR`/`MELT`/`QILIQ`** + — conservation and saturation-adjustment limiters. + +### 5.2 Targeted point dump (`p3_dbg_*`) + +One line per timestep per point in a `(2·halo+1)³` block. Columns: `qc nc mu_c +lamc qr nr mu_r lamr ze_ice ze_rain dbz`, four `nr` and four `qr` checkpoints, +`dnr_ice ncautr nrslf nrevp`, `qcacc_raw qcacc_fin accbr rwrad xvr`, then per +ice category `qitot nitot qirim birim zitot diag_di`. + +The **checkpoints** are the most valuable part — `nr`/`qr` captured at entry, +post-ice-interaction, post-warm-phase and post-sedimentation, so a change can +be attributed to a phase rather than guessed at. They are what disproved both +the "sedimentation creates mass" and "transport delivered it" hypotheses for +the 50 dBZ case. + +`accbr` records which Cohard–Pinty accretion branch executed (0/2/3/4). + +## 6. Findings, with evidence + +### 6.1 Resolved: 19.8 dBZ blip (rain) + +Host delivered `qr ≈ 6e-8` with `nr <= 0`; entry clip floored `nr` to `1e-8`; +`get_rain_dsd2`'s lambda limiter pinned the spectrum at the 2 mm ceiling and +rebuilt `nr`; `ze ∝ qr²/nr` rendered it at 19.8 dBZ, ~33 dB above what the same +mass with intact number would give. **Fixed** by `p3_nrfloor = .false.` +(confirmed — the blip is gone). + +### 6.2 Open: ~50 dBZ feature (rain accretion runaway) — **SHELVED** + +At (38,38,12–13), `qr` jumped 5 orders in one step. Attribution via checkpoints: +not transport, not sedimentation, not ice melt — the **warm phase** added +`1.28e-4 kg/kg` of rain mass while adding **zero** rain number. + +Measured cause: `accbr = 4`, i.e. the Cohard–Pinty **small-drop** accretion +branch, selected because `rwrad = 49.0 µm` fell just under the 50 µm switch. +That branch scales as `xvr² ∝ 1/nr²`. With `nr = 0.32 #/kg` instead of a +physical ~1e4, the raw rate is inflated by ~1e9. `qcacc_raw = 1.43e-3` was +clamped 83.7× by the conservation limiter to `1.71e-5` — which still converted +**the entire cloud water content of the level in one 7.5 s step**, giving a +9.2 mm mean drop before the lambda limiter pinned it at 2 mm. + +Also observed: the branch **flips every timestep** (`accbr` = 2, 2, 0, 4, 3 +over it=196–200; `rwrad` = 69.5, 79.8, —, 49.0, 1817 µm), with raw rates +differing by 1.8e5 across the 50 µm switch. That threshold is itself a +per-point discontinuity between formulas with opposite `nr` sensitivity. + +**Note there is a fix already written and commented out** three lines below the +branch (`module_mp_p3.F`, search `qcacc = Min(qcacc, 0.10*qc(i,k)*odt )`): a +*timescale* bound rather than a mass bound. Enabling it would turn a one-step +total conversion into a ten-step drawdown. One-line experiment. + +Daniel's read after the final run: many remaining glitches still look like this +mechanism. + +### 6.3 Cross-version check (ORIG / ERM / current) + +The pathology is **not** specific to local edits. Compared against +`~/Projects/NCAR_P3/cm1r21.0_new_p3/src/module_mp_p3.F` (clean upstream) and +`~/Projects/cm1r21.0_Ted/src/module_mp_p3.F` (ERM's): + +- **ORIG** has no `nitot` floor and no `nitot` in any gate, so `nitot = 0` + reaches `find_lookupTable_indices_1a` and `alog10(qitot/0) = +Inf` is clamped + to the largest size bin — *the same wrong state*, reached by a different + route. ORIG is arguably worse: its exit gate is `qitot >= qsmall` only, so + `nitot = 0` propagates back to the host and the bad point is self-sustaining. +- **ERM** added the floors (to stop `alog10` of a negative producing NaN) and + raised `qsmall`/`nsmall`. The floors are a band-aid over the same input + problem. +- Daniel reports the **developers' latest version** shows similar behaviour. + +`inv_Drmax = 1/0.002` (2 mm) is the upstream default in all three, not a local +change. The commented-out "old value" is 0.8 mm; at the ceiling +`ze_rain ∝ qr·Drmax³`, so 2 mm renders a pinned point ~12 dB brighter. + +## 7. Wrong turns — read this before repeating them + +1. **Cited `NOTES.md` as evidence for a code claim.** The working tree had ~50 + uncommitted `nsmall`-guard removals; the note described a tree that no + longer existed. → **Always `git status -s` and read the diff first.** + (Saved as a memory note.) +2. **Verified "is this gate protected?" with an `awk` scan that broke across + nested loops**, producing false "UNGATED" results, then quoted them. Verify + suspicious hits by hand. +3. **Checked what each gate *protects* but never what its `else` *does*.** The + rain exit block's `else` clips `qr` to vapour, so adding an `nr` condition + to the `if` relocated the clipping rather than removing it — and I described + it as doing the opposite. Daniel caught it. Same defect nearly repeated on + the ice exit block. +4. **Missed division by `nc` itself** when checking the cloud path (searched + only `/lamc`), causing `qcacc = 0 × Inf = NaN`. The guard needed was on + `xvc = qc/(nc*1000)` at the `iparam=5` branch. +5. **Chased a phantom `lamc = NaN`.** `mu_c` is clamped to `[2,15]` in + `get_cloud_dsd2`'s then-branch and set to 0 in its else, so `mu_c = 0` with + `lamc = NaN` is *impossible* from that routine — which should have stopped + the hypothesis immediately. `lamc` is an **uninitialised automatic array** + that the point dump reads unconditionally; the NaN was almost certainly + stack garbage from a column that took `goto 333`. +6. **Built an unverified causal chain** (`epsr` → `xx` → cloud condensation) + on top of (5) and presented it as the explanation. It was wrong. +7. **Failed to revisit an invariant after deleting its precondition.** I argued + the floor at `qitot_notsmall_1` was harmless *because the entry clip + guaranteed* `nr < nsmall ⟹ qr = 0` — then removed that clip and never + rechecked. Daniel had flagged that exact line as suspicious. +8. **Removed observability while changing behaviour.** Adding `nr < nsmall` to + the entry-clip trigger moved those points to the other branch, silently + zeroing `NFLRR`, and I then quoted `NFLRR = 0` as if it meant "no orphaned + rain". + +Meta-lesson: **the failures were all in verification method, not in reading +individual lines.** Enumerate exhaustively, check both branches, and re-derive +any invariant whose precondition you have just changed. + +## 8. Known latent issues (not fixed) + +- **`mu_c`, `lamc`, `cdist`, `cdist1`, `nu` are never initialised at `p3_main` + entry.** Automatic locals, written only where `get_cloud_dsd2` is called, so + columns taking `goto 333` leave stack garbage that diagnostics will read. + Cost one wrong turn. `diag_di`, `ze_ice`, `ze_rain`, `diag_ze` *are* + initialised. +- **`nu` is `intent(out)` but only assigned when `iparam == 1`** on the + then-path, so it returns undefined for `iparam = 5`. Currently harmless (all + reads sit in `iparam` 1/2 branches) but a live trap. +- **`impose_max_Ni` clips `nitot` without touching `qitot` or `zitot`**, + leaving an inconsistent 3-moment triple on 100% of firings. `p3_nimax = -1` + disables it but is a workaround, not a fix. +- **`zitot` is destroyed at the entry conversion** when `nitot <= 0`: + `where(nitot>0) zitot = zitot**2/nitot elsewhere zitot = 0`. Because + `log_ModAdvZitot = .true.` the advected variable is `√(Z·N)`, so recovering + `Z` *requires* `N` — a corrupted `N` genuinely destroys two of three moments. + Reconstruction from `(q, z)` is **not possible**: with a 3-parameter gamma + and three prognosed moments, `(N₀, μ, λ)` are independent, so `(q, z)` leaves + a free parameter (Daniel's correction — an earlier suggestion of mine to + reconstruct `nitot` was wrong). +- **Dead code in the ice entry clip** — the redundant `sup` clause and the + empty-set branch (§3.4). +- **`qitot/nitot > qr/nr` at ~3636** is gated on `nitot` but not `nr`; closed + in practice by the `p3_nrfloor` invariant, but fragile. + +## 9. Next steps + +**Highest value first.** + +1. **Look for an ice analogue of the `1/nr²` accretion runaway.** Nobody has + checked whether any ice process rate has comparable inverse-`nitot` + sensitivity. Zero visibility currently. Daniel flagged this explicitly. +2. **Revisit `qcacc`** (§6.2). Cheapest experiment in the whole list: uncomment + the `Min(qcacc, 0.10*qc*odt)` timescale bound and rerun. +3. **Watch for mass accumulation.** With both switches `.false.`, number-less + ice *and* rain now keep their mass and are never cleared — neither exit clip + fires on them. `NGATE` and `NFLRR` are the counters; steady is fine, + monotonically climbing means mass piling up in inert points. Ice matters + more (p99 orphaned `qitot ≈ 3.9e-3` vs rain's `1.4e-7`). +4. **Re-verify bit-identity** of `p3_nifloor = .true.` and `p3_nrfloor = .true.` + after the exit-block restructuring. +5. **Initialise the DSD arrays** at `p3_main` entry (§8) — cheap, removes a + whole class of phantom diagnostics. +6. **Retire the temporary switches.** `p3_nifloor` and `p3_nrfloor` were + explicitly agreed as A/B-only. Once the behaviour is settled, fold the + winner in unconditionally and delete both, along with the ~36 guarded sites. + `p3_limlog` and `p3_dbg_*` follow the existing `p3_chksum`/`p3_chkpts` + tooling pattern and were **not** flagged temporary. +7. **The upstream number-transport problem** remains untouched. `PREQN` ~47,000 + and `PREQR` ~49,000 firings per run. Everything here is symptom management. + Daniel deprioritised this deliberately — noting it so nobody assumes it was + handled. + +## 10. Gotchas for a fresh session + +- **Index convention:** Daniel's analysis tooling is **0-based**; CM1 is + 1-based. His `(i,j,k)` = CM1's `(i+1, j+1, k+1)`. This cost a full + rebuild/rerun cycle. `p3_dbg_halo >= 1` makes the dump immune. +- **`diag_ze = -99`** in output means the column was skipped + (`goto 333`, no hydrometeors) — not a real reflectivity. +- **`-ffpe-trap=invalid` catches `log(negative)` and `Inf-Inf` but not + divide-by-zero.** Several hazards here are `x/0`, which needs + `-ffpe-trap=zero`. +- Syntax-check without disturbing the build: + `cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding -DMPI -DNETCDF -DNCFPLUS src/X.F > /tmp/X.f90` + then `gfortran -fsyntax-only -ffree-form -ffree-line-length-none /tmp/X.f90`. + `param.F`/`mp_driver.F` need `mpif90` and `-I src`. +- Test case: `~/Projects/NCAR_P3/simulations/CM1r21/2km_P3_tests/2km050399_WC_drag_pcmaxni_iparam5_P354`. + `ptype = 54`, `iparam = 5` (Cohard–Pinty), `p3_nimax = 2000.e3`, + `p3_ccn_on = 0`, `dtl = 7.5`, 1500 s = 200 steps. diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 4096281..d77b6d5 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -86,6 +86,123 @@ MODULE microphy_p3 integer, save :: chkpts_unit = -1 logical, save :: chkpts_opened = .false. +! Limiter-firing log (log_limlog=.true., host namelist option p3_limlog): +! records every grid point at which one of the point-local limiters/gates in +! p3_main binds, to the per-rank file p3_limlog_NNNN.out. Purpose: diagnose +! grid-point ("checkerboard") noise in the moments and in th/qv/p, which is +! the expected signature of an all-or-nothing limiter that fires at one point +! but not its neighbours. One line per firing: +! +! event it i j k (global) iice ratio v1 v2 v3 v4 +! +! Events logged (see limlog_write calls): +! MAXNI impose_max_Ni clipped nitot for this category (N clipped alone, +! leaving qitot/zitot untouched -> inconsistent 3-moment triple). +! ratio = nitot_after/nitot_before; v1..v4 = nitot_before, nitot_after, +! qitot, zitot. +! NGATE qitot>=qsmall but nitot=nsmall conjuncts stripped from the downstream process gates, +! the process block then runs at an implied mean particle mass of +! q/nsmall, which can be absurdly large at advection/sedimentation +! leading edges. v1..v4 = q, n_before, nsmall, q/nsmall. +! SATC0/SATCR/SATER saturation-adjustment limit on condensation/evaporation +! SATD0/SATDR saturation-adjustment limit on deposition/nucleation +! MELT melt+shed bound on available ice mass +! CLOUD/RAIN/ICE/QILIQ/VAPOR the mass-conservation source/sink ratio limiters +! For all of these, ratio = the applied scaling factor and v1,v2 = +! sources, sinks (v3,v4 = supporting values, event-dependent). +! +! Conservation limiters bind routinely and harmlessly, so only firings with +! ratio < limlog_ratmin are recorded (host namelist p3_limlog_rat, default 0.9); +! MAXNI and NGATE are always recorded when they fire. limlog_maxrec caps the +! number of lines per rank so a long run cannot fill the disk. + logical, public, save :: log_limlog = .false. + real, public, save :: limlog_ratmin = 0.9 + integer, public, save :: limlog_maxrec = 2000000 + integer, save :: limlog_unit = -1 + integer, save :: limlog_nrec = 0 + logical, save :: limlog_opened = .false. + logical, save :: limlog_full = .false. +! limlog_write and qsmall are public so the host can log its own PRE-call state +! check into the same file (see mp_driver.F, ptype 54 block) + public :: limlog_write + public :: qsmall + +!====================== TEMPORARY DIAGNOSTIC SWITCH ========================== +! log_nifloor (host namelist option p3_nifloor, default .true. = current +! behaviour). TEMPORARY -- added solely to A/B one hypothesis about grid-point +! noise; REMOVE once that test concludes, along with the three code sites it +! guards. Do not build anything on it. +! +! .true. : unchanged. The entry clip floors nitot to nsmall, so a category +! with mass but no number is given 1e-8 #/kg and then runs the full +! process block at a mean particle mass of qitot/1e-8, which the +! lookup-table index clamp silently pins to the largest size bin. +! +! .false. : the entry-clip floor is skipped, so such a category keeps nitot=0 +! and fails the existing 'nitot >= nsmall' gates -- no process rates, +! no sedimentation, no lookup access -- and is cleared at the exit +! clip. Two lookup call sites (in k_loop_fz and qi_not_small_merge) +! gate only on qitot and would otherwise divide by zero, so their +! gates pick up an nitot condition here too. Note log_maxnsmall does +! NOT cover this: the floors it switches sit inside gates that already +! require nitot >= nsmall (and ntiny == nsmall), so they are no-ops, +! while the entry-clip floor it does not switch is the one that acts. + logical, public, save :: log_nifloor = .true. +! +! log_nrfloor (host namelist p3_nrfloor, default .true. = current behaviour). +! TEMPORARY, same terms as log_nifloor -- remove when the test concludes. +! .false. rejects rain with mass but no number at the entry clip (qr returned +! to vapour) instead of flooring nr to nsmall. Unlike the ice case this needs +! no downstream gate changes: get_rain_dsd2 guards itself, the two qr/nr +! divisions in the warm-rain block already test nr > nsmall, and the resulting +! post-clip invariant (qr=0,nr=0) or (qr>=qsmall .and. nr>=nsmall) is stronger +! than the one the floor provided. + logical, public, save :: log_nrfloor = .true. +!============================================================================= + +! Targeted single-point dump (host namelist p3_dbg_i / p3_dbg_j / p3_dbg_k; +! disabled when p3_dbg_i <= 0). Writes one line per timestep for one grid +! point to p3_dbgpt_NNNN.out, from whichever rank owns it: the final reflectivity +! components and the liquid/ice distribution parameters behind them. Intended +! for isolated-pixel diagnosis where event counting cannot separate causes -- +! point it at a suspicious grid point and read the actual values. Indices are +! FULL-GRID and are compared against local + chksum_i0/chksum_j0. + integer, public, save :: dbgpt_i = 0 + integer, public, save :: dbgpt_j = 0 + integer, public, save :: dbgpt_k = 0 + ! half-width of the block dumped around (dbgpt_i,dbgpt_j,dbgpt_k): 0 = that + ! point only, 1 = the surrounding 3x3x3, etc. A halo also makes the dump + ! immune to an off-by-one between the analysis tool's index convention and + ! CM1's 1-based global indices, so every line carries its own i,j,k. + integer, public, save :: dbgpt_halo = 1 + integer, save :: dbgpt_unit = -1 + logical, save :: dbgpt_opened = .false. + ! ice microphysics lookup table array dimensions integer, parameter :: isize = 50 integer, parameter :: iisize = 25 @@ -2660,6 +2777,15 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi logical, parameter :: debug_ABORT = .true. !.true. will result in forced abort in s/r 'check_values' logical :: force_abort integer :: location_ind !return value of location index from sr/ 'check_values' + integer :: limlog_j !local j-slab index for the limiter-firing log (see log_limlog) + ! rain-number attribution for the targeted point dump (dbgpt_i>0 only): nr at + ! four checkpoints through the step, plus the warm-phase rates. Differences + ! between consecutive checkpoints attribute the change to ice interactions, + ! warm processes, and sedimentation+clipping respectively. + real, dimension(kts:kte) :: dbg_nr_entry, dbg_nr_posti, dbg_nr_postw, dbg_nr_posts + real, dimension(kts:kte) :: dbg_qr_entry, dbg_qr_posti, dbg_qr_postw, dbg_qr_posts + real, dimension(kts:kte) :: dbg_ncautr, dbg_nrslf, dbg_nrevp, dbg_dnr_ice + real, dimension(kts:kte) :: dbg_qcacc_r, dbg_qcacc_f, dbg_accbr, dbg_rwrad, dbg_xvr ! added for triple moment ice real :: mu_i !shape parameter for ice @@ -2737,6 +2863,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi tmp1 = uzpl(1,1) !avoids compiler warning for unused variable 'uzpl' + ! local j-slab index used by the limiter-firing log (log_limlog). j_index is + ! optional; when the host does not supply it, log 0 rather than an undefined + ! value. limlog_write converts this to a full-grid index via chksum_j0. + limlog_j = 0 + if (present(j_index)) limlog_j = j_index + ! direction of vertical leveling: if (trim(model)=='GEM' .or. trim(model)=='KIN1D') then ktop = kts !k of top level @@ -2867,6 +2999,17 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !-----------------------------------------------------------------------------------! i_loop_main: do i = its,ite ! main i-loop (around the entire scheme) + ! reset the rain-number attribution arrays for this column, so a level whose + ! process rates are skipped shows zero rather than the previous column's value + if (dbgpt_i .gt. 0) then + dbg_nr_entry = 0.; dbg_nr_posti = 0.; dbg_nr_postw = 0.; dbg_nr_posts = 0. + dbg_qr_entry = 0.; dbg_qr_posti = 0.; dbg_qr_postw = 0.; dbg_qr_posts = 0. + dbg_ncautr = 0.; dbg_nrslf = 0.; dbg_nrevp = 0. + dbg_dnr_ice = 0. + dbg_qcacc_r = 0.; dbg_qcacc_f = 0.; dbg_accbr = 0. + dbg_rwrad = 0.; dbg_xvr = 0. + endif + if (nCat.eq.1) then !for nCat = 1, rime-splinter is shut off during the summer (dilution of rimed ice sizes !weakens convection) but on during the winter. The temperature threshold of +5 C (278 K) @@ -2938,31 +3081,60 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !--- apply mass clipping if dry and mass is sufficiently small ! (implying all mass is expected to evaporate/sublimate in one time step) - ! DTD: added nsmall checks to the following - if (qc(i,k).lt.qsmall .or. nc(i,k).lt.nsmall .or. (qc(i,k).lt.1.e-12 .and. sup(i,k).lt.-0.1)) then ! DTD changed to 1.e-12 from 1.e-8 + if (qc(i,k).lt.qsmall .or. (qc(i,k).lt.1.e-12 .and. sup(i,k).lt.-0.1)) then ! DTD changed to 1.e-12 from 1.e-8 qv(i,k) = qv(i,k) + qc(i,k) th(i,k) = th(i,k) - invexn(i,k)*qc(i,k)*xxlv(i,k)*inv_cp qc(i,k) = 0. nc(i,k) = 0. else - ! nc(i,k) = Max( nc(i,k), nsmall ) ! ERM + if (log_limlog .and. nc(i,k).lt.nsmall) & + call limlog_write('NFLRC ',it,i,limlog_j,k,0,0., & + qc(i,k),nc(i,k),nsmall,qc(i,k)/nsmall) + ! TEMPORARY (log_nifloor): as for nitot -- skipping this floor leaves + ! nc=0, which get_cloud_dsd2 rejects internally (lamc=0), so the gates + ! guarding the lamc divisions below must carry an nc condition too + if ( log_nifloor ) nc(i,k) = Max( nc(i,k), nsmall ) ! ERM log_hydrometeorsPresent = .true. ! updated further down endif - if (qr(i,k).lt.qsmall .or. nr(i,k).lt.nsmall .or. (qr(i,k).lt.1.e-12 .and. sup(i,k).lt.-0.1)) then ! DTD changed to 1.e-12 from 1.e-8 + ! TEMPORARY (log_nrfloor): with the floor off, rain that has mass but no + ! number is neither floored nor clipped here -- it passes through and is + ! rejected by the nr conditions on the rain paths downstream, mirroring how + ! a number-less ice category is handled. Flooring it instead would leave + ! qr/nr enormous, and get_rain_dsd2 would pin the distribution at the + ! maximum mean diameter, making ze_rain the largest value attainable for + ! that mass -- an isolated bright reflectivity pixel. + ! NOTE the asymmetry with ice, which is deliberate for now: the ice exit + ! clip fires when qitot < qsmall OR nitot < nsmall, so a number-less ice + ! category is cleared at the end of the step. The rain exit clip tests + ! qr only, so number-less rain persists instead of being cleared. + if (qr(i,k).lt.qsmall .or. & + (qr(i,k).lt.1.e-12 .and. sup(i,k).lt.-0.1)) then ! DTD changed to 1.e-12 from 1.e-8 + ! CLIPR: now provably dead -- qsmall == 1.e-12 makes the second clause + ! imply the first, so this branch cannot be reached with qr >= qsmall. + ! Kept as a canary: any firing means the trigger has changed. + ! ratio = the theta increment (K, negative = evaporative cooling); + ! v1..v4 = qr destroyed, nr, qv before, th before. + if (log_limlog .and. qr(i,k).ge.qsmall) & + call limlog_write('CLIPR ',it,i,limlog_j,k,0, & + -invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp, & + qr(i,k),nr(i,k),qv(i,k),th(i,k)) qv(i,k) = qv(i,k) + qr(i,k) th(i,k) = th(i,k) - invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp qr(i,k) = 0. nr(i,k) = 0. else - ! nr(i,k) = Max( nr(i,k), nsmall ) ! ERM + if (log_limlog .and. nr(i,k).lt.nsmall) & + call limlog_write('NFLRR ',it,i,limlog_j,k,0,0., & + qr(i,k),nr(i,k),nsmall,qr(i,k)/nsmall) + if ( log_nrfloor ) nr(i,k) = Max( nr(i,k), nsmall ) ! ERM log_hydrometeorsPresent = .true. ! updated further down endif clipsum_qv = 0.d0 clipsum_th = 0.d0 do iice = 1,nCat - if (qitot(i,k,iice).lt.qsmall .or. nitot(i,k,iice).lt.nsmall .or. (qitot(i,k,iice).lt.1.e-12 .and. & + if (qitot(i,k,iice).lt.qsmall .or. (qitot(i,k,iice).lt.1.e-12 .and. & supi(i,k).lt.-0.1)) then ! Note that ERM removed second sup criterion for testing. May try later ! category-order-invariant (permanent): ! defer the qv/th increments; accumulated in double precision and @@ -2977,7 +3149,15 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qiliq(i,k,iice) = 0. birim(i,k,iice) = 0. else - ! nitot(i,k,iice) = Max (nitot(i,k,iice), nsmall) ! ERM + ! limiter-firing log: the nsmall floor is about to invent number for a + ! category that has mass but essentially none. v4 is the implied mean + ! particle mass the process block will then run with. + if (log_limlog .and. nitot(i,k,iice).lt.nsmall) & + call limlog_write('NFLRI ',it,i,limlog_j,k,iice,0., & + qitot(i,k,iice),nitot(i,k,iice),nsmall,qitot(i,k,iice)/nsmall) + ! TEMPORARY (log_nifloor): skipping this floor leaves nitot=0 so the + ! existing 'nitot >= nsmall' gates downstream reject the category + if ( log_nifloor ) nitot(i,k,iice) = Max (nitot(i,k,iice), nsmall) ! ERM log_hydrometeorsPresent = .true. ! final update endif @@ -3016,6 +3196,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi th(i,k) = sngl(dble(th(i,k)) + clipsum_th) ! ERM begin + if (dbgpt_i .gt. 0) then ! checkpoint 1: post entry-clip + dbg_nr_entry(k) = nr(i,k) + dbg_qr_entry(k) = qr(i,k) + endif q_old(i,k) = qv(i,k) + qc(i,k) + qr(i,k) + Sum( qitot(i,k,1:nCat) ) qv_old1(i,k) = qv(i,k) qc_old(i,k) = qc(i,k) @@ -3138,7 +3322,16 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! if (abs(epsilon).ge.1.e-15) then if (abs(epsilon).ge.qsmall) then ! ERM qc(i,k) = qc(i,k)+epsilon - !nc(i,k) = Max(nc(i,k), nsmall) ! ERM + ! TEMPORARY (log_nifloor): same treatment as the other nc floors. + ! Currently unreachable -- log_predictSsat is hardwired .false. above -- + ! but gated here so that enabling supersaturation prediction cannot + ! reintroduce cloud mass carrying a manufactured droplet number. + ! NOTE (separate issue, deliberately left alone): this floor fires on + ! any |epsilon| >= qsmall, so it also manufactures droplet number when + ! epsilon < 0, i.e. while cloud water is being evaporated away. That + ! is nonsensical independently of the switch and should be revisited + ! if log_predictSsat is ever turned on. + if ( log_nifloor ) nc(i,k) = Max(nc(i,k), nsmall) ! ERM qv(i,k) = qv(i,k)-epsilon th(i,k) = th(i,k)+epsilon*invexn(i,k)*xxlv(i,k)*inv_cp ! recalculate variables if there was adjustment @@ -3192,7 +3385,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),cdistr(i,k),logn0r(i,k), & - iSPF(k)) + iSPF(k),it,i,limlog_j,k,1) ! initialize inverse supersaturation relaxation timescale for combined ice categories epsi_tot = 0. @@ -3202,17 +3395,25 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! DTD: turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) ! DTD: added call to new per-category Ni limiter - if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) + if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k), & + it,i,limlog_j,k,qitot(i,k,:),zitot(i,k,:)) iice_loop1: do iice = 1,nCat Eii_fact(iice) = 1.0 ! DTD: set default value of ice-ice collection efficiency factor to 1.0 to avoid potential stale value issue f1pr16_s(iice) = -1. ! no lookup accessed for this category yet this step (see declaration) + ! limiter-firing log: mass present but number below nsmall, so the whole + ! process block below is skipped for this category this step (diagnostic + ! only; the test itself is unchanged) + if (log_limlog .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).lt.nsmall) & + call limlog_write('NGATE ',it,i,limlog_j,k,iice,0., & + qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice),birim(i,k,iice)) + qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check ! DTD changed to .ge. from > to ensure case where nitot = nsmall is included !impose lower limits to prevent taking log of # < 0 - if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM - if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM + if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM !compute mean-mass ice diameters (estimated; rigorous approach to be implemented later) !dum2 = 500. !ice density @@ -3265,7 +3466,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! ice-rain collection processes - if (qr(i,k).ge.qsmall .and. nr(i,k).ge.nsmall) then ! DTD added nsmall check + if (qr(i,k).ge.qsmall) then if (.not. log_LiquidFrac) then call access_lookup_table_coll(dumjj,dumii,dumj,dumi,1,dum1,dum3,dum4,dum5,f1pr07) call access_lookup_table_coll(dumjj,dumii,dumj,dumi,2,dum1,dum3,dum4,dum5,f1pr08) @@ -3354,7 +3555,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! print*,'from table',itab_3mom(dumzz+1,dumjj,dumii,dumll,dumi,22) ! ice-rain collection processes - if (qr(i,k).ge.qsmall .and. nr(i,k).ge.nsmall) then ! DTD added nsmall check + if (qr(i,k).ge.qsmall) then if (.not. log_LiquidFrac) then call access_lookup_table_coll_3mom(dumzz,dumjj,dumii,dumj,dumi,1,dum1,dum3,dum4,dum5,dum6,f1pr07) call access_lookup_table_coll_3mom(dumzz,dumjj,dumii,dumj,dumi,2,dum1,dum3,dum4,dum5,dum6,f1pr08) @@ -3446,7 +3647,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ex: rhofaci is grid-mean, f1pr04 is grid-mean, qc*iSCF is in-cloud, ! eci is a constant, rho(i,k) is grid-mean, nitot*iSCF is in-cloud ! (qc*iSCF*nitot*iSCF)*SCF = (qc*nitot)*iSCF to obtain grid-mean qccol - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall .and. t(i,k).le.273.15) then ! diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check, ERM added nitot check ! DTD: changed to .ge. from > to ensure case where nitot = nsmall is included. Also added nc nsmall check + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qc(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check, ERM added nitot check ! DTD: changed to .ge. from > to ensure case where nitot = nsmall is included. qccol(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) @@ -3457,7 +3658,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15 .and. iice==2) then ! .and. diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check ! DTD: only allow qrcol for iice==2 (ice from Biggs freezing) ! if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! orig check - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall .and. t(i,k).le.273.15) then ! ERM added nitot check ! DTD: changed to .ge. from > to ensure case where nitot = nsmall is included. Also added nr nsmall check + ! TEMPORARY (log_nrfloor): nr condition guards logn0r, which is 0 (not + ! -infinity) on the skipped path, so 10.**(f1pr08+logn0r) would silently + ! evaluate with n0r = 1 rather than vanishing + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qr(i,k).ge.qsmall .and. & + (log_nrfloor .or. nr(i,k).ge.nsmall) .and. t(i,k).le.273.15) then ! ERM added nitot check ! DTD: changed to .ge. from > to ensure case where nitot = nsmall is included. IF ( qitot(i,k,iice)/nitot(i,k,iice) > qr(i,k)/nr(i,k) .or. qrcol_opt == 0 ) THEN ! ERM ice size check (Must be larger than rain in mean size) ! qrcol(iice)=f1pr08*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice) ! nrcol(iice)=f1pr07*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice) @@ -3485,7 +3690,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! for T > 273.15, assume cloud water is collected and shed as rain drops if (log_LiquidFrac) then ! assume cloud water is collected by qiliq - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall .and. t(i,k).gt.273.15) then ! DTD added nc and nitot checks + if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).gt.273.15) then qccoll(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccoll(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) if(log_3momentIce) then @@ -3493,7 +3698,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif ! assume collected rain by qiliq - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall .and. t(i,k).gt.273.15) then ! DTD added nr and nitot checks + ! TEMPORARY (log_nrfloor): nr condition guards logn0r (see above) + if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. & + (log_nrfloor .or. nr(i,k).ge.nsmall) .and. t(i,k).gt.273.15) then ! note: f1pr08 and logn0r are already calculated as log_10 qrcoll(iice) = 10.**(f1pr08+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) nrcoll(iice) = 10.**(f1pr07+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) @@ -3503,7 +3710,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif else ! assume cloud water is collected and shed as rain drops (original code) - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall .and. t(i,k).gt.273.15) then ! DTD added nc and nitot checks + if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).gt.273.15) then ! sink for cloud water mass and number, note qcshed is source for rain mass qcshd(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) @@ -3514,7 +3721,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! assume collected rain number is shed as 1 mm drops (original code) ! collection of rain above freezing does not impact total rain mass - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall .and. t(i,k).gt.273.15) then ! DTD added nr and nitot checks + ! TEMPORARY (log_nrfloor): nr condition guards logn0r (see above) + if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. & + (log_nrfloor .or. nr(i,k).ge.nsmall) .and. t(i,k).gt.273.15) then ! rain number sink due to collection nrcol(iice) = 10.**(f1pr07 + logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) ! rain number source due to shedding = collected rain mass/mass of 1 mm drop @@ -3541,9 +3750,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! In a forthcoming version, both LT1-2momI and LT2 (and LT1-3momI) will all be computed ! using the unconstrained size limited (i.e. Dm_max=400000.e-6). - qitot_notsmall: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check + qitot_notsmall: if (qitot(i,k,iice).ge.qsmall) then catcoll_loop: do catcoll = 1,iice-1 - qitotcatcoll_notsmall: if (qitot(i,k,catcoll).ge.qsmall .and. nitot(i,k,catcoll) .ge. nsmall) then ! DTD added nitot check + qitotcatcoll_notsmall: if (qitot(i,k,catcoll).ge.qsmall) then ! first, calculate collection of catcoll category by iice category @@ -3629,7 +3838,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! in the lookup table calculations ! note 'f1pr' values are normalized, so we need to multiply by N - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. log_nislf) then ! ERM added log_nislf. DTD added nitot check + if (qitot(i,k,iice).ge.qsmall .and. log_nislf) then ! ERM added log_nislf. nislf(iice) = f1pr03*rho(i,k)*eii*Eii_fact(iice)*rhofaci(i,k)*nitot(i,k,iice)*nitot(i,k,iice)*iSCF(k) if (log_3momentIce) then ! NOTE: already correct sign from lookup table, thus not multiplied by -1 @@ -3647,7 +3856,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (log_LiquidFrac) then ! some portion of the melted water stays into qiliq --> qimlt(iice) (D>Dth) ! the other portion melts into rain --> qrmlt(iice) (D<=Dth) - if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. t(i,k).gt.273.15) then + if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. t(i,k).gt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) dum = 0. qrmlt(iice) = ((f1pr24+f1pr25*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*((t(i,k)- & @@ -3662,6 +3871,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sinks = qimlt(iice)+qrmlt(iice) if (sinks.gt.0. .and. sinks .gt. (qitot(i,k,iice)-qiliq(i,k,iice))*odt) then ratio = (qitot(i,k,iice)-qiliq(i,k,iice))*odt/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('MELT ',it,i,limlog_j,k,iice,ratio, & + (qitot(i,k,iice)-qiliq(i,k,iice))*odt,sinks, & + qrmlt(iice),qimlt(iice)) qrmlt(iice) = qrmlt(iice)*ratio qimlt(iice) = qimlt(iice)*ratio endif @@ -3673,7 +3886,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif else - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. t(i,k).gt.273.15) then ! DTD added nitot check + if (qitot(i,k,iice).ge.qsmall .and. t(i,k).gt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) ! dum=cpw/xlf(i,k)*(t(i,k)-273.15)*(pracsw1+qcshd(iice)) ! currently enhanced melting from collision is neglected @@ -3701,7 +3914,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! similar to Musil (1970), JAS ! note 'f1pr' values are normalized, so we need to multiply by N - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. (qc(i,k)+qr(i,k)).ge.1.e-6 .and. t(i,k).lt.273.15) then ! DTD added nitot check + if (qitot(i,k,iice).ge.qsmall .and. (qc(i,k)+qr(i,k)).ge.1.e-6 .and. t(i,k).lt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) qwgrth(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*((t(i,k)- & @@ -3755,7 +3968,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !Note (BUG) insert *iSCF(k) because epsi and epsiw needs to be in-cloud (to be done) !if (log_LiquidFrac) then - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check + if (qitot(i,k,iice).ge.qsmall) then if ((qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then epsi(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* & rho(i,k)*dv)*nitot(i,k,iice) @@ -3803,7 +4016,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !............................................................ if (log_LiquidFrac) then - if (qiliq(i,k,iice).ge.qsmall .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check + if (qiliq(i,k,iice).ge.qsmall .and. qitot(i,k,iice).ge.qsmall) then ! Refreezing if (t(i,k).lt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) @@ -3848,7 +4061,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iTc = 1./min(-0.001,t(i,k)-273.15) ! cloud: - if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall) then ! DTD added nc check + ! TEMPORARY (log_nifloor): nc condition guards the lamc divisions below + if (qc(i,k).ge.qsmall .and. & + (log_nifloor .or. nc(i,k).ge.nsmall)) then ! droplet fall speed ! (use Stokes' formulation (thus use analytic solution) Vt_qc(i,k) = acn(i,k)*gamma(4.+bcn+mu_c(i,k))/(lamc(i,k)**bcn*gamma(mu_c(i,k)+4.)) @@ -3923,7 +4138,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! (6.*pi*rin*mu) ! nacnt=exp(-2.80+0.262*(273.15-t(i,k)))*1000. - if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall .and. t(i,k).le.269.15) then ! DTD added nc check + ! TEMPORARY (log_nifloor): nc condition guards the lamc division below + if (qc(i,k).ge.qsmall .and. t(i,k).le.269.15 .and. & + (log_nifloor .or. nc(i,k).ge.nsmall)) then ! DTD added nc check ! qchetc(iice) = pi*pi/3.*Dap*Nacnt*rhow*cdist1(i,k)*gamma(mu_c(i,k)+5.)/lamc(i,k)**4 ! nchetc(iice) = 2.*pi*Dap*Nacnt*cdist1(i,k)*gamma(mu_c(i,k)+2.)/lamc(i,k) ! for future: calculate gamma(mu_c+4) in one place since its used multiple times @@ -3982,7 +4199,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! Note (BUG): is *iSPF(k) necessary here - if (qr(i,k)*iSPF(k).ge.qsmall .and. nr(i,k)*iSPF(k) .ge. nsmall .and. t(i,k).le.269.15) then ! DTD added nr check + ! TEMPORARY (log_nrfloor): nr condition guards log(cdistr) and log(lamr) below, + ! both of which are 0 on the skipped path + if (qr(i,k)*iSPF(k).ge.qsmall .and. t(i,k).le.269.15 .and. & + (log_nrfloor .or. nr(i,k)*iSPF(k).ge.nsmall)) then ! Q_nuc = cons6*exp(log(cdistr(i,k))+log(gamma(7.+mu_r(i,k)))-6.*log(lamr(i,k)))*exp(aimm*(273.15-t(i,k)))*SPF(k) ! N_nuc = cons5*exp(log(cdistr(i,k))+log(gamma(mu_r(i,k)+4.))-3.*log(lamr(i,k)))*exp(aimm*(273.15-t(i,k)))*SPF(k) @@ -4078,7 +4298,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iice_loop_HM: do iice = 1,nCat - ice_present: if (qitot(i,k,iice)-qiliq(i,k,iice) .ge. qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check + ice_present: if (qitot(i,k,iice)-qiliq(i,k,iice) .ge. qsmall) then tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) ! rime fraction tmp2 = qiliq(i,k,iice)/qitot(i,k,iice) ! liquid fraction @@ -4147,7 +4367,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! Note (BUG): is *iSPF(k) necessary here (epsr is in-precip anyway) !calculate rain evaporation including ventilation - if (qr(i,k)*iSPF(k).ge.qsmall .and. nr(i,k)*iSPF(k) .ge. nsmall) then ! DTD added nr check + ! TEMPORARY (log_nrfloor): nr condition guards the division by lamr below; + ! the existing else sets epsr = 0, so number-less rain simply does not + ! contribute to the supersaturation relaxation (and cannot evaporate) + if (qr(i,k)*iSPF(k).ge.qsmall .and. & + (log_nrfloor .or. nr(i,k)*iSPF(k).ge.nsmall)) then call find_lookupTable_indices_3(dumii,dumjj,dum1,rdumii,rdumjj,inv_dum3,mu_r(i,k),lamr(i,k)) !interpolate value at mu_r dum1 = revap_table(dumii,dumjj)+(rdumii-real(dumii))* & @@ -4164,7 +4388,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi epsr = 0. endif - if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall) then ! DTD added nc check + if (qc(i,k).ge.qsmall) then epsc = 2.*pi*rho(i,k)*dv*cdist(i,k) else epsc = 0. @@ -4247,12 +4471,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !Note (BUG) the following three bug fixed change the solution with scpf_on=.false. - if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall) & ! DTD added nc check + if (qc(i,k).ge.qsmall) & !Note (BUG): Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon ! qccon = ((aaa*epsc*oxx+(ssat_cld-aaa*oxx)*odt*epsc*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab)*SCF(k) ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qc qccon = (aaa*epsc*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsc*oxx*(1.d0-dexp(-dble(xx*dt))))/ab - if (qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall) & ! DTD added nr check + if (qr(i,k).ge.qsmall) & !Note (BUG): Cholette (Jul 2022), remove *SPF(k) for ssat_r and multiplication *SPF for grid-mean qccon ! qrcon = ((aaa*epsr*oxx+(ssat_r-aaa*oxx)*odt*epsr*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab)*SPF(k) ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qr @@ -4298,7 +4522,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! if (log_LiquidFrac) then - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check + if (qitot(i,k,iice).ge.qsmall) then if ( (qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then ! ERM split off second part into separate if ! Sublimation/deposition of ice !note: diffusional growth/decay rate: (stored as 'qidep' temporarily; may go to qisub below) @@ -4345,7 +4569,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nitot check + if (qitot(i,k,iice).ge.qsmall) then if ((qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then ! ERM split off second part into separate if ! Condensation/evaporation fo qiliq !Note (BUG) Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon @@ -4625,7 +4849,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! ERM end !Note (BUG), needs to be in-cloud condition - qc_not_small_1: if (qc(i,k)*iSCF(k).ge.qsmall .and. nc(i,k)*iSCF(k).ge.nsmall) then ! DTD changed to use qsmall and added nc check + ! TEMPORARY (log_nifloor): the iparam=5 (Cohard-Pinty) branch forms + ! xvc = qc/(nc*1000) below, so nc=0 gives xvc=Inf and then qcacc = 0*Inf = NaN. + ! The rain-side equivalents at the top of this block already test nr > nsmall; + ! the cloud side never tested nc. The else branch already zeroes xvc. + qc_not_small_1: if (qc(i,k)*iSCF(k).ge.qsmall .and. & + (log_nifloor .or. nc(i,k)*iSCF(k).ge.nsmall)) then ! DTD changed to use qsmall if (iparam.eq.1) then @@ -4738,15 +4967,29 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi IF ( qr(i,k) > qsmall .and. qr(i,k)*rho(i,k) > 1.2*xl2p ) THEN ! xvr = Max((4./3.)*pi*(40.e-6)**3, qr(i,k)/(nr(i,k)*900.)) + ! accretion-branch trace for the targeted point dump. Codes: + ! 0 = block never reached (qc_not_small_1 skipped, or the outer + ! qr > qsmall .and. qr*rho > 1.2*xl2p test failed) + ! 2 = reached, but rwrad <= rh, so no accretion + ! 3 = large-drop branch: qcacc linear in xvr + ! 4 = small-drop branch: qcacc in xvr**2, hence ~ 1/nr**2 + if (dbgpt_i .gt. 0) then + dbg_accbr(k) = 2. + dbg_rwrad(k) = rwrad + dbg_xvr(k) = xvr + endif + IF ( rwrad > rh ) THEN IF ( rwrad > 50.e-6 ) THEN + if (dbgpt_i .gt. 0) dbg_accbr(k) = 3. ncacc = aa2*nr(i,k)*(rho(i,k)*nc(i,k))*(xvc + xvr) ! IF ( qr(i,k)*rho(i,k) > 1.2*xl2p ) THEN qcacc = erw*aa2*nr(i,k)*rho(i,k)*qc(i,k)* & & ((alphac + 2.)*xvc/(alphac + 1.) + xvr) !*rhoinv(mgs) ELSE + if (dbgpt_i .gt. 0) dbg_accbr(k) = 4. qcacc = aa1*nc(i,k)*rho(i,k)*qc(i,k)* & & ((alphac + 3.)*(alphac + 2.)*xvc**2/(alphac + 1.)**2 + & & (alphar + 6.)*(alphar + 5.)*(alphar + 4.)*xvr**2/ & @@ -4766,6 +5009,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ERM end Cohard and Pinty endif + if (dbgpt_i .gt. 0) dbg_qcacc_r(k) = qcacc ! raw rate, before the conservation limiters + if (qcaut .eq.0.) ncautc = 0. if (ncautc.eq.0.) qcaut = 0. @@ -4784,7 +5029,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !............................ ! self-collection of droplets - if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall) then ! DTD added nsmall check + if (qc(i,k).ge.qsmall) then if (iparam.eq.1) then !Seifert and Beheng (2001) @@ -4805,7 +5050,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !............................ ! accretion of cloud by rain - if (qr(i,k).ge.qsmall .and. qc(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall .and. nc(i,k) .ge. nsmall) then ! DTD added nsmall check + if (qr(i,k).ge.qsmall .and. qc(i,k).ge.qsmall) then if (iparam.eq.1) then !Seifert and Beheng (2001) @@ -4849,8 +5094,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall ) then ! ERM added nsmall check ! DTD changed from > to .ge. ! include breakup - dum1 = 500.e-6 ! DTD changed from 280.e-6 - if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall check and using ntiny instead of nsmall + dum1 = 280.e-6 ! DTD changed to 500.e-6 from 280.e-6. Update: changed back for testing + if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall check and using ntiny instead of nsmall ! use mass-mean diameter (do this by using ! the old version of lambda w/o mu dependence) ! note there should be a factor of 6^(1/3), but we @@ -4928,6 +5173,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi tmp1 = qccon+qrcon+qcnuc+sum(qlcon) if (tmp1>0. .and. qcon_satadj<0.) then + if (log_limlog) call limlog_write('SATC0 ',it,i,limlog_j,k,0,0., & + tmp1,qcon_satadj,qccon,qcnuc) qccon = 0. qrcon = 0. qcnuc = 0. @@ -4937,6 +5184,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (tmp1.gt.0. .and. tmp1.gt.qcon_satadj) then ratio = max(0.,qcon_satadj)/tmp1 ratio = min(1.,ratio) + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('SATCR ',it,i,limlog_j,k,0,ratio, & + qcon_satadj,tmp1,qccon,qcnuc) qccon = qccon*ratio qrcon = qrcon*ratio qcnuc = qcnuc*ratio @@ -4945,6 +5195,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi elseif (qcevp+qrevp+sum(qlevp).gt.0.) then ratio = max(0.,-qcon_satadj)/(qcevp+qrevp+sum(qlevp)) ratio = min(1.,ratio) + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('SATER ',it,i,limlog_j,k,0,ratio, & + -qcon_satadj,qcevp+qrevp+sum(qlevp),qcevp,qrevp) qcevp = qcevp*ratio qrevp = qrevp*ratio nrevp = nrevp*ratio @@ -4962,6 +5215,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! category-order-invariant (permanent; category-order-invariant) tmp1 = sngl(sum(dble(qidep))+sum(dble(qinuc))) if (tmp1>0. .and. qdep_satadj<0.) then + if (log_limlog) call limlog_write('SATD0 ',it,i,limlog_j,k,0,0., & + tmp1,qdep_satadj,sngl(sum(dble(qidep))),sngl(sum(dble(qinuc)))) qidep = 0. qinuc = 0. ninuc = 0. @@ -4969,6 +5224,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (tmp1.gt.0. .and. tmp1.gt.qdep_satadj) then ratio = max(0.,qdep_satadj)/tmp1 ratio = min(1.,ratio) + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('SATDR ',it,i,limlog_j,k,0,ratio, & + qdep_satadj,tmp1,sngl(sum(dble(qidep))),sngl(sum(dble(qinuc)))) qidep = qidep*ratio qinuc = qinuc*ratio ninuc = ninuc*ratio @@ -4994,6 +5252,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sources = qc(i,k) + (qccon+qcnuc)*dt if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('CLOUD ',it,i,limlog_j,k,0,ratio, & + sources,sinks,qc(i,k),qcaut+qcacc) qcaut = qcaut*ratio qcacc = qcacc*ratio qcevp = qcevp*ratio @@ -5024,6 +5285,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sum(dble(qcshd))+sum(dble(qlshd)) )*dt if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('RAIN ',it,i,limlog_j,k,0,ratio, & + sources,sinks,qr(i,k),qrevp) qrevp = qrevp*ratio qrcol = qrcol*ratio qrheti = qrheti*ratio @@ -5060,6 +5324,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sinks = sngl(dble(sinks) + tmpdbl2) if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('ICE ',it,i,limlog_j,k,iice,ratio, & + sources,sinks,qitot(i,k,iice),qisub(iice)) qisub(iice) = qisub(iice)*ratio qrmlt(iice) = qrmlt(iice)*ratio qlshd(iice) = qlshd(iice)*ratio @@ -5097,6 +5364,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sinks = sngl(dble(sinks) + tmpdbl2) if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('QILIQ ',it,i,limlog_j,k,iice,ratio, & + sources,sinks,qiliq(i,k,iice),qifrz(iice)) qifrz(iice) = qifrz(iice)*ratio qlshd(iice) = qlshd(iice)*ratio qlevp(iice) = qlevp(iice)*ratio @@ -5118,6 +5388,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sources = qv(i,k) + sngl( dble(qcevp)+dble(qrevp)+sum(dble(qisub))+sum(dble(qlevp)) )*dt if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('VAPOR ',it,i,limlog_j,k,0,ratio, & + sources,sinks,qv(i,k),sngl(sum(dble(qidep))+sum(dble(qinuc)))) qccon = qccon*ratio qrcon = qrcon*ratio qcnuc = qcnuc*ratio @@ -5168,8 +5441,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi mu_i_s(iice)=mu_i_initial - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall & - .and. f1pr16_s(iice).gt.0.) then ! DTD added nsmall check + if (qitot(i,k,iice).ge.qsmall & + .and. f1pr16_s(iice).gt.0.) then ! f1pr16_s check: use THIS category's density from its own lookup ! this step; if the lookup did not run, keep mu_i_initial rather ! than consuming another category's stale density (former bug) @@ -5372,7 +5645,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qc(i,k) = sngl(dble(qc(i,k)) + dqc_dp) if (log_predictNc) nc(i,k) = sngl(dble(nc(i,k)) + dnc_dp) qr(i,k) = sngl(dble(qr(i,k)) + dqr_dp) + if (dbgpt_i .gt. 0) dbg_dnr_ice(k) = sngl(dnr_dp) nr(i,k) = sngl(dble(nr(i,k)) + dnr_dp) + if (dbgpt_i .gt. 0) then ! checkpoint 2: post ice-interaction + dbg_nr_posti(k) = nr(i,k) + dbg_qr_posti(k) = qr(i,k) + endif qv(i,k) = sngl(dble(qv(i,k)) + dqv_dp) th(i,k) = sngl(dble(th(i,k)) + dth_dp) !== @@ -5405,6 +5683,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi print*,'NaN tendency detected in rain processes at i=', i, ' k=', k print*,'qcacc=', qcacc, ' qcaut=', qcaut, ' qrcon=', qrcon, ' qrevp=', qrevp endif + if (dbgpt_i .gt. 0) dbg_qcacc_f(k) = qcacc ! after the conservation limiters qc(i,k) = qc(i,k) + (-qcacc-qcaut+qcnuc+qccon-qcevp)*dt qr(i,k) = qr(i,k) + (qcacc+qcaut+qrcon-qrevp)*dt @@ -5419,6 +5698,13 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi else nr(i,k) = nr(i,k) + (ncautr-nrslf-nrevp)*dt endif + if (dbgpt_i .gt. 0) then + dbg_ncautr(k) = ncautr ! rate, per second (source) + dbg_nrslf(k) = nrslf ! rate, per second (sink) + dbg_nrevp(k) = nrevp ! rate, per second (sink) + dbg_nr_postw(k) = nr(i,k) ! checkpoint 3: post warm-phase + dbg_qr_postw(k) = qr(i,k) + endif qv(i,k) = qv(i,k) + (-qcnuc-qccon-qrcon+qcevp+qrevp)*dt th(i,k) = th(i,k) + invexn(i,k)*((qcnuc+qccon+qrcon-qcevp-qrevp)*xxlv(i,k)* & @@ -5433,7 +5719,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi clipsum_nr = 0.d0 clipsum_th = 0.d0 do iice = 1,nCat - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nsmall check + if (qitot(i,k,iice).ge.qsmall) then if ((qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then ! ERM split conditional to avoid div by zero clipsum_qr = clipsum_qr + dble(qitot(i,k,iice)) clipsum_nr = clipsum_nr + dble(nitot(i,k,iice)) @@ -5452,7 +5738,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! clipping for small hydrometeor values - if (qc(i,k).lt.qsmall .or. nc(i,k) .lt. nsmall) then ! DTD added nsmall check + if (qc(i,k).lt.qsmall) then qv(i,k) = qv(i,k) + qc(i,k) th(i,k) = th(i,k) - invexn(i,k)*qc(i,k)*xxlv(i,k)*inv_cp qc(i,k) = 0. @@ -5461,7 +5747,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi log_hydrometeorsPresent = .true. endif - if (qr(i,k).lt.qsmall .or. nr(i,k) .lt. nsmall) then ! DTD added nsmall check + if (qr(i,k).lt.qsmall) then qv(i,k) = qv(i,k) + qr(i,k) th(i,k) = th(i,k) - invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp qr(i,k) = 0. @@ -5475,7 +5761,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi clipsum_qv = 0.d0 clipsum_th = 0.d0 do iice = 1,nCat - if (qitot(i,k,iice).lt.qsmall .or. nitot(i,k,iice) .lt. nsmall) then ! DTD added nsmall check + if (qitot(i,k,iice).lt.qsmall) then clipsum_qv = clipsum_qv + dble(qitot(i,k,iice)) clipsum_th = clipsum_th - dble(invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp) clipsum_th = clipsum_th - dble(invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp) @@ -5495,7 +5781,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! DTD turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) ! DTD: added call to new per-category Ni limiter - if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) + if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k), & + it,i,limlog_j,k,qitot(i,k,:),zitot(i,k,:)) !--------------------------------------------------------------------------------- @@ -5844,7 +6131,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_c1: do k = k_qxtop,k_qxbot,-kdir - if (qc(i,k)*iSCF(k).ge.qsmall) then + ! TEMPORARY (log_nifloor): nc condition guards the lamc division below + if (qc(i,k)*iSCF(k).ge.qsmall .and. & + (log_nifloor .or. nc(i,k)*iSCF(k).ge.nsmall)) then call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu, & lamc(i,k),lammin,lammax,tmp1,tmp2,iSCF(k)) dum = 1./lamc(i,k)**bcn @@ -5932,9 +6221,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qr_not_small_1: if (qr(i,k)*iSPF(k).ge.qsmall .and. nr(i,k)*iSPF(k) .ge. nsmall ) then ! ERM added nr check ! DTD changed from > to .ge. !Compute Vq, Vn: - if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny instead of nsmall + if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny instead of nsmall call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),cdistr(i,k), & - logn0r(i,k),iSPF(k)) + logn0r(i,k),iSPF(k),it,i,limlog_j,k,2) call find_lookupTable_indices_3(dumii,dumjj,dum1,rdumii,rdumjj,inv_dum3, & mu_r(i,k),lamr(i,k)) @@ -6060,7 +6349,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qi_notsmall_i1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check DTD changed to .ge. from > to ensure that nitot = nsmall is included !--Compute Vq, Vn: - if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ERM added log_maxnsmall and ntiny + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & @@ -6154,7 +6443,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qi_notsmall_i2: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check DTD changed to .ge. from > to ensure that nitot = nsmall is included !--Compute Vq, Vn: - if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ERM added log_maxnsmall and ntiny + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & isize,rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice), & @@ -6258,7 +6547,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qi_notsmall_i3: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) >= nsmall ) then ! ERM added nitot check !--Compute Vq, Vn: - if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ! ERM added log_maxnsmall and ntiny + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & @@ -6407,7 +6696,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qi_notsmall_i4: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check DTD changed to .ge. from > to ensure that nitot = nsmall is included !--Compute Vq, Vn: - if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ! ERM added log_maxnsmall and ntiny + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & @@ -6556,6 +6845,16 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop_sedi_ice !iice-loop + ! checkpoint 4: post-sedimentation, before the final clipping loops. Splits + ! the remaining interval so a change in qr/nr can be attributed either to the + ! sedimentation solvers or to the clipping that follows them. + if (dbgpt_i .gt. 0) then + do k = kbot,ktop,kdir + dbg_nr_posts(k) = nr(i,k) + dbg_qr_posts(k) = qr(i,k) + enddo + endif + !................................................................................ ! diagnose mu tendency from sedimentation @@ -6598,8 +6897,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! compute mean-mass ice diameters diam_ice(i,k,:) = 0. do iice = 1,nCat - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nsmall check - if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny + ! TEMPORARY (log_nifloor): the nitot condition is a no-op when the + ! entry-clip floor is on, and prevents a divide-by-zero in the + ! lookup call below when it is off + if (qitot(i,k,iice).ge.qsmall .and. & + (log_nifloor .or. nitot(i,k,iice).ge.nsmall)) then + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7,isize, & rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), & @@ -6632,7 +6935,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif multicat1 - qc_not_small_2: if (qc(i,k).ge.qsmall .and. nc(i,k) .ge. nsmall .and. t(i,k).lt.233.15) then ! DTD added nc check + ! TEMPORARY (log_nifloor): without an nc condition, homogeneous freezing of a + ! number-less cloud creates a number-less ice category -- feeding the same problem + qc_not_small_2: if (qc(i,k).ge.qsmall .and. t(i,k).lt.233.15 .and. & + (log_nifloor .or. nc(i,k).ge.nsmall)) then Q_nuc = qc(i,k) if ( log_maxnsmall ) nc(i,k) = max(nc(i,k),ntiny) ! ERM added log_maxnsmall and ntiny @@ -6690,10 +6996,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif qc_not_small_2 - qr_not_small_2: if (qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall .and. t(i,k).lt.233.15) then ! DTD added nsmall check + qr_not_small_2: if (qr(i,k).ge.qsmall .and. t(i,k).lt.233.15) then Q_nuc = qr(i,k) - if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny + if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny N_nuc = nr(i,k) if (nCat>1) then !determine destination ice-phase category: @@ -6753,9 +7059,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !step 1: adjustments and calculation of mean diameters k_loop_check_before_merge: do k = kbot,ktop,kdir iice_loop_check_before_merge: do iice = 1,nCat - qi_not_small_merge: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall) then ! DTD added nsmall check + ! TEMPORARY (log_nifloor): see the k_loop_fz gate above -- same + ! divide-by-zero protection for the lookup call below + qi_not_small_merge: if (qitot(i,k,iice).ge.qsmall .and. & + (log_nifloor .or. nitot(i,k,iice).ge.nsmall)) then - if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7,isize, & rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), & @@ -6898,7 +7207,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi k_loop_final_diagnostics: do k = kbot,ktop,kdir ! cloud: - if (qc(i,k)*iSCF(k).ge.qsmall .and. nc(i,k) .ge. nsmall) then ! DTD added nsmall check + ! TEMPORARY (log_nifloor): nc condition guards the lamc division below + if (qc(i,k)*iSCF(k).ge.qsmall .and. & + (log_nifloor .or. nc(i,k)*iSCF(k).ge.nsmall)) then call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu,lamc(i,k), & lammin,lammax,tmp1,tmp2, iSCF(k)) diag_effc(i,k) = 0.5*(mu_c(i,k)+3.)/lamc(i,k) @@ -6910,9 +7221,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! rain: - if (qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall) then ! DTD added nsmall check + ! NOTE: the else branch of this test clips qr to vapour, so the nr condition + ! must NOT be attached here -- doing so would merely relocate the clipping + ! from the entry clip to the exit clip. It guards the DSD/reflectivity + ! block only, immediately below. + if (qr(i,k).ge.qsmall) then + + ! TEMPORARY (log_nrfloor): number-less rain skips the DSD and keeps + ! ze_rain at its initialised 1.e-22, contributing nothing to the + ! diagnosed reflectivity, but its mass is left untouched. + if (log_nrfloor .or. nr(i,k).ge.nsmall) then - call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),tmp1,tmp2,1.) + call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),tmp1,tmp2,1., & + it,i,limlog_j,k,3) ! hm, turn off soft lambda limiter ! impose size limits for rain with 'soft' lambda limiter @@ -6931,6 +7252,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ze_rain(i,k) = rho(i,k)*nr(i,k)*(mu_r(i,k)+6.)*(mu_r(i,k)+5.)*(mu_r(i,k)+4.)* & (mu_r(i,k)+3.)*(mu_r(i,k)+2.)*(mu_r(i,k)+1.)/lamr(i,k)**6 ze_rain(i,k) = max(ze_rain(i,k),1.e-22) + + endif ! log_nrfloor .or. nr >= nsmall + else qv(i,k) = qv(i,k)+qr(i,k) th(i,k) = th(i,k)-invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp @@ -6942,7 +7266,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! DTD turned off for testing ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) ! DTD: added call to new per-category Ni limiter - if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k)) + if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k), & + it,i,limlog_j,k,qitot(i,k,:),zitot(i,k,:)) ! (category-order-invariant: defer the shared qv/th increments from the @@ -6951,11 +7276,20 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi clipsum_th = 0.d0 iice_loop_final_diagnostics: do iice = 1,nCat - qi_not_small: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then ! ERM added nitot check + ! NOTE: the else branch of this test clears the category (mass to vapour), + ! so the nitot condition must NOT be attached here -- that would clear + ! number-less ice rather than leave it alone. It guards the lookup and + ! diagnostic block only, immediately below. Mirrors the rain exit block. + qi_not_small: if (qitot(i,k,iice).ge.qsmall) then ! ERM added nitot check + + ! TEMPORARY (log_nifloor): number-less ice skips the lookups and + ! diagnostics -- ze_ice keeps its initialised 1.e-22 and diag_di is + ! left alone -- but its mass is preserved rather than dumped to vapour. + if (log_nifloor .or. nitot(i,k,iice).ge.nsmall) then !impose lower limits to prevent taking log of # < 0 - if ( log_maxnsmall ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny - if ( log_maxnsmall ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny + if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) @@ -7105,6 +7439,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ze_ice(i,k) = ze_ice(i,k) + f1pr13*nitot(i,k,iice)*rho(i,k) ze_ice(i,k) = max(ze_ice(i,k),1.e-22) + endif ! log_nifloor .or. nitot >= nsmall + else clipsum_qv = clipsum_qv + dble(qitot(i,k,iice)) @@ -7128,6 +7464,20 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! for reflectivity paper diag_ze(i,k) = 10.*log10((ze_ice(i,k)+ze_rain(i,k))*1.e+18) + ! targeted single-point dump: every value below is final for this step + if (dbgpt_i .gt. 0 .and. & + abs(i+chksum_i0 - dbgpt_i) .le. dbgpt_halo .and. & + abs(limlog_j+chksum_j0 - dbgpt_j) .le. dbgpt_halo .and. & + abs(k - dbgpt_k) .le. dbgpt_halo) & + call dbgpt_write(it,i,limlog_j,k,qc(i,k),nc(i,k),mu_c(i,k),lamc(i,k), & + qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),ze_ice(i,k),ze_rain(i,k),diag_ze(i,k), & + dbg_nr_entry(k),dbg_nr_posti(k),dbg_nr_postw(k),dbg_nr_posts(k), & + dbg_qr_entry(k),dbg_qr_posti(k),dbg_qr_postw(k),dbg_qr_posts(k), & + dbg_dnr_ice(k),dbg_ncautr(k),dbg_nrslf(k),dbg_nrevp(k), & + dbg_qcacc_r(k),dbg_qcacc_f(k),dbg_accbr(k),dbg_rwrad(k),dbg_xvr(k), & + qitot(i,k,:),nitot(i,k,:),qirim(i,k,:),birim(i,k,:),zitot(i,k,:), & + diag_di(i,k,:)) + ! DTD: for reflectivity > 85 dBZ, print out the location and all prognostic moments for rain and ice ! for debugging purposes ! DTD: changed to check on ice mean diameter above 2 cm for cat 2 @@ -12674,7 +13024,7 @@ subroutine get_cloud_dsd2(qc_grd,nc_grd,mu_c,rho,nu,dnu,lamc,lammin,lammax,cdist end subroutine get_cloud_dsd2 !=========================================================================================== - subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) + subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF,it,i_loc,j_loc,k_loc,site) !Note (BUG) need to be updated because problem when qr=qsmall ! This will change the solution @@ -12688,15 +13038,26 @@ subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) real, intent(inout) :: nr_grd !grid-mean real, intent(out) :: lamr,mu_r,cdistr,logn0r real, intent(in) :: iSPF + ! optional index arguments, used only by the limiter-firing log (log_limlog); + ! read, never modified. 'site' identifies the call site and is written into + ! the iice column: 1 = main k-loop, 2 = sedimentation, 3 = final diagnostics + ! (the one whose lamr feeds ze_rain). + integer, intent(in), optional :: it,i_loc,j_loc,k_loc,site !local variables: real :: inv_dum,lammax,lammin,qr,nr + real :: nr_before ! pre-limiter nr, for the limiter-firing log + integer :: site_loc !-------------------------------------------------------------------------- qr = qr_grd*iSPF !in-cloud value - if (qr.ge.qsmall .and. nr_grd*iSPF >= nsmall) then ! DTD added nr check + ! TEMPORARY (log_nrfloor): the nr condition mirrors the nc condition already + ! present in get_cloud_dsd2. Without it this routine does not decline to act + ! on a number-less point -- it manufactures nr via the lambda limiter below, + ! pinning the distribution at the maximum mean diameter. + if (qr.ge.qsmall .and. (log_nrfloor .or. nr_grd*iSPF.ge.nsmall)) then nr = nr_grd*iSPF !in-cloud value @@ -12705,7 +13066,7 @@ subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) ! find spot in lookup table ! (scaled N/q for lookup table parameter space_ - if ( log_maxnsmall ) nr = max(nr,ntiny) ! ERM added log_maxnsmall and ntiny + if ( log_maxnsmall .and. log_nrfloor ) nr = max(nr,ntiny) ! ERM added log_maxnsmall and ntiny inv_dum = (qr/(cons1*nr*6.))**thrd ! apply constant mu_r: @@ -12732,12 +13093,31 @@ subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) ! apply lambda limiters for rain lammax = (mu_r+1.)*1.e+5 lammin = (mu_r+1.)*inv_Drmax + nr_before = nr + site_loc = 0 + if (present(site)) site_loc = site + if (lamr.lt.lammin) then lamr = lammin nr = 6.*lamr**3*qr/(pi*rhow*(mu_r+3.)*(mu_r+2.)*(mu_r+1.)) + ! limiter-firing log: drops were too large for the mass, so the whole + ! distribution is pinned at the maximum mean diameter (1/inv_Drmax) + ! and nr is rebuilt from qr. ze_rain then becomes the largest value + ! attainable for this qr. ratio = fraction of the final number that + ! was actually present beforehand (0 = entirely manufactured). + if (log_limlog .and. present(it) .and. present(i_loc) .and. & + present(j_loc) .and. present(k_loc)) & + call limlog_write('RLAMX ',it,i_loc,j_loc,k_loc,site_loc, & + nr_before/max(nr,1.e-30),qr,nr_before,nr,mu_r) elseif (lamr.gt.lammax) then lamr = lammax nr = 6.*lamr**3*qr/(pi*rhow*(mu_r+3.)*(mu_r+2.)*(mu_r+1.)) + ! opposite branch: drops too small for the mass, pinned at the minimum + ! mean diameter. Logged for symmetry -- this one reduces ze_rain. + if (log_limlog .and. present(it) .and. present(i_loc) .and. & + present(j_loc) .and. present(k_loc)) & + call limlog_write('RLAMN ',it,i_loc,j_loc,k_loc,site_loc, & + nr_before/max(nr,1.e-30),qr,nr_before,nr,mu_r) endif logn0r = alog10(nr)+(mu_r+1.)*alog10(lamr)-alog10(gamma(mu_r+1)) !note: logn0r is calculated as log10(n0r) @@ -12746,6 +13126,7 @@ subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) else + mu_r = 0. ! was left unset here; stale on the widened else path lamr = 0. cdistr = 0. logn0r = 0. @@ -12831,12 +13212,153 @@ end subroutine impose_max_total_Ni !=========================================================================================== - subroutine impose_max_Ni(nitot_local,max_Ni,i_rho_local) + subroutine limlog_write(event,it,i_loc,j_loc,k_loc,iice,ratio,v1,v2,v3,v4) + +!-------------------------------------------------------------------------------- +! Limiter-firing log (see the log_limlog block near the top of this module). +! Writes one line per firing of a point-local limiter/gate in p3_main, to the +! per-rank file p3_limlog_NNNN.out. Indices written are FULL-GRID: the caller +! passes local i and j and this routine adds chksum_i0/chksum_j0 (k is not +! decomposed in CM1, so local k = global k). +! +! Diagnostic only: this routine reads its arguments and never modifies model +! state, so enabling p3_limlog cannot change the answer. +!-------------------------------------------------------------------------------- + + implicit none + +!arguments: + character(len=*), intent(in) :: event + integer, intent(in) :: it,i_loc,j_loc,k_loc,iice + real, intent(in) :: ratio,v1,v2,v3,v4 + +!local variables: + character(len=32) :: limlog_fname + + if (limlog_full) return + + if (.not. limlog_opened) then + ! newunit= assigns a NEGATIVE unit number; track opened state with a + ! separate flag, not a sign test on the unit + write(limlog_fname,'(a,i4.4,a)') 'p3_limlog_', chksum_myid, '.out' + open(newunit=limlog_unit, file=trim(limlog_fname), status='replace', & + form='formatted', action='write') + limlog_opened = .true. + write(limlog_unit,'(a)') '# event it i j k (full grid) iice ratio v1 v2 v3 v4' + endif + + write(limlog_unit,'(a6,1x,i8,3(1x,i6),1x,i3,5(1x,e14.6))') & + event, it, i_loc+chksum_i0, j_loc+chksum_j0, k_loc, iice, & + ratio, v1, v2, v3, v4 + + limlog_nrec = limlog_nrec + 1 + + ! flush periodically so the log is intact if the run is killed or aborts + if (mod(limlog_nrec,1000) == 0) flush(limlog_unit) + + if (limlog_nrec .ge. limlog_maxrec) then + write(limlog_unit,'(a,i12,a)') '# LIMLOG RECORD CAP REACHED (', limlog_maxrec, & + ') -- no further firings recorded on this rank' + flush(limlog_unit) + limlog_full = .true. + endif + + end subroutine limlog_write + +!=========================================================================================== + + subroutine dbgpt_write(it,i_loc,j_loc,k_loc,qc_l,nc_l,mu_c_l,lamc_l, & + qr_l,nr_l,mu_r_l,lamr_l,ze_ice_l,ze_rain_l,dbz_l, & + nr_entry_l,nr_posti_l,nr_postw_l,nr_posts_l, & + qr_entry_l,qr_posti_l,qr_postw_l,qr_posts_l, & + dnr_ice_l,ncautr_l,nrslf_l,nrevp_l, & + qcacc_r_l,qcacc_f_l,accbr_l,rwrad_l,xvr_l, & + qitot_l,nitot_l,qirim_l,birim_l,zitot_l,diag_di_l) + +!-------------------------------------------------------------------------------- +! Targeted single-point dump (see the dbgpt_i block near the top of this module). +! Called once per timestep for the one grid point selected by the host, after +! diag_ze has been formed, so every value written is final for that step. +! +! Diagnostic only: reads its arguments and never modifies model state. +!-------------------------------------------------------------------------------- + + implicit none + +!arguments: + integer, intent(in) :: it,i_loc,j_loc,k_loc + real, intent(in) :: qc_l,nc_l,mu_c_l,lamc_l,qr_l,nr_l,mu_r_l,lamr_l + real, intent(in) :: ze_ice_l,ze_rain_l,dbz_l + ! rain-number attribution: nr at three checkpoints through the step, the summed + ! ice-interaction increment, and the three warm-phase rates (per second). + ! (nr_posti - nr_entry) = ice interactions, (nr_postw - nr_posti) = warm phase, + ! (nr_l - nr_postw) = sedimentation + post-process clipping. + real, intent(in) :: nr_entry_l,nr_posti_l,nr_postw_l,nr_posts_l + ! qr at the same three checkpoints, so the mass and number histories can be + ! compared directly -- a bad mass/number ratio present at entry means the rain + ! arrived broken, rather than being broken by anything inside p3_main. + real, intent(in) :: qr_entry_l,qr_posti_l,qr_postw_l,qr_posts_l + real, intent(in) :: dnr_ice_l,ncautr_l,nrslf_l,nrevp_l + ! accretion trace: qcacc before and after the conservation limiters, which of + ! the Cohard-Pinty branches was taken (see the branch-code comment at the + ! accretion block), and the two quantities that select it. + real, intent(in) :: qcacc_r_l,qcacc_f_l,accbr_l,rwrad_l,xvr_l + real, dimension(:), intent(in) :: qitot_l,nitot_l,qirim_l,birim_l,zitot_l,diag_di_l + +!local variables: + character(len=32) :: dbgpt_fname + integer :: iice_d,nCat_d + + nCat_d = size(qitot_l) + + if (.not. dbgpt_opened) then + ! newunit= assigns a NEGATIVE unit number; track opened state with a + ! separate flag, not a sign test on the unit + write(dbgpt_fname,'(a,i4.4,a)') 'p3_dbgpt_', chksum_myid, '.out' + open(newunit=dbgpt_unit, file=trim(dbgpt_fname), status='replace', & + form='formatted', action='write') + dbgpt_opened = .true. + write(dbgpt_unit,'(a,3(1x,i6),a,i3)') '# targeted dump centred on full-grid (i,j,k) =', & + dbgpt_i, dbgpt_j, dbgpt_k, ' halo =', dbgpt_halo + write(dbgpt_unit,'(a)') '# it i j k (full grid) qc nc mu_c lamc qr nr mu_r lamr'// & + ' ze_ice ze_rain dbz nr_entry nr_posti nr_postw nr_posts'// & + ' qr_entry qr_posti qr_postw qr_posts'// & + ' dnr_ice ncautr nrslf nrevp'// & + ' qcacc_raw qcacc_fin accbr rwrad xvr'// & + ' then per ice category: qitot nitot qirim birim zitot diag_di' + endif + + write(dbgpt_unit,'(i8,3(1x,i6),28(1x,e13.6))',advance='no') & + it, i_loc+chksum_i0, j_loc+chksum_j0, k_loc, & + qc_l, nc_l, mu_c_l, lamc_l, qr_l, nr_l, mu_r_l, lamr_l, & + ze_ice_l, ze_rain_l, dbz_l, & + nr_entry_l, nr_posti_l, nr_postw_l, nr_posts_l, & + qr_entry_l, qr_posti_l, qr_postw_l, qr_posts_l, & + dnr_ice_l, ncautr_l, nrslf_l, nrevp_l, & + qcacc_r_l, qcacc_f_l, accbr_l, rwrad_l, xvr_l + do iice_d = 1,nCat_d + write(dbgpt_unit,'(6(1x,e13.6))',advance='no') & + qitot_l(iice_d), nitot_l(iice_d), qirim_l(iice_d), & + birim_l(iice_d), zitot_l(iice_d), diag_di_l(iice_d) + enddo + write(dbgpt_unit,'(a)') '' + flush(dbgpt_unit) + + end subroutine dbgpt_write + +!=========================================================================================== + + subroutine impose_max_Ni(nitot_local,max_Ni,i_rho_local,it,i_loc,j_loc,k_loc, & + qitot_local,zitot_local) !-------------------------------------------------------------------------------- ! Impose maximum ice number concentration on each ice category individually. ! Note, with this approach the maximum total concentration (sum of all categories) ! can in principle be nCat*max_Ni. +! +! The optional index/field arguments are used only by the limiter-firing log +! (log_limlog); they are read, never modified, and omitting them (or leaving +! log_limlog=.false.) leaves the clip below bit-identical. !-------------------------------------------------------------------------------- implicit none @@ -12844,10 +13366,32 @@ subroutine impose_max_Ni(nitot_local,max_Ni,i_rho_local) !arguments: real, intent(inout), dimension(:) :: nitot_local !note: dimension (nCat) real, intent(in) :: max_Ni,i_rho_local + integer, intent(in), optional :: it,i_loc,j_loc,k_loc + real, intent(in), dimension(:), optional :: qitot_local,zitot_local !local variables: real :: dum integer :: iice + real :: nmax_local,nbefore,qdum,zdum + +!--- limiter-firing log: record which categories the clip below actually binds +! on, BEFORE it is applied (diagnostic only; does not alter the clip) + if (log_limlog .and. present(it) .and. present(i_loc) .and. present(j_loc) & + .and. present(k_loc)) then + nmax_local = max_Ni*i_rho_local + do iice = 1,size(nitot_local) + if (nitot_local(iice) .gt. nmax_local) then + nbefore = nitot_local(iice) + qdum = 0. + zdum = 0. + if (present(qitot_local)) qdum = qitot_local(iice) + if (present(zitot_local)) zdum = zitot_local(iice) + call limlog_write('MAXNI ',it,i_loc,j_loc,k_loc,iice, & + nmax_local/max(nbefore,1.e-30), & + nbefore,nmax_local,qdum,zdum) + endif + enddo + endif nitot_local(:) = min(nitot_local(:),max_Ni*i_rho_local) diff --git a/src/mp_driver.F b/src/mp_driver.F index 997d117..9824317 100644 --- a/src/mp_driver.F +++ b/src/mp_driver.F @@ -34,7 +34,10 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & use lfoice_module, only : lfo_ice_drive,lfoice_init use module_mp_graupel , only : mp_graupel use module_mp_nssl_2mom, only : nssl_2mom_driver - use microphy_p3, only : mp_p3_wrapper_wrf + ! note: P3's qsmall (1.e-12) is a different quantity from the host's qsmall + ! in module input, which is used elsewhere in this file -- import it renamed + use microphy_p3, only : mp_p3_wrapper_wrf, limlog_write, log_limlog, & + qsmall_p3 => qsmall use module_mp_jensen_ishmael , only : mp_jensen_ishmael implicit none @@ -76,6 +79,10 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & integer :: i,j,k,n,ind_dhmax integer :: has_reqc,has_reqi,has_reqs,do_radar_ref real :: rdt + ! PREQR (limiter-firing log): mass-weighted mean rain diameter at the p3 + ! call, and the threshold above which the mass/number ratio is flagged. + real :: preqr_d + real, parameter :: preqr_dmax = 1.0e-3 if( stopit ) getdbz = .true. @@ -1168,7 +1175,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & p3a(i,k,23) = q3d(i,j,k,9) p3a(i,k,24) = q3d(i,j,k,10) ! ERM begin - IF ( trim(qunit(lccn)) /= 'none' ) THEN + IF ( lccn > 0 .and. trim(qunit(max(lccn,1))) /= 'none' ) THEN p3a(i,k,31) = q3d(i,j,k,lccn) ENDIF ! ERM end @@ -1225,7 +1232,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & q3d(i,j,k, 9) = p3a(i,k,23) ! nc q3d(i,j,k,10) = p3a(i,k,24) ! qzi_1 ! ERM begin - IF ( trim(qunit(lccn)) /= 'none' ) THEN + IF ( lccn > 0 .and. trim(qunit(max(lccn,1))) /= 'none' ) THEN q3d(i,j,k,lccn) = p3a(i,k,31) ! ccn ENDIF ! ERM end @@ -1655,7 +1662,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & p3a(i,k,27) = q3d(i,j,k, 6) ! nc_3d p3a(i,k,31) = q3d(i,j,k,14) ! qzi1_3d p3a(i,k,32) = q3d(i,j,k,15) ! qzi2_3d - IF ( trim(qunit(lccn)) /= 'none' ) THEN + IF ( lccn > 0 .and. trim(qunit(max(lccn,1))) /= 'none' ) THEN p3a(i,k,40) = q3d(i,j,k,lccn) ! ccna (added by ERM) ENDIF enddo @@ -1665,6 +1672,42 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & p3a(i,1,22) = 0.0 enddo + ! PRE-call state check (limiter-firing log, p3_limlog): does the host + ! hand P3 a category with ice mass but no number? P3 itself always + ! zeroes qitot and nitot together, so any such point was produced + ! outside p3_main -- host advection, sedimentation, or the tendency + ! application. Logged as PREQN into the same p3_limlog_NNNN.out, with + ! v1..v4 = qitot, nitot, qirim, zitot. Diagnostic only. + ! PREQR: does the host hand P3 rain whose mass and number are grossly + ! inconsistent? Unlike PREQN this is a ratio test, not a sign test -- + ! the mass-weighted mean diameter D = (6*qr/(pi*rhow*nr))**(1/3) is + ! compared against preqr_dmax. 1 mm is already large for the light-to- + ! moderate rain rates involved, and the scheme's own ceiling is 2 mm, + ! so anything flagged here is heading for the rain lambda limiter. + ! v1..v4 = qr, nr, qc, nc; ratio column carries D in metres. + IF ( log_limlog ) THEN + do k=1,nk + do i=1,ni + if (p3a(i,k,18).ge.qsmall_p3 .and. p3a(i,k,19).le.0.) & + call limlog_write('PREQN ',nstep,i,j,k,1,0., & + p3a(i,k,18),p3a(i,k,19),p3a(i,k,20),p3a(i,k,31)) + if (p3a(i,k,23).ge.qsmall_p3 .and. p3a(i,k,25).le.0.) & + call limlog_write('PREQN ',nstep,i,j,k,2,0., & + p3a(i,k,23),p3a(i,k,25),p3a(i,k,24),p3a(i,k,32)) + IF ( p3a(i,k,4).ge.qsmall_p3 ) THEN + if (p3a(i,k,5).le.0.) then + preqr_d = 999. ! no number at all for this mass + else + preqr_d = (6.0*p3a(i,k,4)/(3.14159265*1000.0*p3a(i,k,5)))**(1.0/3.0) + endif + if (preqr_d .gt. preqr_dmax) & + call limlog_write('PREQR ',nstep,i,j,k,0,preqr_d, & + p3a(i,k,4),p3a(i,k,5),p3a(i,k,3),p3a(i,k,27)) + ENDIF + enddo + enddo + ENDIF + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & qv = p3a(1,1,2), & qc = p3a(1,1,3), & @@ -1761,7 +1804,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & q3d(i,j,k, 6 ) = p3a(i,k,27) ! nc_3d q3d(i,j,k,14 ) = p3a(i,k,31) ! qzi1_3d q3d(i,j,k,15 ) = p3a(i,k,32) ! qzi2_3d - IF ( trim(qunit(lccn)) /= 'none' ) THEN ! Added by ERM + IF ( lccn > 0 .and. trim(qunit(max(lccn,1))) /= 'none' ) THEN ! Added by ERM q3d(i,j,k,lccn) = p3a(i,k,40) ! ccna ENDIF enddo diff --git a/src/param.F b/src/param.F index 8691fe4..b818f2e 100644 --- a/src/param.F +++ b/src/param.F @@ -74,7 +74,9 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & use module_mp_thompson , only : thompson_init use module_mp_graupel use microphy_p3, only : p3_init, log_chksum, chksum_myid, & - log_chkpts, chksum_i0, chksum_j0 + log_chkpts, chksum_i0, chksum_j0, & + log_limlog, limlog_ratmin, log_nifloor, log_nrfloor, & + dbgpt_i, dbgpt_j, dbgpt_k, dbgpt_halo use module_mp_jensen_ishmael, only : jensen_ishmael_init use module_mp_nssl_2mom, only: nssl_2mom_init, rho_qr, cnor, rho_qs, & cnos, rho_qh, rho_qhl, cnoh, ccn, irenuc, infall, alphah, alphahl, & @@ -164,6 +166,16 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & logical :: p3_cat_init_new = .true. ! switch for mechanism-based ice category initialization logical :: p3_chksum = .false. ! P3: write per-timestep bitwise field checksums to p3_chksum_NNNN.out (divergence diagnosis) logical :: p3_chkpts = .false. ! P3: write per-point raw bit patterns to p3_chkpts_NNNN.out (LARGE; short bracketing runs only) + logical :: p3_limlog = .false. ! P3: log every point-local limiter/gate firing to p3_limlog_NNNN.out (grid-point noise diagnosis) + real :: p3_limlog_rat = 0.9 ! P3: with p3_limlog, record conservation-limiter firings only when the applied ratio is below this + ! P3: targeted single-point dump to p3_dbgpt_NNNN.out (full-grid indices; p3_dbg_i<=0 disables) + integer :: p3_dbg_i = 0 + integer :: p3_dbg_j = 0 + integer :: p3_dbg_k = 0 + integer :: p3_dbg_halo = 1 ! P3: half-width of the block dumped around (p3_dbg_i,j,k); 0 = single point + ! TEMPORARY diagnostic switch -- remove after the grid-point-noise A/B concludes: + logical :: p3_nifloor = .true. ! P3: .false. disables every nitot/nc floor; ice or cloud with mass but no number keeps its mass and is rejected by nitot/nc conditions on the gates instead of running at an absurd mean size. NOTE: with .false. the exit clip no longer clears number-less ice, so that mass persists + logical :: p3_nrfloor = .true. ! P3: .false. disables every nr floor; rain with mass but no number keeps its mass and is rejected by nr conditions on the rain paths (get_rain_dsd2, ice collection, evaporation, sedimentation, ze_rain) instead of being given nr=nsmall, which would pin the drop spectrum at the maximum diameter and maximise ze_rain logical :: log_nislf = .true. ! switch to allow ice self-aggregation logical :: log_iceice_interaction = .true. ! switch to allow ice categories to interact integer :: p3_catdest_contact_n2 = 1 @@ -245,6 +257,14 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_cat_init_new,& p3_chksum, & p3_chkpts, & + p3_limlog, & + p3_limlog_rat, & + p3_nifloor, & + p3_nrfloor, & + p3_dbg_i, & + p3_dbg_j, & + p3_dbg_k, & + p3_dbg_halo, & qsum_invariant, & log_nislf, & log_iceice_interaction, & @@ -878,6 +898,14 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(p3_cat_init_new,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_chksum,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_chkpts,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_limlog,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_limlog_rat,1,MPI_REAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_nifloor,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_nrfloor,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_dbg_i,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_dbg_j,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_dbg_k,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_dbg_halo,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(qsum_invariant,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_nislf,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(log_iceice_interaction,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) @@ -4601,6 +4629,17 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! Phase-1/2 checksum instrumentation (category-swap divergence diagnosis): log_chksum = p3_chksum log_chkpts = p3_chkpts + ! limiter-firing log (grid-point noise diagnosis) + log_limlog = p3_limlog + limlog_ratmin = p3_limlog_rat + ! TEMPORARY -- remove with p3_nifloor + log_nifloor = p3_nifloor + log_nrfloor = p3_nrfloor + ! targeted single-point dump + dbgpt_i = p3_dbg_i + dbgpt_j = p3_dbg_j + dbgpt_k = p3_dbg_k + dbgpt_halo = p3_dbg_halo chksum_myid = myid ! global index = local index + offset (k is not decomposed): chksum_i0 = myi1-1 From 0124dd181968db256a457a01b71bde3ebc34a0ad Mon Sep 17 00:00:00 2001 From: "Dawson, Daniel T" Date: Wed, 5 Aug 2026 11:30:01 -0500 Subject: [PATCH 25/25] Updated small value gating and added H-M rime splintering namelist switch --- p3_smallvalue_gating_notes.md | 102 ++++++++++++++++++++ run/namelist.input | 2 + src/module_mp_p3.F | 172 ++++++++++++++++++++-------------- src/param.F | 34 ++++--- 4 files changed, 225 insertions(+), 85 deletions(-) diff --git a/p3_smallvalue_gating_notes.md b/p3_smallvalue_gating_notes.md index 2286384..fb618ce 100644 --- a/p3_smallvalue_gating_notes.md +++ b/p3_smallvalue_gating_notes.md @@ -382,3 +382,105 @@ any invariant whose precondition you have just changed. - Test case: `~/Projects/NCAR_P3/simulations/CM1r21/2km_P3_tests/2km050399_WC_drag_pcmaxni_iparam5_P354`. `ptype = 54`, `iparam = 5` (Cohard–Pinty), `p3_nimax = 2000.e3`, `p3_ccn_on = 0`, `dtl = 7.5`, 1500 s = 200 steps. + +--- + +## 11. Changes on disk as of 2026-08-05 + +Everything in §1–§10 above was committed as `48092ba`. What follows is what sat +uncommitted in `src/module_mp_p3.F` at the start of the 2026-08-05 session +(Daniel's edits between sessions), plus the `p3_hm_opt` work done in it. + +### 11.1 Daniel's edits — the gating campaign generalised + +The gate/floor logic of §3 was pushed through the rest of the scheme. ~25 gates +that tested only `q >= qsmall` now also test the matching number: + +- **`nc >= nsmall` added to:** ice-collects-cloud (`qccol`), the two + `t > 273.15` cloud-collection blocks (`qccoll` liqFrac, `qcshd`), `epsc`, + the `qccon` condensation statement, cloud self-collection, and rain-collects- + cloud accretion. +- **`nitot >= nsmall` added to:** all four `t > 273.15` collection blocks, + `qitot_notsmall` **and** `qitotcatcoll_notsmall` in ice-ice collection, + `nislf`, both melting branches, wet growth, `epsi`, the liqFrac refreeze/shed + block, `ice_present` in the HM block, all four dep/sub blocks, the `iice_loop2` + rime-fraction and `mu_i` blocks, rime densification during melting, the + liqFrac `>0.99` clip sum, and the 3-moment group-1 block (§11.2). +- **`nr >= nsmall` added to:** the `qrcon` statement, rain-collects-cloud + accretion, and `qr_not_small_2` (homogeneous rain freezing below 233.15 K). + +**This is consistent with §3 and it is the right direction** — it moves the +scheme from "floor the number and run at an absurd size" to "decline to act". +Three things to be aware of: + +1. These conditions are **unconditional**, not wrapped in the + `(log_nifloor .or. …)` short-circuit that §4.2/§4.3 used. That is fine for + bit-identity only *because* the floors, when on, guarantee `n >= nsmall` + wherever `q >= qsmall`; with `p3_nifloor = .true.` they are no-ops. It does + mean the two switch families are no longer the single place to look — a + future retirement of the switches (§9.6) has to account for these too. +2. Checked against the §3.3 rule (what does the `else` do?): none of the new + gates sits on an `if` whose `else` destroys mass. The riskiest ones are all + plain "skip the process" — no `else` at all, or an `else` that zeroes a rate + (`epsc`, `epsi`). No mass is silently returned to vapour. +3. `rimevolume`/`rimefraction`/`liquidfraction` (skipped at `iice_loop2` when + the new `nitot` test fails) are whole-array-zeroed once per `p3_main` call + and indexed `(i,k,iice)`, so a skipped point reads 0, not stale data. Their + consumers are weighted by `qicol`, which is itself zero for a gated-out + category. Safe. + +### 11.2 3-moment group-1 block: `dumni` gate replaces the `dumni` floor + +`dumni` is now computed **above** the `if`, the gate reads +`dumqi >= qsmall .and. dumni >= nsmall`, and `dumni = max(dumni,nsmall)` is +commented out. This is exactly the §3.1 floor→gate substitution applied to the +dummy state. The block has no `else`, and the group-2 `zitot` additions below it +are unconditional, so a rejected point simply leaves `zitot` alone. Daniel's +in-line question (`! DTD: should we also gate on dumni > nsmall?`) is answered +by the code beneath it. No concerns. + +### 11.3 Hallett-Mossop source was flipped by commenting + +The cloud-riming splinter block had been uncommented and the rain-riming block +commented out — the reverse of `48092ba`. Two side effects of that particular +edit, both now gone (§11.4): + +- `qrmul_dp`/`nimul_dp` were left initialised and applied but never accumulated, + so the post-loop application added zero. +- The cloud path accumulated `qcmul(iice_dest)`/`nimul(iice_dest)` **inside** the + category loop in single precision — reintroducing precisely the fixed-slot-order + sum that the comment three lines above says was removed as a + category-relabeling roundoff seed. + +### 11.4 New: `p3_hm_opt` (this session) + +Rime splintering is now a namelist option instead of a comment-block choice. +`&p3_params`, plumbed like `p3_qrcol_opt` (declaration + `NAMELIST` + `MPI_BCAST` +in `param.F`, optional `p3_hm_opt` argument on all 15 `p3_init` call sites, +clamped to `[0,3]` in `p3_init`, module variable `hm_opt` in `module_mp_p3.F`). + +| `p3_hm_opt` | behaviour | +|---|---| +| 0 | off entirely — `calc_HM` is skipped regardless of `log_hmossopOn` | +| 1 | riming of **cloud** droplets only (`qccol → qcmul`) — **default** | +| 2 | riming of **rain** only (`qrcol → qrmul`) — original P3 / commit `48092ba` | +| 3 | both | + +`hm_opt` is decoded once per `p3_main` call into two locals, `hm_cloud` and +`hm_rain`, which appear both in `HM_conditions_met` (at least one enabled source +must be collecting) and on each splintering branch. + +Notes: + +- **The default is 1**, chosen to reproduce the working tree as found, not + commit `48092ba`. One line in `src/param.F` if that is the wrong call. +- `log_hmossopOn` is unchanged and still independent: for `nCat = 1` it is the + seasonal `t(i,kbot) < 278 K` proxy. `p3_hm_opt = 0` overrides it; nothing + overrides `log_hmossopOn = .false.`. +- **Both** paths now accumulate into double-precision `qcmul_dp`/`qrmul_dp`/ + `nimul_dp` and are applied to `iice_dest` once after the loop, restoring the + category-order invariance of §11.3. `qcmul_dp` is new. For `nCat = 1` this is + an exact no-op (single term, `dble`→`sngl` round-trips exactly); **for + `nCat > 1` with `p3_hm_opt = 1` it changes the last bits** relative to the + working tree as found. `p3_hm_opt = 2` should be bit-identical to `48092ba`. +- Builds clean (`cd src && make`). **Not yet run.** diff --git a/run/namelist.input b/run/namelist.input index 01a26ba..90f148d 100644 --- a/run/namelist.input +++ b/run/namelist.input @@ -451,6 +451,8 @@ p3_ccn_on = 0, p3_merge_opt = 1, p3_qrcol_opt = 0, + p3_hm_opt = 1, ! Hallett-Mossop rime splintering: 0 = off, 1 = riming of cloud only, + ! 2 = riming of rain only (original P3), 3 = both rssflg = 1, sssflg = 1, p3_cat_init_new = .true., diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index d77b6d5..b679a54 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -280,6 +280,16 @@ MODULE microphy_p3 ! 0 = no merging; 1 = diameter-difference merge (original); 2 = percent difference in diam. (Cholette 2024) integer :: qrcol_opt = 0 ! 0 = no size check on qrcol; 1 = only allow qrcol for ice larger than rain ! for merge_opt=0 with qrcol_opt=2 and ncat=2, this disables qrcol for iice=2 + ! DTD: Hallett-Mossop rime-splintering source selection (host namelist p3_hm_opt). + ! Which riming source feeds the splinter production in the calc_HM block; both + ! sources use the same 350 splinters per mg of rime accreted, and the splinter + ! mass is removed from the corresponding collection tendency. Previously this + ! was chosen by commenting one of the two blocks in or out. + ! 0 = off entirely (no rime splintering, regardless of log_hmossopOn) + ! 1 = riming of cloud droplets only (qccol -> qcmul) + ! 2 = riming of rain only (qrcol -> qrmul) [original P3 behaviour] + ! 3 = both + integer :: hm_opt = 1 logical :: cat_init_new = .true. ! default for mechanism-based ice category initialization logical :: log_iceice_interaction = .true. ! default for allowing ice categories to interact ! DTD: the _n5/_n6 defaults continue the progressive split of the _n2..._n4 @@ -323,7 +333,7 @@ MODULE microphy_p3 !==================================================================================================! subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err,dowr, & - nanew1_in,iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt,iparamice_in, & + nanew1_in,iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt,p3_hm_opt,iparamice_in, & rssflg_in,sssflg_in,max_Ni_in,cat_init_new_in, & log_nislf_in, & log_iceice_interaction_in, & @@ -366,7 +376,7 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err ! Added by ERM real, intent(in), optional :: nanew1_in, max_Ni_in integer, intent(in), optional :: iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt, & - iparamice_in,rssflg_in,sssflg_in + p3_hm_opt,iparamice_in,rssflg_in,sssflg_in logical, intent(in), optional :: cat_init_new_in logical, intent(in), optional :: log_nislf_in logical, intent(in), optional :: log_iceice_interaction_in @@ -460,6 +470,7 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err IF ( present( p3_ccn_on ) ) ccn_on = p3_ccn_on IF ( present( p3_merge_opt ) ) merge_opt = p3_merge_opt IF ( present( p3_qrcol_opt ) ) qrcol_opt = p3_qrcol_opt + IF ( present( p3_hm_opt ) ) hm_opt = min(3,max(0,p3_hm_opt)) IF ( present( cat_init_new_in ) ) cat_init_new = cat_init_new_in IF ( present( log_nislf_in ) ) log_nislf = log_nislf_in IF ( present( log_iceice_interaction_in ) ) log_iceice_interaction = log_iceice_interaction_in @@ -2695,7 +2706,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! independent of which slot holds which species (NEXT PROJECT / audit sec. 4(c)). double precision :: dqc_dp,dnc_dp,dqr_dp,dnr_dp,dqv_dp,dth_dp ! iice_loop3 shared-field tendencies double precision :: clipsum_qr,clipsum_nr ! post-loop3 liquid-fraction shed clip (qr/nr/th deferred) - double precision :: nimul_dp,qrmul_dp ! category-order-invariant Hallett-Mossop accumulation into iice_dest + double precision :: nimul_dp,qcmul_dp,qrmul_dp ! category-order-invariant Hallett-Mossop accumulation into iice_dest ! deferred ice-ice interaction cross-category contributions to the per-category ! ice fields, accumulated in double precision so the result is invariant to ! category slot order (applied once, after iice_loop3, before the per-category @@ -2716,6 +2727,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi logical :: log_nucleationPossible,log_hydrometeorsPresent,log_predictSsat, & log_exitlevel,log_hmossopOn,log_qxpresent,log_test ! ERM added log_test + ! DTD: decoded form of hm_opt (host namelist p3_hm_opt), set once below + logical :: hm_cloud,hm_rain ! quantities related to process rates/parameters, interpolated from lookup tables: @@ -2991,6 +3004,13 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !log_hmossopOn = .true. !switch to have Hallet-Mossop ON !log_hmossopOn = .false. !switch to have Hallet-Mossop OFF +! DTD: decode the Hallett-Mossop source selection (host namelist p3_hm_opt). +! 0 = off, 1 = riming of cloud only, 2 = riming of rain only, 3 = both. +! hm_opt = 0 shuts the calc_HM block off outright, independently of the +! nCat=1 seasonal log_hmossopOn switch set in the i-loop below. + hm_cloud = (hm_opt == 1 .or. hm_opt == 3) + hm_rain = (hm_opt == 2 .or. hm_opt == 3) + ! Note (BUG), I think SCF, SPF,... should be initialize here with scpf_on=.false. ! initialize the qiliq to 0. to allow gereralized use even if liqFrac is not used @@ -3647,7 +3667,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ex: rhofaci is grid-mean, f1pr04 is grid-mean, qc*iSCF is in-cloud, ! eci is a constant, rho(i,k) is grid-mean, nitot*iSCF is in-cloud ! (qc*iSCF*nitot*iSCF)*SCF = (qc*nitot)*iSCF to obtain grid-mean qccol - if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qc(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check, ERM added nitot check ! DTD: changed to .ge. from > to ensure case where nitot = nsmall is included. + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall .and. t(i,k).le.273.15) then ! diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check, ERM added nitot check ! DTD: changed to .ge. from > to ensure case where nitot = nsmall is included. qccol(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) @@ -3690,7 +3710,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! for T > 273.15, assume cloud water is collected and shed as rain drops if (log_LiquidFrac) then ! assume cloud water is collected by qiliq - if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall .and. t(i,k).gt.273.15) then qccoll(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccoll(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) if(log_3momentIce) then @@ -3699,7 +3719,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! assume collected rain by qiliq ! TEMPORARY (log_nrfloor): nr condition guards logn0r (see above) - if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. & + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. qr(i,k).ge.qsmall .and. & (log_nrfloor .or. nr(i,k).ge.nsmall) .and. t(i,k).gt.273.15) then ! note: f1pr08 and logn0r are already calculated as log_10 qrcoll(iice) = 10.**(f1pr08+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) @@ -3710,7 +3730,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif else ! assume cloud water is collected and shed as rain drops (original code) - if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall .and. t(i,k).gt.273.15) then ! sink for cloud water mass and number, note qcshed is source for rain mass qcshd(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) @@ -3722,7 +3742,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! assume collected rain number is shed as 1 mm drops (original code) ! collection of rain above freezing does not impact total rain mass ! TEMPORARY (log_nrfloor): nr condition guards logn0r (see above) - if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. & + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. qr(i,k).ge.qsmall .and. & (log_nrfloor .or. nr(i,k).ge.nsmall) .and. t(i,k).gt.273.15) then ! rain number sink due to collection nrcol(iice) = 10.**(f1pr07 + logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) @@ -3750,9 +3770,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! In a forthcoming version, both LT1-2momI and LT2 (and LT1-3momI) will all be computed ! using the unconstrained size limited (i.e. Dm_max=400000.e-6). - qitot_notsmall: if (qitot(i,k,iice).ge.qsmall) then + qitot_notsmall: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then catcoll_loop: do catcoll = 1,iice-1 - qitotcatcoll_notsmall: if (qitot(i,k,catcoll).ge.qsmall) then + qitotcatcoll_notsmall: if (qitot(i,k,catcoll).ge.qsmall .and. nitot(i,k,catcoll).ge.nsmall) then ! first, calculate collection of catcoll category by iice category @@ -3838,7 +3858,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! in the lookup table calculations ! note 'f1pr' values are normalized, so we need to multiply by N - if (qitot(i,k,iice).ge.qsmall .and. log_nislf) then ! ERM added log_nislf. + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. log_nislf) then ! ERM added log_nislf. nislf(iice) = f1pr03*rho(i,k)*eii*Eii_fact(iice)*rhofaci(i,k)*nitot(i,k,iice)*nitot(i,k,iice)*iSCF(k) if (log_3momentIce) then ! NOTE: already correct sign from lookup table, thus not multiplied by -1 @@ -3856,7 +3876,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (log_LiquidFrac) then ! some portion of the melted water stays into qiliq --> qimlt(iice) (D>Dth) ! the other portion melts into rain --> qrmlt(iice) (D<=Dth) - if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. t(i,k).gt.273.15) then + if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. t(i,k).gt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) dum = 0. qrmlt(iice) = ((f1pr24+f1pr25*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*((t(i,k)- & @@ -3886,7 +3906,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif else - if (qitot(i,k,iice).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. t(i,k).gt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) ! dum=cpw/xlf(i,k)*(t(i,k)-273.15)*(pracsw1+qcshd(iice)) ! currently enhanced melting from collision is neglected @@ -3914,7 +3934,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! similar to Musil (1970), JAS ! note 'f1pr' values are normalized, so we need to multiply by N - if (qitot(i,k,iice).ge.qsmall .and. (qc(i,k)+qr(i,k)).ge.1.e-6 .and. t(i,k).lt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. (qc(i,k)+qr(i,k)).ge.1.e-6 .and. t(i,k).lt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) qwgrth(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*((t(i,k)- & @@ -3968,7 +3988,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !Note (BUG) insert *iSCF(k) because epsi and epsiw needs to be in-cloud (to be done) !if (log_LiquidFrac) then - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then if ((qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then epsi(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* & rho(i,k)*dv)*nitot(i,k,iice) @@ -4016,7 +4036,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !............................................................ if (log_LiquidFrac) then - if (qiliq(i,k,iice).ge.qsmall .and. qitot(i,k,iice).ge.qsmall) then + if (qiliq(i,k,iice).ge.qsmall .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then ! Refreezing if (t(i,k).lt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) @@ -4027,7 +4047,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! Shedding tmp1=0. - if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall) tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) + if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) ! Shedding qlshd(iice) = tmp1*f1pr28*nitot(i,k,iice)*qiliq(i,k,iice)/qitot(i,k,iice) qlshd(iice) = min(max(0.,qlshd(iice)),qiliq(i,k,iice)*odt) @@ -4253,11 +4273,13 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! rime splintering (Hallet-Mossop 1974) ! Rime splintering occurs from accretion of large drops (>25 microns diameter) -! by large, rimed, fully-frozen ice. For simplicitly it is assumed that all -! accreted rain contributes to splintering, but accreted cloud water does not. +! by large, rimed, fully-frozen ice. Which riming source is allowed to produce +! splinters is set by hm_opt (host namelist p3_hm_opt): 0 = off, 1 = cloud only, +! 2 = rain only (the original P3 assumption, that all accreted rain contributes +! but accreted cloud water does not), 3 = both. ! It only occurs in the temperature range of -8C < T -3C. - calc_HM: if (log_hmossopOn .and. t(i,k).gt.265.15 .and. t(i,k).lt.270.15) then + calc_HM: if (hm_opt.gt.0 .and. log_hmossopOn .and. t(i,k).gt.265.15 .and. t(i,k).lt.270.15) then if (nCat>1) then !determine destination ice-phase category @@ -4293,21 +4315,26 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! it to the destination category once after the loop. iice_dest is the ! (swapped) rimesplinter destination, so the original fixed-slot-order ! sum over source categories was a category-relabeling roundoff seed. + qcmul_dp = 0.d0 qrmul_dp = 0.d0 nimul_dp = 0.d0 iice_loop_HM: do iice = 1,nCat - ice_present: if (qitot(i,k,iice)-qiliq(i,k,iice) .ge. qsmall) then + ice_present: if (qitot(i,k,iice)-qiliq(i,k,iice) .ge. qsmall .and. nitot(i,k,iice) .ge. nsmall) then tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) ! rime fraction tmp2 = qiliq(i,k,iice)/qitot(i,k,iice) ! liquid fraction + ! DTD: hm_opt selects which riming source(s) may splinter; at least + ! one enabled source must actually be collecting for the block to do + ! anything, so the source positivity tests are folded in here (and + ! repeated per branch below). HM_conditions_met: if (diam_ice(i,k,iice).ge.Dmin_HM .and. & tmp1.gt.0.5 .and. & tmp2.lt.0.1 .and. & ! tmp2.lt.0.1 .and. & DTD: changed to 0.01 - ! qccol(iice).gt.0. .and. & - qrcol(iice).gt.0.) then + ( (hm_cloud .and. qccol(iice).gt.0.) .or. & + (hm_rain .and. qrcol(iice).gt.0.) ) ) then if (t(i,k).lt.270.15 .and. t(i,k).gt.268.15) then dum = (270.15-t(i,k))*0.5 @@ -4315,37 +4342,39 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum = (t(i,k)-265.15)*thrd endif - !rime splintering from riming of cloud droplets: - ! (commented out to exclude rime splintering from accretion of cloud, - ! but code is retained in case of possible future use) - ! dum1 = 35.e+4*qccol(iice)*dum*1000. ! 1000 is to convert kg to g - ! dum2 = dum1*piov6*900.*Dinit_HM**3 - ! dum3 = (qccol(iice)-dum2)/qccol(iice) - ! qccol(iice) = qccol(iice)-dum2 ! subtract splintering from rime mass transfer - ! if (log_3momentIce) then - ! zqccol(iice) = dum3*zqccol(iice) - ! endif - ! if (qccol(iice) .lt. 0.) then - ! dum2 = qccol(iice) + dum2 - ! qccol(iice) = 0. - ! endif - ! qcmul(iice_dest) = qcmul(iice_dest) + dum2 - ! nimul(iice_dest) = nimul(iice_dest) + dum1 - - !rime splintering from riming of rain: - dum1 = 35.e+4*qrcol(iice)*dum*1000. ! 1000 is to convert kg to g - dum2 = dum1*piov6*900.*Dinit_HM**3 - dum3 = (qrcol(iice)-dum2)/qrcol(iice) - qrcol(iice) = qrcol(iice) - dum2 ! subtract splintering from rime mass transfer - if (log_3momentIce) then - zqrcol(iice) = dum3*zqrcol(iice) - endif - if (qrcol(iice) .lt. 0.) then - dum2 = qrcol(iice) + dum2 - qrcol(iice) = 0. + !rime splintering from riming of cloud droplets: (hm_opt = 1 or 3) + if (hm_cloud .and. qccol(iice).gt.0.) then + dum1 = 35.e+4*qccol(iice)*dum*1000. ! 1000 is to convert kg to g + dum2 = dum1*piov6*900.*Dinit_HM**3 + dum3 = (qccol(iice)-dum2)/qccol(iice) + qccol(iice) = qccol(iice)-dum2 ! subtract splintering from rime mass transfer + if (log_3momentIce) then + zqccol(iice) = dum3*zqccol(iice) + endif + if (qccol(iice) .lt. 0.) then + dum2 = qccol(iice) + dum2 + qccol(iice) = 0. + endif + qcmul_dp = qcmul_dp + dble(dum2) + nimul_dp = nimul_dp + dble(dum1) + endif + + !rime splintering from riming of rain: (hm_opt = 2 or 3) + if (hm_rain .and. qrcol(iice).gt.0.) then + dum1 = 35.e+4*qrcol(iice)*dum*1000. ! 1000 is to convert kg to g + dum2 = dum1*piov6*900.*Dinit_HM**3 + dum3 = (qrcol(iice)-dum2)/qrcol(iice) + qrcol(iice) = qrcol(iice) - dum2 ! subtract splintering from rime mass transfer + if (log_3momentIce) then + zqrcol(iice) = dum3*zqrcol(iice) + endif + if (qrcol(iice) .lt. 0.) then + dum2 = qrcol(iice) + dum2 + qrcol(iice) = 0. + endif + qrmul_dp = qrmul_dp + dble(dum2) + nimul_dp = nimul_dp + dble(dum1) endif - qrmul_dp = qrmul_dp + dble(dum2) - nimul_dp = nimul_dp + dble(dum1) endif HM_conditions_met @@ -4354,6 +4383,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop_HM ! apply the deferred, category-order-invariant HM accumulation once + qcmul(iice_dest) = qcmul(iice_dest) + sngl(qcmul_dp) qrmul(iice_dest) = qrmul(iice_dest) + sngl(qrmul_dp) nimul(iice_dest) = nimul(iice_dest) + sngl(nimul_dp) @@ -4388,7 +4418,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi epsr = 0. endif - if (qc(i,k).ge.qsmall) then + if (qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall) then epsc = 2.*pi*rho(i,k)*dv*cdist(i,k) else epsc = 0. @@ -4471,12 +4501,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !Note (BUG) the following three bug fixed change the solution with scpf_on=.false. - if (qc(i,k).ge.qsmall) & + if (qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall) & !Note (BUG): Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon ! qccon = ((aaa*epsc*oxx+(ssat_cld-aaa*oxx)*odt*epsc*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab)*SCF(k) ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qc qccon = (aaa*epsc*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsc*oxx*(1.d0-dexp(-dble(xx*dt))))/ab - if (qr(i,k).ge.qsmall) & + if (qr(i,k).ge.qsmall .and. nr(i,k).ge.nsmall) & !Note (BUG): Cholette (Jul 2022), remove *SPF(k) for ssat_r and multiplication *SPF for grid-mean qccon ! qrcon = ((aaa*epsr*oxx+(ssat_r-aaa*oxx)*odt*epsr*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab)*SPF(k) ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qr @@ -4522,7 +4552,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! if (log_LiquidFrac) then - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then if ( (qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then ! ERM split off second part into separate if ! Sublimation/deposition of ice !note: diffusional growth/decay rate: (stored as 'qidep' temporarily; may go to qisub below) @@ -4536,7 +4566,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif !for very small ice contents in dry air, sublimate all ice instantly. DTD: check if we need an nitot check here - if (supi_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall ) then ! ERM split off second part into separate if + if (supi_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then ! ERM split off second part into separate if if (qiliq(i,k,iice)/qitot(i,k,iice).lt.0.01) then qidep(iice) = -(qitot(i,k,iice)-qiliq(i,k,iice))*odt endif @@ -4569,7 +4599,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then if ((qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then ! ERM split off second part into separate if ! Condensation/evaporation fo qiliq !Note (BUG) Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon @@ -4581,7 +4611,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! ERM inner if/else endif ! DTD: check if we need an nitot check here - if (sup_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall ) then ! ERM split off second part into separate if + if (sup_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then ! ERM split off second part into separate if if ( (qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) qlcon(iice) = -qiliq(i,k,iice)*odt endif @@ -5029,7 +5059,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !............................ ! self-collection of droplets - if (qc(i,k).ge.qsmall) then + if (qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall) then if (iparam.eq.1) then !Seifert and Beheng (2001) @@ -5050,7 +5080,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !............................ ! accretion of cloud by rain - if (qr(i,k).ge.qsmall .and. qc(i,k).ge.qsmall) then + if (qr(i,k).ge.qsmall .and. qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall .and. nr(i,k).ge.nsmall) then if (iparam.eq.1) then !Seifert and Beheng (2001) @@ -5429,7 +5459,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! compute fractions before update (assumed constant during ice-ice coll.) iice_loop2: do iice = 1,nCat - if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall) then + if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. (nitot(i,k,iice)).ge.nsmall) then tmp1 = 1./(qitot(i,k,iice)-qiliq(i,k,iice)) rimevolume(i,k,iice) = birim(i,k,iice)*tmp1 rimefraction(i,k,iice) = qirim(i,k,iice)*tmp1 @@ -5441,7 +5471,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi mu_i_s(iice)=mu_i_initial - if (qitot(i,k,iice).ge.qsmall & + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall & .and. f1pr16_s(iice).gt.0.) then ! f1pr16_s check: use THIS category's density from its own lookup ! this step; if the lookup did not run, keep mu_i_initial rather @@ -5633,7 +5663,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi birim(i,k,iice) = qirim(i,k,iice)*inv_rho_rimeMax endif ! densify rimed ice during melting (tend rime density towards solid ice [917 kg m-3]) - if (.not. log_LiquidFrac .and. qitot(i,k,iice).ge.qsmall .and. birim(i,k,iice).ge.bsmall .and. qrmlt(iice)>0.) then + if (.not. log_LiquidFrac .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. birim(i,k,iice).ge.bsmall .and. qrmlt(iice)>0.) then tmp1 = qirim(i,k,iice)/birim(i,k,iice) ! rho_i before densification tmp2 = qitot(i,k,iice) + qrmlt(iice)*dt ! qitot before melting (but after all other updates) birim(i,k,iice) = qirim(i,k,iice)/(tmp1+(917.-tmp1)*qrmlt(iice)*dt/tmp2) @@ -5719,7 +5749,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi clipsum_nr = 0.d0 clipsum_th = 0.d0 do iice = 1,nCat - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then if ((qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then ! ERM split conditional to avoid div by zero clipsum_qr = clipsum_qr + dble(qitot(i,k,iice)) clipsum_nr = clipsum_nr + dble(nitot(i,k,iice)) @@ -5809,17 +5839,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! include all processes **except** group 2 processes which are added later below ! thus, all group 2 processes are subtracted from the ice variables below + ! DTD: should we also gate on dumni > nsmall? dumqi = qitot(i,k,iice) - (qinuc(iice)+qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice))*dt + dumni = nitot(i,k,iice) - (ninuc(iice)+nrhetc(iice)+nrheti(iice)+nchetc(iice)+ncheti(iice)+nimul(iice))*dt - if (dumqi.ge.qsmall) then + if (dumqi.ge.qsmall .and. dumni.ge.nsmall) then - dumni = nitot(i,k,iice) - (ninuc(iice)+nrhetc(iice)+nrheti(iice)+nchetc(iice)+ncheti(iice)+nimul(iice))*dt + ! dumni = nitot(i,k,iice) - (ninuc(iice)+nrhetc(iice)+nrheti(iice)+nchetc(iice)+ncheti(iice)+nimul(iice))*dt dumzi = zitot(i,k,iice) dumqr = qirim(i,k,iice) - (qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qcmul(iice)+qrmul(iice))*dt ! DTD: added qcmul dumbi = birim(i,k,iice) - (qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qcmul(iice)+qrmul(iice))*inv_rho_rimeMax*dt ! DTD: added qcmul dumql = qiliq(i,k,iice) - dumni = max(dumni,nsmall) ! impose limit on dummy ni + ! dumni = max(dumni,nsmall) ! impose limit on dummy ni dumzi = max(dumzi,zsmall) ! impose limit on dummy zi !....................... @@ -6996,7 +7028,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif qc_not_small_2 - qr_not_small_2: if (qr(i,k).ge.qsmall .and. t(i,k).lt.233.15) then + qr_not_small_2: if (qr(i,k).ge.qsmall .and. nr(i,k).ge.nsmall .and. t(i,k).lt.233.15) then Q_nuc = qr(i,k) if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny diff --git a/src/param.F b/src/param.F index b818f2e..f6c903d 100644 --- a/src/param.F +++ b/src/param.F @@ -161,6 +161,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & integer :: p3_merge_opt = 1 ! 0 = no merging; 1 = diameter-difference merge (original); 2 = percent difference in diam. (Cholette 2024) integer :: p3_qrcol_opt = 0 ! 0 = no size check on qrcol; 1 = only allow qrcol for ice larger than rain ! for p3_merge_opt=0 with p3_qrcol_opt=2 and ncat=2, this disables qrcol for iice=2 + integer :: p3_hm_opt = 1 ! P3: Hallett-Mossop rime-splintering source: 0 = off, 1 = riming of cloud droplets only, + ! 2 = riming of rain only (original P3 behaviour), 3 = both integer :: rssflg = 1 ! P3: Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value integer :: sssflg = 1 ! P3: As for rain but for ice (all ice) logical :: p3_cat_init_new = .true. ! switch for mechanism-based ice category initialization @@ -252,6 +254,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & p3_ccn_on, & p3_merge_opt, & p3_qrcol_opt, & + p3_hm_opt, & rssflg, & sssflg, & p3_cat_init_new,& @@ -893,6 +896,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(p3_ccn_on ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_merge_opt,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_qrcol_opt,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_hm_opt,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(rssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(sssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(p3_cat_init_new,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) @@ -4242,7 +4246,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & ! ERM added new p3 options (all calls) - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4266,7 +4270,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4290,7 +4294,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4314,7 +4318,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4338,7 +4342,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4362,7 +4366,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4386,7 +4390,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4410,7 +4414,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4434,7 +4438,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4458,7 +4462,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4482,7 +4486,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4506,7 +4510,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4537,7 +4541,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4568,7 +4572,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, & @@ -4599,7 +4603,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & stat=p3stat, & abort_on_err=.false., & dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & - p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & cat_init_new_in=p3_cat_init_new, & log_nislf_in=log_nislf, &