diff --git a/CODEOWNERS b/CODEOWNERS index 2e6e555ef..8d9809c64 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -128,7 +128,6 @@ physics/SFC_Models/Ocean/UFS/sfc_ocean.* @He physics/SFC_Models/SeaIce/CICE/sfc_cice.* @wd20xw @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/SFC_Models/SeaIce/CICE/sfc_sice.* @wd20xw @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/hooks/machine.* @grantfirl @rhaesung @Qingfu-Liu @dustinswales -physics/hooks/physcons.F90 @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/photochem/module_h2ophys.* @Qingfu-Liu @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/photochem/module_ozphys.* @dustinswales @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/smoke_dust/* @haiqinli @grantfirl @rhaesung @Qingfu-Liu @dustinswales @@ -149,7 +148,7 @@ physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.* physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.* @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.* @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.* @grantfirl @rhaesung @Qingfu-Liu @dustinswales -physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.* @grantfirl @rhaesung @Qingfu-Liu @dustinswales +physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.* @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.* @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.* @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.* @dustinswales @Qingfu-Liu @grantfirl @rhaesung @Qingfu-Liu @dustinswales diff --git a/physics/CONV/C3/cu_c3_driver.F90 b/physics/CONV/C3/cu_c3_driver.F90 index c7e1c1f8c..c16fc0737 100644 --- a/physics/CONV/C3/cu_c3_driver.F90 +++ b/physics/CONV/C3/cu_c3_driver.F90 @@ -5,7 +5,6 @@ module cu_c3_driver ! DH* TODO: replace constants with arguments to cu_c3_driver_run - !use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv use machine , only: kind_phys use cu_c3_deep, only: cu_c3_deep_run,neg_check,fct1d3 use cu_c3_sh , only: cu_c3_sh_run diff --git a/physics/CONV/Chikira_Sugiyama/cs_conv.F90 b/physics/CONV/Chikira_Sugiyama/cs_conv.F90 index 84a06f377..a0e412be4 100644 --- a/physics/CONV/Chikira_Sugiyama/cs_conv.F90 +++ b/physics/CONV/Chikira_Sugiyama/cs_conv.F90 @@ -8,31 +8,18 @@ module cs_conv !>--------------------------------------------------------------------------------- ! Purpose: ! -!> Interface for Chikira-Sugiyama convection scheme +!> Interface for Chikira-Sugiyama convection scheme !! !! Author: Minoru Chikira !--------------------------------------------------------------------------------- ! use machine , only : kind_phys - use physcons, only : cp => con_cp, grav => con_g, & - & rair => con_rd, rvap => con_rv, & - & cliq => con_cliq, cvap => con_cvap, & - & epsv => con_eps, epsvm1 => con_epsm1, & - & epsvt => con_fvirt, & - & el => con_hvap, emelt => con_hfus, t0c => con_t0c use funcphys, only : fpvs ! this is saturation vapor pressure in funcphys.f - - implicit none private ! Make default type private to the module real(kind_phys), parameter :: zero=0.0d0, one=1.0d0, half=0.5d0 - real(kind_phys), parameter :: cpoel=cp/el, cpoesub=cp/(el+emelt), esubocp=1.0/cpoesub, & - elocp=el/cp, oneocp=one/cp, gocp=grav/cp, gravi=one/grav,& - emeltocp=emelt/cp, cpoemelt=cp/emelt, epsln=1.e-10_kind_phys - - real(kind_phys), parameter :: fact1=(cvap-cliq)/rvap, fact2=el/rvap-fact1*t0c !< to calculate d(qs)/dT logical, parameter :: adjustp=.true. ! logical, parameter :: adjustp=.false. @@ -87,7 +74,7 @@ module cs_conv ! PUBLIC: interfaces ! public cs_conv_run ! CS scheme main driver - + contains !>\defgroup cs_scheme Chikira-Sugiyama Cumulus Scheme Module @@ -124,7 +111,7 @@ module cs_conv !! Also, added an extra iteration in this k loop. Reduced some memory. !! - June 2018 : S. Moorthi - the output mass fluxes ud_mf, dd_mf and dt_mf are over time step delta !! -!! \b Arakawa-Wu \b implemtation: +!! \b Arakawa-Wu \b implemtation: !! for background, consult An Introduction to the !! General Circulation of the Atmosphere, Randall, chapter six. !! Traditional parameterizations compute tendencies like those in eq 103, 105 and 106. @@ -142,7 +129,7 @@ module cs_conv !! !! !! JLS NOTE: The convective mass fluxes (dt_mf, dd_mf and ud_mf) passed in and out of cs_conv have not been multiplied by -!! the timestep (kg/m2/sec) as they are in all other convective schemes. EMC is aware of this problem, +!! the timestep (kg/m2/sec) as they are in all other convective schemes. EMC is aware of this problem, !! and in the future will be fixing this discrepancy. In the meantime, CCPP will use the same mass flux standard_name !! and long_name as the other convective schemes, where the units are in kg/m2. (Aug 2018) !! @@ -163,7 +150,14 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & lprnt , ipr, kcnv, & QLCN, QICN, w_upi, cf_upi, CNV_MFD, & ! for coupling to MG microphysics CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE, & - mp_phys,errmsg,errflg) + mp_phys, & + cp, grav, & + rair, rvap, & + cliq, cvap, & + epsv, epsvm1, & + epsvt, & + el, emelt, t0c, & + errmsg,errflg) implicit none @@ -202,10 +196,10 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & ! updraft, downdraft, and detrainment mass flux (kg/m2/s) real(kind_phys), intent(inout), dimension(:,:) :: ud_mf real(kind_phys), intent(inout), dimension(:,:) :: dd_mf, dt_mf - + real(kind_phys), intent(out) :: rain1(:) ! lwe thickness of deep convective precipitation amount (m) ! GJF* These variables are conditionally allocated depending on whether the -! Morrison-Gettelman microphysics is used, so they must be declared +! Morrison-Gettelman microphysics is used, so they must be declared ! using assumed shape. real(kind_phys), intent(out), dimension(:,:), optional :: qlcn, qicn, w_upi,cnv_mfd, & cnv_dqldt, clcn, cnv_fice, & @@ -218,7 +212,7 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & integer, intent(out) :: errflg !DDsigma - output added for AW sigma diagnostics -! interface sigma and vertical velocity by cloud type (1=sfc) +! interface sigma and vertical velocity by cloud type (1=sfc) ! real(kind_phys), intent(out), dimension(:,:,:) :: sigmai, vverti real(kind_phys), intent(out), dimension(:,:) :: sigma ! sigma sigma totaled over cloud type - on interfaces (1=sfc) ! sigma terms in eq 91 and 92 @@ -266,6 +260,27 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & real(kind_phys) :: ftintm, wrk, wrk1, tem integer i, k, n, ISTS, IENS, kp1 + real(kind_phys), intent(in) :: cp !< specific heat of dry air at constant pressure [J kg-1 K-1] + real(kind_phys), intent(in) :: grav !< gravitational acceleration [m s-2] + real(kind_phys), intent(in) :: rair !< ideal gas constant for dry air [J kg-1 K-1] + real(kind_phys), intent(in) :: rvap !< ideal gas constant for water vapor [J kg-1 K-1] + real(kind_phys), intent(in) :: cliq !< specific heat of liquid water at constant pressure [J kg-1 K-1] + real(kind_phys), intent(in) :: cvap !< specific heat of water vapor at constant pressure [J kg-1 K-1] + real(kind_phys), intent(in) :: epsv !< rd/rv + real(kind_phys), intent(in) :: epsvm1 !< (rd/rv) - 1 + real(kind_phys), intent(in) :: epsvt !< (rv/rd) - 1 + real(kind_phys), intent(in) :: el !< latent heat of evaporation/sublimation [J kg-1] + real(kind_phys), intent(in) :: emelt !< latent heat of fusion [J kg-1] + real(kind_phys), intent(in) :: t0c !< temperature at 0 degrees Celsius [K] + + ! real(kind_phys), intent(in) :: + real(kind_phys) :: cpoel, cpoesub, esubocp, & + elocp, oneocp, gocp, gravi,& + emeltocp, cpoemelt, epsln + real(kind_phys) :: fact1, fact2 + + + !DD borrowed from RAS to go form total condensate to ice/water separately ! parameter (tf=130.16, tcr=160.16, tcrf=1.0/(tcr-tf),tcl=2.0) ! parameter (tf=230.16, tcr=260.16, tcrf=1.0/(tcr-tf)) @@ -276,6 +291,20 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & errmsg = '' errflg = 0 + ! Initialize parameters + cpoel=cp/el + cpoesub=cp/(el+emelt) + esubocp=1.0/cpoesub + elocp=el/cp + oneocp=one/cp + gocp=grav/cp + gravi=one/grav + emeltocp=emelt/cp + cpoemelt=cp/emelt + epsln=1.e-10_kind_phys + fact1=(cvap-cliq)/rvap + fact2=el/rvap-fact1*t0c + ! lprnt = kdt == 1 .and. mype == 38 ! ipr = 43 @@ -319,8 +348,8 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & enddo !DD following adapted from ras -!> -# Following the Relaxed Arakawa Schubert Scheme (RAS; -!! Moorthi and Suarez 1992 \cite moorthi_and_suarez_1992 ), +!> -# Following the Relaxed Arakawa Schubert Scheme (RAS; +!! Moorthi and Suarez 1992 \cite moorthi_and_suarez_1992 ), !! separate total condensate between ice and water. !! The ratio of cloud ice to cloud water is determined by a linear function !! of temperature: @@ -328,7 +357,7 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & !! F_i(T)= (T_2-T)/(T_2-T_1) !!\f] !! where T is temperature, and\f$T_1\f$ and \f$T_2\f$ are set as tcf=263.16 -!! and tf= 233.16 +!! and tf= 233.16 if (clw(1,1,2) <= -999.0) then ! input ice/water are together do k=1,kmax do i=1,IJSDIM @@ -410,7 +439,12 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & DELTA , DELTI , ISTS , IENS, mype,& ! input fscav, fswtr, wcbmaxm, nctp, & sigmai, sigma, vverti, & ! input/output !DDsigma - do_aw, do_awdd, flx_form) + do_aw, do_awdd, flx_form, rair, & + oneocp, gravi, grav, gocp, fact2, & + fact1, esubocp, epsvt, epsvm1, & + epsv, elocp, el, cpoesub, & + cpoemelt, cpoel, cp, epsln, & + emeltocp, emelt) ! ! !DD detrainment has to be added in for GFS @@ -453,7 +487,7 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & qicn(i,k) = max(0.0, clw(i,k,1)-gdq(i,k,2)) qlcn(i,k) = max(0.0, clw(i,k,2)-gdq(i,k,3)) - + wrk = qicn(i,k) + qlcn(i,k) if (wrk > 1.0e-12) then cnv_fice(i,k) = qicn(i,k) / wrk @@ -494,7 +528,7 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & qicn(i,k) = max(0.0, clw(i,k,1)-gdq(i,k,2)) qlcn(i,k) = max(0.0, clw(i,k,2)-gdq(i,k,3)) cnv_fice(i,k) = qicn(i,k) / max(1.0e-10,qicn(i,k)+qlcn(i,k)) -! +! ! CNV_MFD(i,k) = dt_mf(i,k) * (1/delta) CNV_MFD(i,k) = dt_mf(i,k) CNV_DQLDT(i,k) = (qicn(i,k)+qlcn(i,k)) / delta @@ -504,7 +538,7 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & cf_upi(i,k) = max(0.0,min(0.01*log(1.0+500*ud_mf(i,k)),0.1)) ! & 500*ud_mf(i,k)),0.60)) ! CLCN(i,k) = cf_upi(i,k) !downdraft is below updraft - + w_upi(i,k) = ud_mf(i,k)*(t(i,k)+epsvt*gdq(i,k,1)) * rair & / (max(cf_upi(i,k),1.e-12)*gdp(i,k)) enddo @@ -513,7 +547,7 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & endif !**************************************************************************** - + KTMAX = 1 do n=1,nctp do i=1,IJSDIM @@ -549,7 +583,7 @@ subroutine cs_conv_run( IJSDIM , KMAX , ntracp1 , NN, & ! if (lprnt) then ! write(0,*)' aft cs_cum prec=',prec(ipr),'GTPRP=',GTPRP(ipr,1) ! endif - + ! if (do_aw) then ! call moist_bud(ijsdim,ijsdim,im,kmax,mype,kdt,grav,delta,delp,prec & @@ -599,17 +633,25 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions DELTA , DELTI , ISTS , IENS, mype,& ! input fscav, fswtr, wcbmaxm, nctp, & ! sigmai, sigma, vverti, & ! input/output !DDsigma - do_aw, do_awdd, flx_form) + do_aw, do_awdd, flx_form, rair, & + oneocp, gravi, grav, gocp, fact2, & + fact1, esubocp, epsvt, epsvm1, & + epsv, elocp, el, cpoesub, & + cpoemelt, cpoel, cp, epsln, & + emeltocp, emelt) ! IMPLICIT NONE - + + real(kind_phys), intent(in) :: oneocp, gravi, grav, gocp, fact2, fact1, & + esubocp, epsvt, epsvm1, epsv, elocp, el, cpoesub, cpoemelt, cpoel, & + cp, epsln, emeltocp, emelt Integer, parameter :: ntrq=4 ! starting index for tracers INTEGER, INTENT(IN) :: im, IJSDIM, KMAX, NTR, mype, nctp, ipr !! DD, for GFS, pass in logical, intent(in) :: do_aw, do_awdd, flx_form ! switch to apply Arakawa-Wu to the tendencies logical, intent(in) :: otspt1(ntr), otspt2(ntr), lprnt REAL(kind_phys),intent(in) :: DELP (IJSDIM, KMAX) REAL(kind_phys),intent(in) :: DELPINV (IJSDIM, KMAX) -! + real(kind_phys), intent(in) :: rair !< ideal gas constant for dry air [J kg-1 K-1] ! [OUTPUT] REAL(kind_phys), INTENT(OUT) :: GTT (IJSDIM, KMAX ) ! heating rate REAL(kind_phys), INTENT(OUT) :: GTQ (IJSDIM, KMAX, NTR) ! change in q @@ -634,7 +676,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions real(kind_phys), intent(out) :: sigmai(IM,KMAX+1,nctp) !DDsigma sigma by cloud type - on interfaces (1=sfc) real(kind_phys), intent(out) :: vverti(IM,KMAX+1,nctp) !DDsigma vert. vel. by cloud type - on interfaces (1=sfc) real(kind_phys), intent(out) :: sigma(IM,KMAX+1) !DDsigma sigma totaled over cloud type - on interfaces (1=sfc) - + ! for computing AW flux form of tendencies ! real(kind_phys), dimension(IM,KMAX) :: & !DDsigmadiag ! sfluxterm, qvfluxterm @@ -763,7 +805,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions REAL(kind_phys) HBGT ( IJSDIM ) ! imbalance in column heat REAL(kind_phys) WBGT ( IJSDIM ) ! imbalance in column water - + !DDsigma begin local work variables - all on model interfaces (sfc=1) REAL(kind_phys) lamdai( IJSDIM, KMAX+1, nctp ) ! lamda for cloud type ctp REAL(kind_phys) lamdaprod( IJSDIM, KMAX+1 ) ! product of (1+lamda) through cloud type ctp @@ -773,7 +815,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions REAL(kind_phys) gdtrm(ntrq:ntr) ! tracer character(len=4) :: cproc !DDsigmadiag - ! the following are new arguments to cumup to get them out + ! the following are new arguments to cumup to get them out REAL(kind_phys) wcv( IJSDIM, KMAX+1, nctp) ! in-cloud vertical velocity REAL(kind_phys) GCTM ( IJSDIM, KMAX+1 ) ! cloud T (half lev) !DDsigmadiag make output REAL(kind_phys) GCQM ( IJSDIM, KMAX+1, nctp ) ! cloud q (half lev) !DDsigmadiag make output @@ -782,11 +824,11 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions REAL(kind_phys) GClM ( IJSDIM, KMAX+1 ) ! cloud q (half lev) !DDsigmadiag make output REAL(kind_phys) GChM ( IJSDIM, KMAX+1, nctp ) ! cloud q (half lev) !DDsigmadiag make output REAL(kind_phys) GCtrM (IJSDIM, KMAX, ntrq:ntr) ! cloud tracer (half lev) !DDsigmadiag make output - + ! these are the fluxes at the interfaces - AW will operate on them REAL(kind_phys), dimension(ijsdim,Kmax+1,nctp) :: sfluxtem, qvfluxtem, qlfluxtem, qifluxtem REAL(kind_phys), dimension(ijsdim,Kmax+1,ntrq:ntr,nctp) :: trfluxtem ! tracer - + REAL(kind_phys), dimension(ijsdim,Kmax+1) :: dtcondtem, dqcondtem, dtfrztem, dqprectem,dfrzprectem REAL(kind_phys), dimension(ijsdim,Kmax) :: dtevap, dqevap, dtmelt, dtsubl REAL(kind_phys), dimension(ijsdim) :: moistening_aw @@ -937,7 +979,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions GDW(i,k) = GDQ(i,k,1) + GDQ(i,k,ITL) + GDQ(i,k,iti) enddo enddo -!> -# Compute layer saturate moisture \f$Q_i\f$(GDQS) and +!> -# Compute layer saturate moisture \f$Q_i\f$(GDQS) and !! saturate moist static energy (GDHS; see Appendix B in !! Chikira and Sugiyama (2010) \cite Chikira_2010) DO K=1,KMAX @@ -983,7 +1025,8 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions GDPM , FDQS , GAM , & ! input lprnt, ipr, & ISTS , IENS , & !) ! input - gctbl, gcqbl,gdq,gcwbl, gcqlbl, gcqibl, gctrbl) ! sub cloud tendencies + gctbl, gcqbl,gdq,gcwbl, gcqlbl, gcqibl, gctrbl, & + oneocp, grav, el) ! sub cloud tendencies ! !> -# Compute CAPE and CIN ! @@ -1025,7 +1068,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo enddo - do ctp=1,nctp + do ctp=1,nctp do k=1,kp1 do i=1,ijsdim lamdai(i,k,ctp) = zero @@ -1080,7 +1123,9 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions KB , CTP , ISTS , IENS , & ! input gctm , gcqm(:,:,CTP), gcwm(:,:,CTP), gchm(:,:,CTP),& gcwt, gclm, gcim, gctrm, & ! additional incloud profiles and cloud top total water - lprnt , ipr ) + lprnt , ipr, & + oneocp, grav, fact1, fact2, epsvt, & + epsvm1, epsv, emelt, el, cp) ! !> -# Call cumbmx() to compute cloud base mass flux CALL CUMBMX(IJSDIM, KMAX, & !DD dimensions @@ -1088,8 +1133,9 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ACWF , GCYT(:,CTP), GDZM , & ! input GDW , GDQS , DELP , & ! input KT (:,CTP), KTMX(CTP) , KB , & ! input - DELTI , ISTS , IENS ) - + DELTI , ISTS , IENS , & ! input + oneocp, el, epsln ) + !DDsigma - begin sigma computation ! At this point cbmfx is updated and we have everything we need to compute sigma @@ -1124,12 +1170,12 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions !> -# Compute lamda for a cloud type and then updraft area fraction -!! (sigmai) following Equations 23 and 12 of +!! (sigmai) following Equations 23 and 12 of !! Arakawa and Wu (2013) \cite arakawa_and_wu_2013 , respectively lamdai(i,k,ctp) = mflx_e * rair * gdtm(i,k)*(one+epsvt*gdqm) & / (gdpm(i,k)*wcv(i,k,ctp)) - + ! just compute lamdai here, we will compute sigma, sigmai, and vverti outside ! the cloud type loop after we can sort lamdai ! lamdaprod(i,k) = lamdaprod(i,k) * (one+lamdai(i,k,ctp)) @@ -1238,9 +1284,9 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo ! end of k=kbi,kk loop endif ! end of if(cbmfl > zero) - - - + + + enddo ! end of i loop endif ! if (flx_form) ! @@ -1260,7 +1306,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! gcut(i,ctp) = tem * gcut(i,ctp) ! gcvt(i,ctp) = tem * gcvt(i,ctp) ! do k=1,kmax -! kk = kb(i) +! kk = kb(i) ! if (k < kk) then ! tem = one - sigma(i,kk) ! tem1 = tem @@ -1288,7 +1334,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ISTS , IENS ) ! input ENDDO ! end of cloud type ctp loop - + !> -# Compute net updraft mass flux for all clouds do k=1,kmax do i=ists,iens @@ -1325,7 +1371,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions CBMFX , GCYT , DELPInv , GCHT , GCQT , & ! input GCLT , GCIT , GCUT , GCVT , GDQ(:,:,iti),& ! input gctrt , & - KT , ISTS , IENS, nctp ) ! input + KT , ISTS , IENS, nctp, oneocp, el) ! input endif !for now area fraction of the downdraft is zero, it will be computed @@ -1343,7 +1389,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions sigmai(i,k,loclamdamax) = lamdai(i,k,loclamdamax) / lamdaprod(i,k) sigma(i,k) = max(zero, min(one, sigma(i,k) + sigmai(i,k,loclamdamax))) vverti(i,k,loclamdamax) = sigmai(i,k,loclamdamax) * wcv(i,k,loclamdamax) - + ! make this lamdai negative so it won't be counted again lamdai(i,k,loclamdamax) = -lamdai(i,k,loclamdamax) ! get new lamdamax @@ -1396,8 +1442,8 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo ! end of k=kbi,kk loop endif ! end of if(cbmfl > zero) - - + + ! get tendencies by difference of fluxes, sum over cloud type do k = 1,kk @@ -1411,11 +1457,11 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! if (lprnt .and. i == ipr) write(0,*)' k=',k,' trfluxtem=',trfluxtem(k+1,ntr),trfluxtem(k,ntr),& ! ' ctp=',ctp,' trfluxterm=',trfluxterm(i,k,ntr) enddo - + enddo ! end of i loop enddo ! end of nctp loop endif -!downdraft sigma and mass-flux tendency terms are now put into +!downdraft sigma and mass-flux tendency terms are now put into ! the nctp+1 slot of the cloud-type dimensiond variables do k=1,kmax @@ -1424,7 +1470,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo enddo -!> -# Call cumdwn() to compute cumulus downdraft and assocated melt, freeze +!> -# Call cumdwn() to compute cumulus downdraft and assocated melt, freeze !! and evaporation CALL CUMDWN(IM, IJSDIM, KMAX, NTR, ntrq, nctp, & ! DD dimensions GTT , GTQ , GTU , GTV , & ! modified @@ -1438,8 +1484,11 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions sigmad, do_aw , do_awdd, flx_form, & ! DDsigma input dtmelt, dtevap, dtsubl, & ! DDsigma input dtdwn , dqvdwn, dqldwn, dqidwn, & ! DDsigma input - dtrdwn, & - KB , KTMXT , ISTS , IENS ) ! input + dtrdwn, & ! input + KB , KTMXT , ISTS , IENS, & ! input + oneocp, gocp, esubocp, emeltocp, emelt, & + elocp, el, cp) + ! sigma = sigma + sigmad @@ -1454,7 +1503,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions GDH , GDQ , GDQ(:,:,iti) , & ! input GDU , GDV , & ! input DELPINV , GMFLX , GMFX0 , & ! input - KTMXT , CPRES , kb, ISTS , IENS ) ! input + KTMXT , CPRES , kb, ISTS , IENS, oneocp, el ) ! input else CALL CUMSBW(IM , IJSDIM, KMAX , & !DD dimensions GTU , GTV , & ! modified @@ -1500,7 +1549,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! GMFLX , KTMXT , OTSPT2, & ! input ! ISTS , IENS ) ! input - endif + endif ! if this tracer not advected zero it out DO n = ntrq,NTR @@ -1512,12 +1561,12 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ENDDO endif ENDDO - + ! if(do_aw .and. flx_form) then ! compute AW tendencies !> -# Compute AW tendencies of T, ql and qi if(flx_form) then ! compute AW tendencies ! AW lump all heating together, compute qv term - + ! sigma interpolated to the layer for condensation, etc. terms, precipitation if(do_aw) then do k=1,kmax @@ -1551,13 +1600,13 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions teme = -dtevap(i,k) * delp(i,k) * tem2 tems = -dtsubl(i,k) * delp(i,k) * tem3 GSNWP(I,k) = GSNWP(I,kp1) + fsigma(i,k) * (GSNWI(i,k) - tem - tems) - GPRCP(I,k) = GPRCP(I,kp1) + fsigma(i,k) * (GPRCI(i,k) + tem - teme) + GPRCP(I,k) = GPRCP(I,kp1) + fsigma(i,k) * (GPRCI(i,k) + tem - teme) ENDDO ENDDO endif -! some of the above routines have set the tendencies and they need to be +! some of the above routines have set the tendencies and they need to be ! reinitialized, gtt not needed, but gtq needed Anning 5/25/2020 do n=1,ntr do k=1,kmax @@ -1580,14 +1629,14 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo -! diabatic terms from updraft and downdraft models +! diabatic terms from updraft and downdraft models DO K=1,KMAX DO I=ISTS,IENS tem = frzterm(i,k)*cpoEMELT - prectermfrz(i,k) ! gtt(i,k) = gtt(i,k) + fsigma(i,k)*(dtmelt(i,k) + dtevap(i,k)) + condtermt(i,k) ! gtq(i,k,1) = gtq(i,k,1) + fsigma(i,k)*dqevap(i,k) + condtermq(i,k) -! gtq(i,k,itl) = gtq(i,k,itl) - (condtermq(i,k) + prectermq(i,k) + tem) -! gtq(i,k,iti) = gtq(i,k,iti) + tem +! gtq(i,k,itl) = gtq(i,k,itl) - (condtermq(i,k) + prectermq(i,k) + tem) +! gtq(i,k,iti) = gtq(i,k,iti) + tem gtt(i,k) = dtdwn(i,k) + condtermt(i,k) & + fsigma(i,k)*(dtmelt(i,k) + dtevap(i,k)) gtq(i,k,1) = dqvdwn(i,k) + condtermq(i,k) & @@ -1611,11 +1660,11 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions DO K=1,kk kp1 = k+1 gtt(i,k) = gtt(i,k) - (fsigma(i,kp1)*sfluxtem(i,kp1,ctp) & - - fsigma(i,k)*sfluxtem(i,k,ctp)) * delpinv(i,k) + - fsigma(i,k)*sfluxtem(i,k,ctp)) * delpinv(i,k) gtq(i,k,1) = gtq(i,k,1) - (fsigma(i,kp1)*qvfluxtem(i,kp1,ctp) & - - fsigma(i,k)*qvfluxtem(i,k,ctp)) * delpinv(i,k) + - fsigma(i,k)*qvfluxtem(i,k,ctp)) * delpinv(i,k) gtq(i,k,itl) = gtq(i,k,itl) - (fsigma(i,kp1)*qlfluxtem(i,kp1,ctp) & - - fsigma(i,k)*qlfluxtem(i,k,ctp)) * delpinv(i,k) + - fsigma(i,k)*qlfluxtem(i,k,ctp)) * delpinv(i,k) gtq(i,k,iti) = gtq(i,k,iti) - (fsigma(i,kp1)*qifluxtem(i,kp1,ctp) & - fsigma(i,k)*qifluxtem(i,k,ctp)) * delpinv(i,k) ENDDO @@ -1661,7 +1710,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions gtt(i,k) = gtt(i,k) + elocp*(gtq(i,k,1)-tem1) gtq(i,k,1) = tem1 endif - + ! column-integrated total water tendency - to be used to impose water conservation moistening_aw(i) = moistening_aw(i) & + (gtq(i,k,1)+gtq(i,k,itl)+gtq(i,k,iti)) * delp(i,k) * gravi @@ -1695,7 +1744,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions CALL CUMFXR(IM , IJSDIM, KMAX , NTR , & !DD dimensions GTQ , & ! modified GDQ , DELP , DELTA , KTMXT , IMFXR, & ! input - ISTS , IENS ) ! input + ISTS , IENS, gravi ) ! input ! ! do k=1,kmax @@ -1732,11 +1781,11 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! HBGT(I) = HBGT(I) + (CP*GTT(I,K) + EL*GTQ(I,K,1) & ! - EMELT*GTQ(I,K,ITI)) * tem ! - EMELT*(GTQ(I,K,ITI)+GTIDET(I,K))) * tem -! WBGT(I) = WBGT(I) + (GTQ(I,K,1) + GTQ(I,K,ITL) + GTQ(I,K,ITI)) * tem +! WBGT(I) = WBGT(I) + (GTQ(I,K,1) + GTQ(I,K,ITL) + GTQ(I,K,ITI)) * tem ! + GTLDET(I,K) + GTIDET(I,K)) * tem ! ENDDO ! ENDDO - + ! ! DO I=ISTS,IENS @@ -1763,7 +1812,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! ENDIF ! ENDDO ! -!> -# Ensures conservation of water. +!> -# Ensures conservation of water. !In fact, no adjustment of the precip ! is occuring now which is a good sign! DD if(flx_form) then @@ -1776,7 +1825,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions endif END DO endif - + ! second method of determining sfc precip only ! if(flx_form) then ! DO I = ISTS, IENS @@ -1821,7 +1870,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions !DD provide GFS with a separate downdraft mass flux if(do_aw) then DO K = 1, KMAX+1 - DO I = ISTS, IENS + DO I = ISTS, IENS fsigma(i,k) = one - sigma(i,k) GMFX0( I,K ) = GMFX0( I,K ) * fsigma(i,k) GMFLX( I,K ) = GMFLX( I,K ) * fsigma(i,k) @@ -1829,13 +1878,13 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions END DO endif DO K = 1, KMAX+1 - DO I = ISTS, IENS + DO I = ISTS, IENS GMFX1( I,K ) = GMFX0( I,K ) - GMFLX( I,K ) END DO END DO - + if (allocated(gprcc)) deallocate(gprcc) - + ! END SUBROUTINE CS_CUMLUS !> @} @@ -1853,16 +1902,18 @@ SUBROUTINE CUMBAS & ! cloud base GDPM , FDQS , GAM , & ! input lprnt, ipr, & ISTS , IENS , gctbl, gcqbl ,gdq, & - gcwbl, gcqlbl, gcqibl, gctrbl ) ! input !DDsigmadiag add updraft profiles below cloud base -! -! + gcwbl, gcqlbl, gcqibl, gctrbl, & ! input !DDsigmadiag add updraft profiles below cloud base + oneocp, grav, el) + + IMPLICIT NONE ! integer, parameter :: crtrh=0.80 integer, parameter :: crtrh=0.70 INTEGER, INTENT(IN) :: IJSDIM, KMAX , ntr, ntrq ! DD, for GFS, pass in integer ipr logical lprnt -! + real(kind_phys), intent(in) :: oneocp, grav, el + ! [OUTPUT] INTEGER KB (IJSDIM) ! cloud base REAL(kind_phys) GCYM (IJSDIM, KMAX) ! norm. mass flux (half lev) @@ -1963,7 +2014,7 @@ SUBROUTINE CUMBAS & ! cloud base if (qsl(i) > zero) tx1(i) = tx1(i) / qsl(i) if (tx1(i) < crtrh) kb(i) = -1 enddo - + ! KBMX = 1 DO I=ISTS,IENS @@ -2071,7 +2122,9 @@ SUBROUTINE CUMUP & !! in-cloud properties ! CPRES , WCB , ERMR , & ! input KB , CTP , ISTS , IENS, & ! input gctm , gcqm , gcwm , gchm, gcwt,& - gclm, gcim , gctrm , lprnt, ipr ) + gclm, gcim , gctrm , lprnt, ipr,& + oneocp, grav, fact1, fact2, epsvt, & + epsvm1, epsv, emelt, el, cp) ! !DD AW the above line of arguments were previously local, and often scalars. ! Dimensions were added to them to save profiles for each grid point. @@ -2080,7 +2133,8 @@ SUBROUTINE CUMUP & !! in-cloud properties INTEGER, INTENT(IN) :: IJSDIM, KMAX, NTR, ipr , ntrq ! DD, for GFS, pass in logical :: lprnt -! + real(kind_phys), intent(in) :: oneocp, grav, fact1, fact2, epsvt + real(kind_phys), intent(in) :: epsvm1, epsv, emelt, el, cp ! [OUTPUT] REAL(kind_phys) ACWF (IJSDIM) !< cloud work function REAL(kind_phys) GCLZ (IJSDIM, KMAX) !< cloud liquid water*eta @@ -2205,7 +2259,7 @@ SUBROUTINE CUMUP & !! in-cloud properties ! REAL(kind_phys) :: wfn_neg = 0.25 ! REAL(kind_phys) :: wfn_neg = 0.30 ! REAL(kind_phys) :: wfn_neg = 0.35 - + REAL(kind_phys) :: esat, tem ! REAL(kind_phys) :: esat, tem, rhs_h, rhs_q ! @@ -2336,7 +2390,7 @@ SUBROUTINE CUMUP & !! in-cloud properties GDQM = half * (GDQ(I,K,1) + GDQ(I,K-1,1)) GDCM = half * (GDQ(I,K,ITL) + GDQI(I,K) & + GDQ(I,K-1,ITL) + GDQI(I,K-1)) - + ! BUOYM(I,K) = (DCTM*tem + EPSVT*(GCQM(I,K)-GDQM) - GCCM + GDCM )*GRAV ! @@ -2575,7 +2629,7 @@ SUBROUTINE CUMUP & !! in-cloud properties kk = max(1, kt(i)+1) do k=kk,kmax GCYM (I,K) = zero - GCLZ (I,K) = zero + GCLZ (I,K) = zero GCIZ (I,K) = zero GPRCIZ(I,K) = zero GSNWIZ(I,K) = zero @@ -2728,12 +2782,14 @@ SUBROUTINE CUMBMX & !! cloud base mass flux ACWF , GCYT , GDZM , & ! input GDW , GDQS , DELP , & ! input KT , KTMX , KB , & ! input - DELT , ISTS , IENS ) ! input + DELT , ISTS , IENS, & ! input + oneocp, el, epsln) ! input ! ! IMPLICIT NONE - + INTEGER, INTENT(IN) :: IJSDIM, KMAX ! DD, for GFS, pass in + real(kind_phys), intent(in) :: oneocp, el, epsln ! ! [MODIFY] REAL(kind_phys) CBMFX (IJSDIM) !< cloud base mass flux @@ -2876,11 +2932,12 @@ SUBROUTINE CUMDET & !! detrainment CBMFX , GCYT , DELPI , GCHT , GCQT , & ! input GCLT , GCIT , GCUT , GCVT , GDQI , & ! input gctrt, & - KT , ISTS , IENS , nctp ) ! input + KT , ISTS , IENS , nctp, oneocp, el) ! input ! IMPLICIT NONE INTEGER, INTENT(IN) :: im, IJSDIM, KMAX, NTR, nctp, ntrq !! DD, for GFS, pass in + real(kind_phys), intent(in) :: oneocp, el ! ! [MODIFY] REAL(kind_phys) GTT (IJSDIM, KMAX) !< temperature tendency @@ -2911,7 +2968,7 @@ SUBROUTINE CUMDET & !! detrainment ! ! [INTERNAL WORK] REAL(kind_phys) GTHCI, GTQVCI, GTXCI - integer I, K, CTP, kk,n + integer I, K, CTP, kk,n ! DO CTP=1,NCTP @@ -2950,12 +3007,14 @@ SUBROUTINE CUMSBH & !! adiabat. descent GDH , GDQ , GDQI , & ! input GDU , GDV , & ! input DELPI , GMFLX , GMFX0 , & ! input - KTMX , CPRES , KB, ISTS , IENS ) ! input + KTMX , CPRES , KB, ISTS , IENS, & ! input + oneocp, el) ! ! IMPLICIT NONE INTEGER, INTENT(IN) :: IJSDIM, IM, KMAX, NTR, ntrq !! DD, for GFS, pass in + real(kind_phys), intent(in) :: oneocp, el ! ! [MODIFY] REAL(kind_phys) GTT (IJSDIM, KMAX) !< Temperature tendency @@ -3152,8 +3211,10 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation sigmad, do_aw , do_awdd, flx_form, & !DDsigma input gtmelt, gtevap, gtsubl, & !DDsigma input dtdwn , dqvdwn, dqldwn, dqidwn, & !DDsigma input - dtrdwn, & - KB , KTMX , ISTS , IENS ) ! input + dtrdwn, & ! input + KB , KTMX , ISTS , IENS, & ! input + oneocp, gocp, esubocp, emeltocp, emelt,& + elocp, el, cp) ! ! DD AW : modify to get eddy fluxes and microphysical tendencies for AW ! @@ -3161,6 +3222,9 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX, NTR , ntrq, nctp !! DD, for GFS, pass in logical, intent(in) :: do_aw, do_awdd, flx_form + real(kind_phys), intent(in) :: oneocp, gocp, esubocp, emeltocp, emelt, & + elocp, el, cp + ! ! [MODIFY] REAL(kind_phys) GTT (IJSDIM, KMAX) !< Temperature tendency @@ -3292,24 +3356,24 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation GMDD (I,k) = zero GTEVP (I,k) = zero EVAPD (I,k) = zero - SUBLD (I,k) = zero - EVAPE (I,k) = zero - SUBLE (I,k) = zero - EVAPX (I,k) = zero - SUBLX (I,k) = zero - GMDDE (I,k) = zero - SNMLT (I,k) = zero - GCHDD (I,k) = zero - GCWDD (I,k) = zero - GTTEV (I,k) = zero - GTQEV (I,k) = zero - GCdseD(I,k) = zero - GCqvD (I,k) = zero -! GCqlD (I,k) = zero -! GCqiD (I,k) = zero - gtevap(I,k) = zero - gtmelt(I,k) = zero - gtsubl(I,k) = zero + SUBLD (I,k) = zero + EVAPE (I,k) = zero + SUBLE (I,k) = zero + EVAPX (I,k) = zero + SUBLX (I,k) = zero + GMDDE (I,k) = zero + SNMLT (I,k) = zero + GCHDD (I,k) = zero + GCWDD (I,k) = zero + GTTEV (I,k) = zero + GTQEV (I,k) = zero + GCdseD(I,k) = zero + GCqvD (I,k) = zero +! GCqlD (I,k) = zero +! GCqiD (I,k) = zero + gtevap(I,k) = zero + gtmelt(I,k) = zero + gtsubl(I,k) = zero enddo enddo @@ -3338,7 +3402,7 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation enddo do n=ntrq,ntr do i=ists,iens - GCtrD (I,n) = zero + GCtrD (I,n) = zero enddo enddo ! @@ -3520,7 +3584,7 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation if (kb(i) > 0) then wrk = DELPI(I,k) tx1 = DELPI(I,kp1) - + GTTEV(I,K) = GTTEV(I,K) - wrk & * (ELocp*EVAPE(I,K)+(ELocp+EMELTocp)*SUBLE(I,K)) GTT(I,K) = GTT(I,K) + GTTEV(I,K) @@ -3608,12 +3672,12 @@ SUBROUTINE CUMCLD & !! cloudiness REAL(kind_phys) :: CLMIN = 1.e-3_kind_phys !> cloudiness Min. REAL(kind_phys) :: CLMAX = 0.1_kind_phys !> cloudiness Max. REAL(kind_phys), SAVE :: FACLF -! +! IF ( OFIRST ) THEN FACLF = (CLMAX-CLMIN)/LOG(CMFMAX/CMFMIN) OFIRST = .FALSE. END IF - + CUMFRC(ISTS:IENS) = zero DO K=1,KTMX DO I=ISTS,IENS @@ -3843,10 +3907,11 @@ SUBROUTINE CUMSBR & !! Tracer Subsidence GDR , DELP , & ! input GMFLX , KTMX , OTSPT , & ! input sigmai , sigma , & !DDsigma input - ISTS, IENS ) ! input + ISTS, IENS, grav ) ! input ! IMPLICIT NONE + real(kind_phys), intent(in) :: grav INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX, NTR, nctp !! DD, for GFS, pass in ! ! [MODIFY] @@ -3898,10 +3963,11 @@ SUBROUTINE CUMFXR & ! Tracer mass fixe ( IM , IJSDIM, KMAX , NTR , & !DD dimensions GTR , & ! modified GDR , DELP , DELTA , KTMX , IMFXR , & ! input - ISTS , IENS ) ! input + ISTS , IENS, gravi ) ! input ! IMPLICIT NONE + real(kind_phys), intent(in) :: gravi INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX, NTR !! DD, for GFS, pass in ! ! [MODIFY] @@ -3990,9 +4056,12 @@ SUBROUTINE CUMFXR1 & ! Tracer mass fixer ( IM , IJSDIM, KMAX ,nctp, & !DD dimensions GTR , & ! modified GDR , DELP , DELTA , KTMX , IMFXR , & ! input - ISTS , IENS ) ! input + ISTS , IENS , & ! input + gravi & + ) ! IMPLICIT NONE + real(kind_phys), intent(in) :: gravi INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX, nctp !! DD, for GFS, pass in ! diff --git a/physics/CONV/Chikira_Sugiyama/cs_conv.meta b/physics/CONV/Chikira_Sugiyama/cs_conv.meta index 5211b939e..f2c8a6357 100644 --- a/physics/CONV/Chikira_Sugiyama/cs_conv.meta +++ b/physics/CONV/Chikira_Sugiyama/cs_conv.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = cs_conv type = scheme - dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -401,6 +401,102 @@ dimensions = () type = integer intent = in +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[grav] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[rair] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[rvap] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[cliq] + standard_name = specific_heat_of_liquid_water_at_constant_pressure + long_name = specific heat of liquid water at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[cvap] + standard_name = specific_heat_of_water_vapor_at_constant_pressure + long_name = specific heat of water vapor at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[epsv] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[epsvm1] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one + long_name = (rd/rv) - 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[epsvt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[el] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[emelt] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degrees Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/CONV/Grell_Freitas/cu_gf_deep.F90 b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 index 5da78d9ec..eb78cd6f6 100644 --- a/physics/CONV/Grell_Freitas/cu_gf_deep.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 @@ -4,7 +4,6 @@ !> This module contains the Grell_Freitas deep convection scheme module cu_gf_deep use machine , only : kind_phys - use physcons, only : qamin real(kind=kind_phys), parameter::g=9.81 real(kind=kind_phys), parameter:: cp=1004. real(kind=kind_phys), parameter:: xlv=2.5e6 @@ -143,7 +142,8 @@ subroutine cu_gf_deep_run( & !! betwee -1 and +1 ,do_capsuppress,cap_suppress_j & ! ,k22 & ! - ,jmin,kdt,mc_thresh) ! + ,jmin,kdt,mc_thresh & + ,qamin) implicit none @@ -192,6 +192,7 @@ subroutine cu_gf_deep_run( & ,intent (in ) :: & kpbl !$acc declare copyin(kpbl) + real(kind_phys), intent(in) :: qamin ! ! basic environmental input includes moisture convergence (mconv) ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off diff --git a/physics/CONV/Grell_Freitas/cu_gf_driver.F90 b/physics/CONV/Grell_Freitas/cu_gf_driver.F90 index 47bddd799..d4437a0cf 100644 --- a/physics/CONV/Grell_Freitas/cu_gf_driver.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_driver.F90 @@ -5,7 +5,6 @@ module cu_gf_driver ! DH* TODO: replace constants with arguments to cu_gf_driver_run - !use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv use machine , only: kind_phys use cu_gf_deep, only: cu_gf_deep_run,neg_check,fct1d3 use cu_gf_sh , only: cu_gf_sh_run @@ -68,7 +67,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart, gf_co dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & maxupmf,maxMF,do_mynnedmf,ichoice_in,ichoicem_in,ichoice_s_in, & spp_cu_deep,spp_wts_cu_deep,nchem,chem3d,fscav,wetdpc_deep, & - do_smoke_transport,kdt,errmsg,errflg) + do_smoke_transport,kdt,qamin,errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -164,6 +163,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart, gf_co real(kind_phys), dimension(:,:), intent(inout), optional :: wetdpc_deep !$acc declare copy(cactiv,cactiv_m,chem3d,wetdpc_deep) + real(kind_phys), intent(in) :: qamin + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -331,11 +332,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart, gf_co rand_mom(:) = 0. rand_vmas(:) = 0. rand_clos(:,:) = 0. - else + else do i=1,im spp_wts_cu_deep_tmp=min(max(-1.0_kind_phys, spp_wts_cu_deep(i,1)),1.0_kind_phys) - rand_mom(i) = spp_wts_cu_deep_tmp - rand_vmas(i) = spp_wts_cu_deep_tmp + rand_mom(i) = spp_wts_cu_deep_tmp + rand_vmas(i) = spp_wts_cu_deep_tmp rand_clos(i,:) = spp_wts_cu_deep_tmp end do end if @@ -351,7 +352,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart, gf_co kte=km ktf=kte-1 !$acc kernels -! +! tropics(:)=0 ! !> - Set tuning constants for radiation coupling @@ -494,7 +495,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart, gf_co !$acc end kernels ierrc(:)=" " !$acc kernels - + kbcon(:)=0 kbcons(:)=0 @@ -771,7 +772,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart, gf_co ! betwee -1 and +1 ,do_cap_suppress_here,cap_suppress_j & ,k22m & - ,jminm,kdt,mc_thresh) + ,jminm,kdt,mc_thresh & + ,qamin) !$acc kernels do i=its,itf do k=kts,ktf @@ -857,7 +859,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart, gf_co ! betwee -1 and +1 ,do_cap_suppress_here,cap_suppress_j & ,k22 & - ,jmin,kdt,mc_thresh) + ,jmin,kdt,mc_thresh & + ,qamin) jpr=0 ipr=0 !$acc kernels diff --git a/physics/CONV/Grell_Freitas/cu_gf_driver.meta b/physics/CONV/Grell_Freitas/cu_gf_driver.meta index 39a20f755..a1720e93e 100644 --- a/physics/CONV/Grell_Freitas/cu_gf_driver.meta +++ b/physics/CONV/Grell_Freitas/cu_gf_driver.meta @@ -678,6 +678,14 @@ dimensions = () type = integer intent = in +[qamin] + standard_name = minimum_aerosol_concentration + long_name = Minimum aerosol mass mixing ratio + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/CONV/SAMF/samfaerosols.F b/physics/CONV/SAMF/samfaerosols.F index ade8f1b5a..8fc5089c6 100644 --- a/physics/CONV/SAMF/samfaerosols.F +++ b/physics/CONV/SAMF/samfaerosols.F @@ -13,10 +13,9 @@ module samfcnv_aerosols subroutine samfdeepcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, & xlamde, xlamdd, cnvflg, jmin, kb, kmax, kd94, ktcon, fscav, & edto, xlamd, xmb, c0t, eta, etad, zi, xlamue, xlamud, delp, - & qtr, qaero) + & qtr, qaero, g, qamin) use machine , only : kind_phys - use physcons, only : g => con_g, qamin implicit none @@ -35,6 +34,8 @@ subroutine samfdeepcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, & eta, etad, zi, xlamue, xlamud real(kind=kind_phys), dimension(ix,km), intent(in) :: delp real(kind=kind_phys), dimension(ix,km,ntr+2), intent(in) :: qtr + real(kind=kind_phys), intent(in) :: g + real(kind=kind_phys), intent(in) :: qamin c -- output arguments real(kind=kind_phys), dimension(im,km,ntc), intent(out) :: qaero @@ -412,10 +413,9 @@ end subroutine samfdeepcnv_aerosols subroutine samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, & cnvflg, kb, kmax, kbcon, ktcon, fscav, & xmb, c0t, eta, zi, xlamue, xlamud, delp, - & qtr, qaero) + & qtr, qaero, con_g, qamin) use machine , only : kind_phys - use physcons, only : g => con_g, qamin implicit none @@ -435,6 +435,8 @@ subroutine samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, & eta, zi, xlamue !, xlamud real(kind=kind_phys), dimension(ix,km), intent(in) :: delp real(kind=kind_phys), dimension(ix,km,ntr+2), intent(in) :: qtr + real(kind=kind_phys), intent(in) :: con_g + real(kind=kind_phys), intent(in) :: qamin c -- output arguments real(kind=kind_phys), dimension(im,km,ntc), intent(out) :: qaero @@ -463,9 +465,10 @@ subroutine samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, real(kind=kind_phys), parameter :: zero = 0.0_kind_phys real(kind=kind_phys), parameter :: epsil = 1.e-22_kind_phys ! prevent division by zero real(kind=kind_phys), parameter :: escav = 0.8_kind_phys ! wet scavenging efficiency + real(kind=kind_phys) :: g c -- begin - + g = con_g c -- check if aerosols are present if ( ntc <= 0 .or. itc <= 0 .or. ntr <= 0 ) return if ( ntr < itc + ntc - 3 ) return diff --git a/physics/CONV/SAMF/samfshalcnv.f b/physics/CONV/SAMF/samfshalcnv.f index bc69f0ebb..30e18514b 100644 --- a/physics/CONV/SAMF/samfshalcnv.f +++ b/physics/CONV/SAMF/samfshalcnv.f @@ -59,6 +59,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, & & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal, & & sigmain,sigmaout,omegain,omegaout,betadcu,betamcu,betascu, & + & qamin, & & errmsg,errflg) ! use machine , only : kind_phys @@ -90,7 +91,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), intent(out) :: rn(:), & & cnvw(:,:), cnvc(:,:), dt_mf(:,:) ! - real(kind=kind_phys), intent(out) :: ud_mf(:,:) + real(kind=kind_phys), intent(out), optional :: ud_mf(:,:) real(kind=kind_phys), intent(inout), optional :: sigmaout(:,:), & & omegaout(:,:) @@ -98,6 +99,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & asolfac, evef, pgcon logical, intent(in) :: hwrf_samfshal,first_time_step, & & restart,progsigma,progomega + real(kind=kind_phys), intent(in) :: qamin character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! @@ -132,7 +134,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & ptem, ptem1 ! integer kb(im), kb1(im), kbcon(im), kbcon1(im), - & ktcon(im), ktcon1(im), + & ktcon(im), ktcon1(im), & kbm(im), kmax(im) ! real(kind=kind_phys) aa1(im), cina(im), @@ -353,7 +355,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & xmb(i) = 0. enddo endif -!! +!! !> - Return to the calling routine if deep convection is present or the surface buoyancy flux is negative. totflg = .true. do i=1,im @@ -373,7 +375,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & !> - determine scale-aware rain conversion parameter decreasing with decreasing grid size do i=1,im if(gdx(i) < dxcrtc0) then - tem = gdx(i) / dxcrtc0 + tem = gdx(i) / dxcrtc0 tem1 = tem**3 c0(i) = c0(i) * tem1 endif @@ -1534,9 +1536,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif enddo enddo - + else -! diagnostic updraft velocity +! diagnostic updraft velocity do k = 2, km1 do i = 1, im if (cnvflg(i)) then @@ -1568,7 +1570,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo endif !progomega - + ! compute updraft velocity averaged over the whole cumulus ! !> - Calculate the mean updraft velocity within the cloud (wc). @@ -1684,7 +1686,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo endif c - + c--- compute precipitation efficiency in terms of windshear c !! - Calculate the wind shear and precipitation efficiency according to equation 58 in Fritsch and Chappell (1980) \cite fritsch_and_chappell_1980 : @@ -2084,7 +2086,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! & cnvflg, kb, kmax, ktcon, fscav, !! & edto, xlamd, xmb, c0t, eta, etad, zi, xlamue, xlamud, delp, ! & xmb, c0t, eta, zi, xlamue, xlamud, delp, -! & qtr, qaero) +! & qtr, qaero, grav, qamin) ! endif ! !> ## For the "feedback control", calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control. @@ -2456,7 +2458,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif enddo enddo -c +c c convective cloud cover c !> - Calculate convective cloud cover, which is used when pdf-based cloud fraction is used (i.e., pdfcld=.true.). @@ -2564,4 +2566,3 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & end subroutine samfshalcnv_run !> @} end module samfshalcnv - diff --git a/physics/CONV/SAMF/samfshalcnv.meta b/physics/CONV/SAMF/samfshalcnv.meta index b96a742f2..644c3d1c1 100644 --- a/physics/CONV/SAMF/samfshalcnv.meta +++ b/physics/CONV/SAMF/samfshalcnv.meta @@ -550,6 +550,14 @@ dimensions = () type = real intent = in +[qamin] + standard_name = minimum_aerosol_concentration + long_name = Minimum aerosol mass mixing ratio + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/CONV/SAS/sascnvn.F b/physics/CONV/SAS/sascnvn.F index 8a78d63ff..79230ba8d 100644 --- a/physics/CONV/SAS/sascnvn.F +++ b/physics/CONV/SAS/sascnvn.F @@ -101,10 +101,6 @@ subroutine sascnvn_run( ! use machine , only : kind_phys use funcphys , only : fpvs -! use physcons, grav => con_g, cp => con_cp, hvap => con_hvap & -! &, rv => con_rv, fv => con_fvirt, t0c => con_t0c & -! &, cvap => con_cvap, cliq => con_cliq & -! &, eps => con_eps, epsm1 => con_epsm1,rgas => con_rd implicit none ! ! Interface variables @@ -1000,14 +996,14 @@ subroutine sascnvn_run( aa2(i) = aa2(i) + & dz1 * (g / (cp * to(i,k))) & * dbyo(i,k) / (1. + gamma) - & * rfact + & * rfact !NRL MNM: Limit overshooting not to be deeper than half the actual cloud tem = 0.5 * (zi(i,ktcon(i))-zi(i,kbcon(i))) tem1 = zi(i,k)-zi(i,ktcon(i)) if(aa2(i) < 0. .or. tem1 >= tem) then ktcon1(i) = k flg(i) = .false. - endif + endif endif endif enddo diff --git a/physics/CONV/SAS/shalcnv.F b/physics/CONV/SAS/shalcnv.F index 872b6d694..a9c278700 100644 --- a/physics/CONV/SAS/shalcnv.F +++ b/physics/CONV/SAS/shalcnv.F @@ -96,10 +96,6 @@ subroutine shalcnv_run( & ! use machine , only : kind_phys use funcphys , only : fpvs -! use physcons, grav => con_g, cp => con_cp, hvap => con_hvap & -! &, rv => con_rv, fv => con_fvirt, t0c => con_t0c & -! &, rd => con_rd, cvap => con_cvap, cliq => con_cliq & -! &, eps => con_eps, epsm1 => con_epsm1 implicit none ! ! Interface variables diff --git a/physics/CONV/nTiedtke/cu_ntiedtke.F90 b/physics/CONV/nTiedtke/cu_ntiedtke.F90 index 1de9de72b..5d7e18443 100644 --- a/physics/CONV/nTiedtke/cu_ntiedtke.F90 +++ b/physics/CONV/nTiedtke/cu_ntiedtke.F90 @@ -13,8 +13,6 @@ module cu_ntiedtke ! DH* TODO - replace with arguments to subroutine calls, ! this also requires redefining derived constants in the ! parameter section below - use physcons, only:rd=>con_rd, rv=>con_rv, g=>con_g, & - & cpd=>con_cp, alv=>con_hvap, alf=>con_hfus implicit none real(kind=kind_phys),private :: rcpd,vtmpc1,als, & @@ -34,19 +32,15 @@ module cu_ntiedtke real(kind=kind_phys),parameter:: rtber = tmelt-5. real(kind=kind_phys),parameter:: rtice = tmelt-23. parameter( & - rcpd=1.0/cpd, & - zrg=1.0/g, & - c2es=c1es*rd/rv, & - als = alv+alf, & c5les=c3les*(tmelt-c4les), & - c5ies=c3ies*(tmelt-c4ies), & - r5alvcp=c5les*alv*rcpd, & - r5alscp=c5ies*als*rcpd, & - ralvdcp=alv*rcpd, & - ralsdcp=als*rcpd, & - ralfdcp=alf*rcpd, & - vtmpc1=rv/rd-1.0, & - rovcp = rd*rcpd ) + c5ies=c3ies*(tmelt-c4ies)) + + real(kind=kind_phys) :: rd = 1.0E30_kind_phys + real(kind=kind_phys) :: rv = 1.0E30_kind_phys + real(kind=kind_phys) :: g = 1.0E30_kind_phys + real(kind=kind_phys) :: cpd = 1.0E30_kind_phys + real(kind=kind_phys) :: alv = 1.0E30_kind_phys + real(kind=kind_phys) :: alf = 1.0E30_kind_phys ! momtrans: momentum transport method ( 1 = IFS40r1 method; 2 = new method ) ! ------- @@ -121,12 +115,16 @@ module cu_ntiedtke !! \htmlinclude cu_ntiedtke_init.html !! subroutine cu_ntiedtke_init(imfshalcnv, imfshalcnv_ntiedtke, imfdeepcnv, & - imfdeepcnv_ntiedtke,mpirank, mpiroot, errmsg, errflg) + imfdeepcnv_ntiedtke, con_rd, con_rv, & + con_g, con_cp, con_hvap, con_hfus, & + mpirank, mpiroot, errmsg, errflg) implicit none integer, intent(in) :: imfshalcnv, imfshalcnv_ntiedtke integer, intent(in) :: imfdeepcnv, imfdeepcnv_ntiedtke + real(kind=kind_phys), intent(in) :: con_rd, con_rv, con_g + real(kind=kind_phys), intent(in) :: con_cp, con_hvap, con_hfus integer, intent(in) :: mpirank integer, intent(in) :: mpiroot character(len=*), intent( out) :: errmsg @@ -136,6 +134,26 @@ subroutine cu_ntiedtke_init(imfshalcnv, imfshalcnv_ntiedtke, imfdeepcnv, & errmsg = '' errflg = 0 + ! initialize variables using constants + rd = con_rd + rv = con_rv + g = con_g + cpd = con_cp + alv = con_hvap + alf = con_hfus + + rcpd=1.0/cpd + zrg=1.0/g + c2es=c1es*rd/rv + als = alv+alf + r5alvcp=c5les*alv*rcpd + r5alscp=c5ies*als*rcpd + ralvdcp=alv*rcpd + ralsdcp=als*rcpd + ralfdcp=alf*rcpd + vtmpc1=rv/rd-1.0 + rovcp = rd*rcpd + ! DH* temporary if (mpirank==mpiroot) then write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' @@ -4099,4 +4117,3 @@ end function foeldcpm !================================================================================================================= end module cu_ntiedtke !================================================================================================================= - diff --git a/physics/CONV/nTiedtke/cu_ntiedtke.meta b/physics/CONV/nTiedtke/cu_ntiedtke.meta index 3e1755a5a..6d1d29364 100644 --- a/physics/CONV/nTiedtke/cu_ntiedtke.meta +++ b/physics/CONV/nTiedtke/cu_ntiedtke.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_ntiedtke type = scheme - dependencies = ../../hooks/machine.F,../../hooks/physcons.F90 + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -35,6 +35,54 @@ dimensions = () type = integer intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in [mpirank] standard_name = mpi_rank long_name = current MPI-rank diff --git a/physics/GWD/cires_ugwp.meta b/physics/GWD/cires_ugwp.meta index b0b1a8615..4336d1d09 100644 --- a/physics/GWD/cires_ugwp.meta +++ b/physics/GWD/cires_ugwp.meta @@ -2,7 +2,7 @@ name = cires_ugwp type = scheme # DH* 20200804 - this is a result of the nasty hack to call gwdps from within ugwp-v0! - dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 + dependencies=ugwp_common_v0.f90,cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 dependencies=cires_orowam2017.f,cires_ugwp_module.F90,gwdps.f,../hooks/machine.F,ugwp_driver_v0.F ######################################################################## @@ -822,7 +822,7 @@ type = real kind = kind_phys intent = in -[dqdt_tke] +[dqdt_tke] standard_name = process_split_cumulative_tendency_of_turbulent_kinetic_energy long_name = turbulent kinetic energy tendency due to model physics units = J s-1 diff --git a/physics/GWD/cires_ugwp_initialize.F90 b/physics/GWD/cires_ugwp_initialize.F90 index ae923671d..4cc01bb36 100644 --- a/physics/GWD/cires_ugwp_initialize.F90 +++ b/physics/GWD/cires_ugwp_initialize.F90 @@ -1,31 +1,10 @@ !>\file cires_ugwp_initialize.F90 !! This file contains cu-cires ugwp initialization scheme. -! initialization of ugwp_common_v0 ! init gw-solvers (1,2) .. no UFS-funds for (3,4) tests ! init gw-source specifications ! init gw-background dissipation -!=============================== - -!> This module contains UGWP v0 initialization schemes - module ugwp_common_v0 -! - use machine, only: kind_phys - use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & - rv => con_rv, cpd => con_cp, fv => con_fvirt,& - arad => con_rerth - implicit none - - real(kind=kind_phys), parameter :: grcp = grav/cpd, rgrav = 1.0d0/grav, & - rdi = 1.0d0/rd, & - gor = grav/rd, gr2 = grav*gor, gocp = grav/cpd, & - rcpd = 1./cpd, rcpd2 = 0.5*rcpd, & - pi2 = pi + pi, omega1 = pi2/86400.0, & - omega2 = omega1+omega1, & - rad_to_deg=180.0/pi, deg_to_rad=pi/180.0, & - dw2min=1.0, bnv2min=1.e-6, velmin=sqrt(dw2min) - +!=============================== - end module ugwp_common_v0 ! ! !=================================================== @@ -55,7 +34,7 @@ subroutine init_global_gwdis_v0(levs, zkm, pmb, kvg, ktg, krad, kion) real, parameter :: inv_pra = 3. !kt/kv =inv_pr ! real, parameter :: alpha = 1./86400./15. -! +! real, parameter :: kdrag = 1./86400./10. real, parameter :: zdrag = 100. real, parameter :: zgrow = 50. @@ -83,10 +62,10 @@ subroutine init_global_gwdis_v0(levs, zkm, pmb, kvg, ktg, krad, kion) krad(k) = krad(k-1) kvg(k) = kvg(k-1) ktg(k) = ktg(k-1) -! +! end subroutine init_global_gwdis_v0 - + ! ======================================================================== ! Part 2 - sources ! wave sources @@ -101,7 +80,7 @@ module ugwpv0_oro_init use ugwp_common_v0, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi implicit none -! +! ! constants and "crirtical" values to run oro-mtb_gw physics ! ! choice of oro-scheme: strver = 'vay_2018' , 'gfs_2018', 'kdn_2005', 'smc_2000' @@ -124,18 +103,18 @@ module ugwpv0_oro_init real, parameter :: rlolev=50000.0 ! real, parameter :: hncrit=9000. ! max value in meters for elvmax - + ! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt real, parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor real, parameter :: hminmt=50. ! min mtn height (*j*) real, parameter :: minwnd=1.0 ! min wind component (*j*) real, parameter :: dpmin=5000.0 ! minimum thickness of the reference layer in pa - + real, parameter :: kxoro=6.28e-3/200. ! real, parameter :: coro = 0.0 integer, parameter :: nridge=2 - + real :: cdmb ! scale factors for mtb real :: cleff ! scale factors for orogw integer :: nworo ! number of waves @@ -143,7 +122,7 @@ module ugwpv0_oro_init integer :: nstoro ! flag for stochastic launch above SG-peak integer, parameter :: mdir = 8 - real, parameter :: fdir=.5*mdir/pi + real :: fdir = 1.0E30 integer nwdir(mdir) data nwdir/6,7,5,8,2,3,1,4/ @@ -168,8 +147,8 @@ module ugwpv0_oro_init real, parameter :: lzmax = 18.e3 ! 18 km real, parameter :: mkzmin = 6.28/lzmax real, parameter :: mkz2min = mkzmin*mkzmin - real, parameter :: zbr_pi = (3.0/2.0)*pi - real, parameter :: zbr_ifs = 0.5*pi + real :: zbr_pi = 1.0E30 + real :: zbr_ifs = 1.0E30 contains ! @@ -180,19 +159,22 @@ subroutine init_oro_gws_v0(nwaves, nazdir, nstoch, effac, & integer :: nwaves, nazdir, nstoch integer :: lonr real :: cdmbgwd(2) ! scaling factors for MTb (1) & (2) for cleff = cleff * cdmbgwd(2) - ! high res-n "larger" MTB and "less-active" cleff in GFS-2018 + ! high res-n "larger" MTB and "less-active" cleff in GFS-2018 real :: cdmbX real :: kxw real :: effac ! it is analog of cdmbgwd(2) for GWs, off for now !-----------------------------! GFS-setup for cdmb & cleff -! cdmb = 4.0 * (192.0/IMX) +! cdmb = 4.0 * (192.0/IMX) ! cleff = 0.5E-5 / SQRT(IMX/192.0) = 0.5E-5*SQRT(192./IMX) ! real, parameter :: lonr_refmb = 4.0 * 192.0 real, parameter :: lonr_refgw = 192.0 ! copy to "ugwp_oro_init" => nwaves, nazdir, nstoch - + fdir=.5*mdir/pi + zbr_pi = (3.0/2.0)*pi + zbr_ifs = 0.5*pi + nworo = nwaves nazoro = nazdir nstoro = nstoch @@ -200,13 +182,13 @@ subroutine init_oro_gws_v0(nwaves, nazdir, nstoch, effac, & cdmbX = lonr_refmb/float(lonr) cdmb = cdmbX if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) - + cleff = 0.5e-5 * sqrt(lonr_refgw/float(lonr)) !* effac !!! cleff = kxw * sqrt(lonr_refgw/float(lonr)) !* effac if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) -! +! !.................................................................... ! higher res => smaller h' ..&.. higher kx ! flux_gwd ~ 'u'^2*kx/kz ~kxu/n ~1/dx *u/n tau ~ h'*h'*kx*kx = const (h'-less kx-grow) @@ -274,7 +256,7 @@ end module ugwpv0_lsatdis_init ! !>This module contains init-solvers for "broad" non-stationary multi-wave spectra module ugwpv0_wmsdis_init - + use ugwp_common_v0, only : pi, pi2 implicit none @@ -288,7 +270,7 @@ module ugwpv0_wmsdis_init real, parameter :: gssec = (6.28/30.)**2 ! max-value for bn2 real, parameter :: bv2min = (6.28/60./120.)**2 ! min-value for bn2 7.6(-7) 2 hrs real, parameter :: minvel = 0.5 - + ! ! make parameter list that will be passed to SOLVER ! @@ -299,30 +281,32 @@ module ugwpv0_wmsdis_init real, parameter :: zfluxglob= 3.75e-3 real , parameter :: nslope=1 ! the GW sprctral slope at small-m - + integer , parameter :: iazidim=4 ! number of azimuths integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum real , parameter :: ucrit2=0.5 - + real , parameter :: zcimin = ucrit2 real , parameter :: zcimax = 125.0 real , parameter :: zgam = 0.25 - real , parameter :: zms_l = 2000.0, zms = pi2 / zms_l, zmsi = 1.0 / zms + real , parameter :: zms_l = 2000.0 + real :: zms = 1.0E30 + real :: zmsi = 1.0E30 integer :: ilaunch real :: gw_eff - + !=========================================================================== integer :: nwav, nazd, nst real :: eff - + real :: zaz_fct real, allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) real, allocatable :: zcosang(:), zsinang(:) contains !============================================================================ subroutine initsolv_wmsdis_v0(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) - + implicit none ! !input -control for solvers: @@ -340,6 +324,9 @@ subroutine initsolv_wmsdis_v0(me, master, nwaves, nazdir, nstoch, effac, do_phy real :: zang, zang1, znorm real :: zx1, zx2, ztx, zdx, zxran, zxmin, zxmax, zx, zpexp + zms = pi2 / zms_l + zmsi = 1.0 / zms + if( nwaves == 0) then ! ! redefine from the deafault @@ -391,7 +378,7 @@ subroutine initsolv_wmsdis_v0(me, master, nwaves, nazdir, nstoch, effac, do_phy zaz_fct = 2.0 / znorm ! correction factor for azimuthal sums ! define coordinate transform for "Ch" ....x = 1/c stretching transform -! ----------------------------------------------- +! ----------------------------------------------- ! note that this is expresed in terms of the intrinsic phase speed ! at launch ci=c-u_o so that the transformation is identical ! see eq. 28-30 of scinocca 2003. x = 1/c stretching transform diff --git a/physics/GWD/ugwp_common_v0.f90 b/physics/GWD/ugwp_common_v0.f90 new file mode 100644 index 000000000..246731724 --- /dev/null +++ b/physics/GWD/ugwp_common_v0.f90 @@ -0,0 +1,59 @@ +!> This module contains UGWP v0 initialization schemes +module ugwp_common_v0 + use machine, only: kind_phys + implicit none + + real(kind=kind_phys), parameter :: dw2min=1.0, bnv2min=1.e-6 + real(kind=kind_phys) :: grcp = 1.0E30 + real(kind=kind_phys) :: rgrav = 1.0E30 + real(kind=kind_phys) :: rdi = 1.0E30 + real(kind=kind_phys) :: gor = 1.0E30 + real(kind=kind_phys) :: gr2 = 1.0E30 + real(kind=kind_phys) :: gocp = 1.0E30 + real(kind=kind_phys) :: rcpd = 1.0E30 + real(kind=kind_phys) :: rcpd2 = 1.0E30 + real(kind=kind_phys) :: pi2 = 1.0E30 + real(kind=kind_phys) :: omega1 = 1.0E30 + real(kind=kind_phys) :: omega2 = 1.0E30 + real(kind=kind_phys) :: rad_to_deg = 1.0E30 + real(kind=kind_phys) :: deg_to_rad = 1.0E30 + real(kind=kind_phys) :: velmin = 1.0E30 + real(kind=kind_phys) :: pi = 1.0E30 + real(kind=kind_phys) :: grav = 1.0E30 + real(kind=kind_phys) :: rd = 1.0E30 + real(kind=kind_phys) :: rv = 1.0E30 + real(kind=kind_phys) :: cpd = 1.0E30 + real(kind=kind_phys) :: fv = 1.0E30 + real(kind=kind_phys) :: arad = 1.0E30 + +contains + + subroutine ugwp_common_v0_init(con_pi, con_g, con_rd, con_rv, & + con_cp, con_fvirt, con_rerth) + real(kind=kind_phys), intent(in) :: con_pi, con_g, con_rd, con_rv + real(kind=kind_phys), intent(in) :: con_cp, con_fvirt, con_rerth + + pi = con_pi + grav = con_g + rd = con_rd + rv = con_rv + cpd = con_cp + fv = con_fvirt + arad = con_rerth + + grcp = grav/cpd + rgrav = 1.0d0/grav + rdi = 1.0d0/rd + gor = grav/rd + gr2 = grav*gor + gocp = grav/cpd + rcpd = 1./cpd + rcpd2 = 0.5*rcpd + pi2 = pi + pi + omega1 = pi2/86400.0 + omega2 = omega1+omega1 + rad_to_deg=180.0/pi + deg_to_rad=pi/180.0 + velmin=sqrt(dw2min) + end subroutine ugwp_common_v0_init +end module ugwp_common_v0 diff --git a/physics/GWD/ugwp_common_v0.meta b/physics/GWD/ugwp_common_v0.meta new file mode 100644 index 000000000..943fe70e5 --- /dev/null +++ b/physics/GWD/ugwp_common_v0.meta @@ -0,0 +1,81 @@ +[ccpp-table-properties] + name = ugwp_common_v0 + type = scheme + dependencies = ../hooks/machine.F + +######################################################################## + +[ccpp-arg-table] + name = GFS_time_vary_pre_init + type = scheme +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GWD/ugwp_driver_v0.F b/physics/GWD/ugwp_driver_v0.F index 845323e43..ba36042e1 100644 --- a/physics/GWD/ugwp_driver_v0.F +++ b/physics/GWD/ugwp_driver_v0.F @@ -7,7 +7,7 @@ module ugwp_driver_v0 ! !===================================================================== ! -!ugwp-v0 subroutines: GWDPS_V0 and fv3_ugwp_solv2_v0 +!ugwp-v0 subroutines: GWDPS_V0 and fv3_ugwp_solv2_v0 ! !===================================================================== !>\defgroup ugwp_driverv0_mod UGWP V0 Driver Module @@ -44,14 +44,14 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! modified/revised version of gwdps.f (with bug fixes, tofd, appropriate ! computation of reference level for OGW + COORDE diagnostics ! all constants/parameters inside cires_ugwp_initialize.F90 -!---------------------------------------- +!---------------------------------------- USE MACHINE , ONLY : kind_phys use ugwp_common_v0,only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 &, pi, rad_to_deg, deg_to_rad, pi2 &, rdi, gor, grcp, gocp, fv, gr2 &, bnv2min, dw2min, velmin, arad - + use ugwpv0_oro_init, only : rimin, ric, efmin, efmax &, hpmax, hpmin, sigfaci => sigfac &, dpmin, minwnd, hminmt, hncrit @@ -62,7 +62,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, &, n_tofd, ze_tofd, ztop_tofd use cires_ugwpv0_module, only : kxw, max_kdis, max_axyz - + !---------------------------------------- implicit none integer, parameter :: kp = kind_phys @@ -75,7 +75,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, integer, intent(in) :: KPBL(IM) ! Index for the PBL top layer! real(kind=kind_phys), intent(in) :: dtp ! time step real(kind=kind_phys), intent(in) :: cdmbgwd(2) - + real(kind=kind_phys), intent(in), dimension(im,km) :: & u1, v1, t1, q1, & del, prsl, prslk, phil @@ -91,13 +91,13 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, real(kind=kind_phys) :: SIGMA(IM), GAMMA(IM) real(kind=kind_phys), intent(in) :: con_g, con_omega - + !output -phys-tend real(kind=kind_phys),dimension(im,km),intent(out) :: & Pdvdt, Pdudt, Pkdis, Pdtdt ! output - diag-coorde &, dudt_mtb, dudt_ogw, dudt_tms -! +! real(kind=kind_phys),dimension(im) :: RDXZB, zmtb, zogw &, tau_ogw, tau_mtb, tau_tofd &, dusfc, dvsfc @@ -184,7 +184,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, grav2 = grav + grav ! ! mtb-blocking sigma_min and dxres => cires_initialize -! +! sgrmax = maxval(sparea) ; sgrmin = minval(sparea) dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) @@ -208,7 +208,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, zogw(i) = 0.0 rdxzb(i) = 0.0 tau_ogw(i) = 0.0 - tau_mtb(i) = 0.0 + tau_mtb(i) = 0.0 dusfc(i) = 0.0 dvsfc(i) = 0.0 tau_tofd(i) = 0.0 @@ -253,7 +253,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! a, b > sso_min upscale ellipse a/b > 0.1 a>sso_min & h/b=>new_sigm ! - aelps = sso_min + aelps = sso_min if (belps < sso_min ) then gamma(i) = 1.0 belps = aelps*gamma(i) @@ -283,7 +283,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, do i=1,npt iwklm(i) = 2 - IDXZB(i) = 0 + IDXZB(i) = 0 kreflm(i) = 0 enddo @@ -296,7 +296,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, enddo KMM1 = km - 1 ; KMM2 = km - 2 ; KMLL = kmm1 - LCAP = km ; LCAPP1 = LCAP + 1 + LCAP = km ; LCAPP1 = LCAP + 1 DO I = 1, npt j = ipt(i) @@ -308,11 +308,11 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, DO I = 1, npt j = ipt(i) ztopH = sigfac * hprime(j) - zlowH = sigfacs* hprime(j) + zlowH = sigfacs* hprime(j) pkp1log = phil(j,k+1) * rgrav pklog = phil(j,k) * rgrav ! if (( ELVMAX(j) <= pkp1log) .and. (ELVMAX(j).ge.pklog) ) -! & iwklm(I) = MAX(iwklm(I), k+1 ) +! & iwklm(I) = MAX(iwklm(I), k+1 ) if (( ztopH <= pkp1log) .and. (zTOPH >= pklog) ) & iwklm(I) = MAX(iwklm(I), k+1 ) ! @@ -374,7 +374,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ROLL (I) = 0.0 PE (I) = 0.0 EK (I) = 0.0 - BNV2bar(I) = 0.0 + BNV2bar(I) = 0.0 ENDDO ! DO I = 1, npt @@ -397,23 +397,23 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! integrate from Ztoph = sigfac*hprime down to Zblk if exists ! find ph_blk, dz_blk like in LM-97 and IFS ! - ph_blk =0. + ph_blk =0. DO K = iwklm(I), 1, -1 PHIANG = atan2(V1(J,K),U1(J,K))*RAD_TO_DEG ANG(I,K) = ( THETA(J) - PHIANG ) if ( ANG(I,K) > 90. ) ANG(I,K) = ANG(I,K) - 180. if ( ANG(I,K) < -90. ) ANG(I,K) = ANG(I,K) + 180. ANG(I,K) = ANG(I,K) * DEG_TO_RAD - UDS(I,K) = + UDS(I,K) = & MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), velmin) ! IF (IDXZB(I) == 0 ) then dz_blk = ( PHII(J,K+1) - PHII(J,K) ) *rgrav - PE(I) = PE(I) + BNV2(I,K) * + PE(I) = PE(I) + BNV2(I,K) * & ( ELVMAX(J) - phil(J,K)*rgrav ) * dz_blk - UP(I) = max(UDS(I,K) * cos(ANG(I,K)), velmin) - EK(I) = 0.5 * UP(I) * UP(I) + UP(I) = max(UDS(I,K) * cos(ANG(I,K)), velmin) + EK(I) = 0.5 * UP(I) * UP(I) ph_blk = ph_blk + dz_blk*sqrt(BNV2(I,K))/UP(I) @@ -429,7 +429,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ENDDO ! ! Alternative expression: ZMTB = max(Heff*(1. -Fcrit_gfs/Fr), 0) -! fcrit_gfs/fr +! fcrit_gfs/fr ! goto 788 @@ -440,7 +440,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, Fr = heff*bnv/Ulow(i) ZW1 = max(Heff*(1. -fcrit_gfs/fr), 0.0) zw2 = phil(j,2)*rgrav - if (Fr > fcrit_gfs .and. zw1 > zw2 ) then + if (Fr > fcrit_gfs .and. zw1 > zw2 ) then do k=2, kmm1 pkp1log = phil(j,k+1) * rgrav pklog = phil(j,k) * rgrav @@ -458,7 +458,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! ! --- The drag for mtn blocked flow ! - cdmb4 = 0.25*cdmb + cdmb4 = 0.25*cdmb DO I = 1, npt J = ipt(i) ! @@ -474,9 +474,9 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, tem = cos(ANG(I,K)) COSANG2 = tem * tem - SINANG2 = 1.0 - COSANG2 + SINANG2 = 1.0 - COSANG2 ! -! cos =1 sin =0 => 1/R= gam ZR = 2.-gam +! cos =1 sin =0 => 1/R= gam ZR = 2.-gam ! cos =0 sin =1 => 1/R= 1/gam ZR = 2.- 1/gam ! rdem = COSANG2 + GAM2 * SINANG2 @@ -516,12 +516,12 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62 ! inside "cires_ugwp_initialize.F90" now ! - KMPBL = km / 2 + KMPBL = km / 2 iwk(1:npt) = 2 ! -! METO-scheme: -! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw -! +! METO-scheme: +! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw +! DO K=3,KMPBL DO I=1,npt j = ipt(i) @@ -609,12 +609,12 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! !------------------ ! v0: incorporates latest modifications for kxridge and heff/hsat -! and taulin for Fr <=fcrit_gfs +! and taulin for Fr <=fcrit_gfs ! and concept of "clipped" hill if zmtb > 0. to make ! the integrated "tau_sso = tau_ogw +tau_mtb" close to reanalysis data ! it is still used the "single-OGWave"-approach along ULOW-upwind ! -! in contrast to the 2-orthogonal wave (2OTW) schemes of IFS/METO/E-CANADA +! in contrast to the 2-orthogonal wave (2OTW) schemes of IFS/METO/E-CANADA ! 2OTW scheme requires "aver angle" and wind projections on 2 axes of ellipse a-b ! with 2-stresses: taub_a & taub_b from AS of Phillips et al. (1984) !------------------ @@ -638,10 +638,10 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, COEFM = (1. + CLX(I)) ** (OA(I)+1.) ! XLINV(I) = COEFM * CLEFF ! effective kxw for Lin-wave - XLINGFS = COEFM * CLEFF + XLINGFS = COEFM * CLEFF ! TEM = FR * FR * OC(J) - GFOBNV = GMAX * TEM / ((TEM + CG)*BNV) + GFOBNV = GMAX * TEM / ((TEM + CG)*BNV) ! !new specification of XLINV(I) & taulin(i) @@ -649,7 +649,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, if (heff/sigres > hdxres) sigres = heff/hdxres inv_b2eff = 0.5*sigres/heff kxridge = 1.0 / sqrt(sparea(J)) - XLINV(I) = XLINGFS !or max(kxridge, inv_b2eff) ! 6.28/Lx ..0.5*sigma(j)/heff = 1./Lridge + XLINV(I) = XLINGFS !or max(kxridge, inv_b2eff) ! 6.28/Lx ..0.5*sigma(j)/heff = 1./Lridge taulin(i) = 0.5*ROLL(I)*XLINV(I)*BNV*ULOW(I)* & heff*heff @@ -658,12 +658,12 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, & * ULOW(I) * GFOBNV * EFACT ! nonlinear FLUX Tau0...XLINV(I) ! else -! +! TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) - & * ULOW(I) * GFOBNV * EFACT -! + & * ULOW(I) * GFOBNV * EFACT +! ! TAUB(I) = taulin(i) ! linear flux for FR <= fcrit_gfs -! +! endif ! ! @@ -684,16 +684,16 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ENDDO ENDDO - if (strsolver == 'PSS-1986') then + if (strsolver == 'PSS-1986') then !====================================================== ! V0-GFS OROGW-solver of Palmer et al 1986 -"PSS-1986" ! in V1-OROGW LINSATDIS of "WAM-2017" ! with LLWB-mechanism for -! rotational/non-hydrostat OGWs important for +! rotational/non-hydrostat OGWs important for ! HighRES-FV3GFS with dx < 10 km !====================================================== - + DO K = KMPS, KMM1 ! Vertical Level Loop KP1 = K + 1 DO I = 1, npt @@ -713,7 +713,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, SCORK = BNV2(I,K) * TEMV * TEMV RSCOR = MIN(1.0, SCORK / SCOR(I)) SCOR(I) = SCORK - ELSE + ELSE RSCOR = 1. ENDIF ! @@ -740,7 +740,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, TEMC = 2.0 + 1.0 / TEM2 HD = VELCO(I,K) * (2.*SQRT(TEMC)-TEMC) / BRVF TAUP(I,KP1) = TEM1 * HD * HD - ELSE + ELSE TAUP(I,KP1) = TAUP(I,K) * RSCOR ENDIF taup(i,kp1) = min(taup(i,kp1), taup(i,k)) @@ -751,7 +751,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! ! zero momentum deposition at the top model layer ! - taup(1:npt,km+1) = taup(1:npt,km) + taup(1:npt,km+1) = taup(1:npt,km) ! ! Calculate wave acc-n: - (grav)*d(tau)/d(p) = taud ! @@ -762,7 +762,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ENDDO ! !------scale MOMENTUM DEPOSITION AT TOP TO 1/2 VALUE -! it is zero now +! it is zero now ! DO I = 1,npt ! TAUD(I, km) = TAUD(I,km) * FACTOP ! ENDDO @@ -797,19 +797,19 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! ! sigres = max(sigmin, sigma(J)) ! if (heff/sigres.gt.dxres) sigres=heff/dxres -! inv_b2eff = 0.5*sigres/heff +! inv_b2eff = 0.5*sigres/heff ! XLINV(I) = max(kxridge, inv_b2eff) ! 0.5*sigma(j)/heff = 1./Lridge dtfac(:) = 1.0 - + call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsL, & del, sigma, hprime, gamma, theta, & sinlat, xlatd, taup, taud, pkdis) - + endif ! oro_wam_2017 - LINSATDIS-solver of WAM-2017 ! !--------------------------- OROGW-solver of WAM2017 -! +! ! TOFD as in BELJAARS-2004 ! ! --------------------------- @@ -883,7 +883,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! TAUD(I,K) = TAUD(I,K) * DTFAC(I) DTAUX = TAUD(I,K) * XN(I) - DTAUY = TAUD(I,K) * YN(I) + DTAUY = TAUD(I,K) * YN(I) Pdvdt(j,k) = DTAUY +Pdvdt(j,k) Pdudt(j,k) = DTAUX +Pdudt(j,k) @@ -923,9 +923,9 @@ end subroutine gwdps_v0 !=============================================================================== !23456============================================================================== -!> A modification of the Scinocca (2003) \cite scinocca_2003 algorithm for +!> A modification of the Scinocca (2003) \cite scinocca_2003 algorithm for !! NGWs with non-hydrostatic and rotational -!!effects for GW propagations and background dissipation +!!effects for GW propagations and background dissipation subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, & tm1 , um1, vm1, qm1, & prsl, prsi, philg, xlatd, sinlat, coslat, @@ -954,7 +954,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, &, nslope, ilaunch, zmsi &, zci, zdci, zci4, zci3, zci2 &, zaz_fct, zcosang, zsinang - &, nwav, nazd, zcimin, zcimax + &, nwav, nazd, zcimin, zcimax ! implicit none !23456 @@ -967,7 +967,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, real, intent(in) :: vm1(klon,klev) ! meridional wind real, intent(in) :: um1(klon,klev) ! zonal wind real, intent(in) :: qm1(klon,klev) ! spec. humidity - real, intent(in) :: tm1(klon,klev) ! kin temperature + real, intent(in) :: tm1(klon,klev) ! kin temperature real, intent(in) :: prsl(klon,klev) ! mid-layer pressure real, intent(in) :: philg(klon,klev) ! m2/s2-phil => meters !!!!! phil =philg/grav @@ -1001,9 +1001,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! real :: zthm1(klon,klev) ! temperature interface levels real :: zthm1 ! 1.0 / temperature interface levels - real :: zbvfhm1(klon,ilaunch:klev) ! interface BV-frequency + real :: zbvfhm1(klon,ilaunch:klev) ! interface BV-frequency real :: zbn2(klon,ilaunch:klev) ! interface BV-frequency - real :: zrhohm1(klon,ilaunch:klev) ! interface density + real :: zrhohm1(klon,ilaunch:klev) ! interface density real :: zuhm1(klon,ilaunch:klev) ! interface zonal wind real :: zvhm1(klon,ilaunch:klev) ! meridional wind real :: v_zmet(klon,ilaunch:klev) @@ -1048,9 +1048,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! real :: rcpd, grav2cpd - real, parameter :: rcpdl = cpd/grav ! 1/[g/cp] == cp/g - &, grav2cpd = grav/rcpdl ! g*(g/cp)= g^2/cp - &, cpdi = one/cpd + real :: grav2cpd = 1.0E30 ! g*(g/cp)= g^2/cp + real :: rcpdl = 1.0E30 ! 1/[g/cp] == cp/g + real :: cpdi = 1.0E30 ! 1/[g/cp] == cp/g real :: expdis, fdis ! real :: fmode, expdis, fdis @@ -1060,6 +1060,10 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! !-------------------------------------------------------------------------- ! + rcpdl = cpd/grav + grav2cpd = grav/rcpdl ! g*(g/cp)= g^2/cp + cpdi = one/cpd + do k=1,klev do j=1,klon pdvdt(j,k) = zero @@ -1098,8 +1102,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, zthm1 = 2.0_kp / (tvc1+tvm1) zuhm1(jl,jk) = half *(um1(jl,jk-1)+um1(jl,jk)) zvhm1(jl,jk) = half *(vm1(jl,jk-1)+vm1(jl,jk)) -! zrhohm1(jl,jk) = prsi(jl,jk)*rdi/zthm1(jl,jk) ! rho = p/(RTv) - zrhohm1(jl,jk) = prsi(jl,jk)*rdi*zthm1 ! rho = p/(RTv) +! zrhohm1(jl,jk) = prsi(jl,jk)*rdi/zthm1(jl,jk) ! rho = p/(RTv) + zrhohm1(jl,jk) = prsi(jl,jk)*rdi*zthm1 ! rho = p/(RTv) zdelp = phil(jl,jk)-phil(jl,jk-1) !>0 ...... dz-meters v_zmet(jl,jk) = zdelp + zdelp delpi(jl,jk) = grav / (prsi(jl,jk-1) - prsi(jl,jk)) @@ -1152,16 +1156,16 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo ! define rho(zo)/n(zo) -! ------------------- - do jk=ilaunch, klev-1 +! ------------------- + do jk=ilaunch, klev-1 do jl=1,klon zfct(jl,jk) = zrhohm1(jl,jk) / zbvfhm1(jl,jk) enddo enddo -! ----------------------------------------- +! ----------------------------------------- ! set launch momentum flux spectral density -! ----------------------------------------- +! ----------------------------------------- if(nslope == 1) then ! s=1 case ! -------- @@ -1334,7 +1338,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, !======================================================================= ! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat ! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -! define kxw = +! define kxw = !======================================================================= v_cdp = abs(zcin-zui(jL,jk,iazi)) v_wdp = v_kxw*v_cdp @@ -1347,9 +1351,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, endif if ( kzw2 > zero .and. cdf2 > zero) then v_kzw = sqrt(kzw2) -! +! !linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 -! +! !kzw2 = (zBn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NiGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) ! Kds = kxw*Cdf1*rhp2/kzw3 ! @@ -1372,10 +1376,10 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] ! zfluxs = zfct(jl,jk)*v_cdp*v_cdp*zcinc -! +! ! zfluxs= zfct(jl,jk)*(zcin-zui(jl,jk,iazi))**2/zcin ! flux_tot - sat.flux -! +! zdep = zact(jl,inc,iazi)* (fdis-zfluxs) if(zdep > zero ) then ! subs on sat-limit @@ -1392,13 +1396,13 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! integrate over spectral modes zpu(y, z, azimuth) zact(jl,inc,iazi)*zflux(jl,inc,iazi)*[d("zcinc")] ! zdfdz_v(:,jk,iazi) = zero - + do inc=1, nwav zcinc = zdci(inc) ! dc-integration do jl=1,klon vc_zflx_mode = zact(jl,inc,iazi)*zflux(jl,inc,iazi) zpu(jl,jk,iazi) = zpu(jl,jk,iazi) + vc_zflx_mode*zcinc - + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check monotonic decrease ! (heat deposition integration over spectral mode for each azimuth @@ -1462,7 +1466,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ze2 = (tauy(jl,jk)-tauy(jl,jk-1))*zdelp if (abs(ze1) >= maxdudt ) then ze1 = sign(maxdudt, ze1) - endif + endif if (abs(ze2) >= maxdudt ) then ze2 = sign(maxdudt, ze2) endif @@ -1479,7 +1483,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo ! ! add limiters/efficiency for "unbalanced ics" if it is needed -! +! do jk=ilaunch,klev do jl=1, klon pdudt(jl,jk) = gw_eff * pdudt(jl,jk) @@ -1489,8 +1493,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo enddo ! -!--------------------------------------------------------------------------- +!--------------------------------------------------------------------------- return end subroutine fv3_ugwp_solv2_v0 - + end module ugwp_driver_v0 diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 index ce2a2a9e2..6c127dfb8 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 @@ -2,16 +2,16 @@ !! This file contains the subroutines that calculate diagnotics variables !! after calling any microphysics scheme: -!> This module contains the subroutine that calculates +!> This module contains the subroutine that calculates !! precipitation type and its post, which provides precipitation forcing !! to LSM. module GFS_MP_generic_post contains !> If dominant precip type is requested (i.e., Zhao-Carr MP scheme), 4 more algorithms in calpreciptype() -!! will be called. the tallies are then summed in calwxt_dominant(). For GFDL cloud MP scheme, determine convective +!! will be called. the tallies are then summed in calwxt_dominant(). For GFDL cloud MP scheme, determine convective !! rain/snow by surface temperature; and determine explicit rain/snow by rain/snow coming out directly from MP. -!! +!! !> \section arg_table_GFS_MP_generic_post_run Argument Table !! \htmlinclude GFS_MP_generic_post_run.html !! @@ -27,7 +27,9 @@ subroutine GFS_MP_generic_post_run( graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, num_diag_buckets, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & fh_dfi_radar,index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, prevsq, & - iopt_lake, iopt_lake_clm, lkm, use_lake_model, errmsg, errflg) + iopt_lake, iopt_lake_clm, lkm, use_lake_model, con_eps, con_epsm1, & + con_epsq, con_fvirt, con_rog, & + errmsg, errflg) ! use machine, only: kind_phys use calpreciptype_mod, only: calpreciptype @@ -54,6 +56,9 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:,:), intent(in) :: prsl, save_t, del real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, phii,phil real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0, save_q + real(kind=kind_phys), intent(in) :: con_eps, con_epsm1 + real(kind=kind_phys), intent(in) :: con_epsq, con_fvirt + real(kind=kind_phys), intent(in) :: con_rog real(kind=kind_phys), dimension(:,:,:), intent(in), optional :: dfi_radar_tten @@ -128,7 +133,7 @@ subroutine GFS_MP_generic_post_run( errflg = 0 onebg = one/con_g - + do i = 1, im rain(i) = rainc(i) + frain * rain1(i) ! time-step convective plus explicit enddo @@ -140,9 +145,9 @@ subroutine GFS_MP_generic_post_run( do i=1,im factor(i) = 0.0 lfrz = .true. - zfrz(i) = phil(i,1)*onebg + zfrz(i) = phil(i,1)*onebg do k = levs, 1, -1 - zo(i,k) = phil(i,k)*onebg + zo(i,k) = phil(i,k)*onebg if (gt0(i,k) >= con_t0c .and. lfrz) then zfrz(i) = zo(i,k) lfrz = .false. @@ -242,7 +247,7 @@ subroutine GFS_MP_generic_post_run( endif endif -!> - If requested (e.g. Zhao-Carr MP scheme), call calpreciptype() to calculate dominant +!> - If requested (e.g. Zhao-Carr MP scheme), call calpreciptype() to calculate dominant !! precipitation type. ! DH* TODO - Fix wrong code in non-CCPP build (GFS_physics_driver) ! and use commented lines here (keep wrong version for bit-for-bit): @@ -268,7 +273,7 @@ subroutine GFS_MP_generic_post_run( tprcp = max (zero, rain) ! time-step convective and explicit precip ice = frain*rain1*sr ! time-step ice end if - + if (lsm==lsm_ruc .or. lsm==lsm_noahmp) then raincprv(:) = rainc(:) rainncprv(:) = frain * rain1(:) @@ -300,7 +305,9 @@ subroutine GFS_MP_generic_post_run( call calpreciptype (kdt, nrcm, im, im, levs, levs+1, & rann, xlat, xlon, gt0, & gq0(:,:,1), prsl, prsi, & - rain, phii, tsfc, & ! input + rain, phii, tsfc, & + con_g, con_eps, con_epsm1, & + con_epsq, con_fvirt, con_rog, & ! input domr, domzr, domip, doms) ! output ! ! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation @@ -385,7 +392,7 @@ subroutine GFS_MP_generic_post_run( enddo enddo - ! Conversion factor from mm per day to m per physics timestep + ! Conversion factor from mm per day to m per physics timestep tem = dtp * con_p001 / con_day !> - For GFDL, Thompson and NSSL MP schemes, determine convective snow by surface temperature; @@ -398,7 +405,7 @@ subroutine GFS_MP_generic_post_run( ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP - + if (lsm /= lsm_ruc) then do i = 1, im !tprcp(i) = max(0.0, rain(i) )! clu: rain -> tprcp ! DH now lines 245-250 @@ -541,7 +548,7 @@ subroutine GFS_MP_generic_post_run( pwat(i) = pwat(i) * onebg enddo - if(progsigma)then + if(progsigma)then do k = 1, levs do i=1, im prevsq(i,k) = gq0(i,k,1) diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta index ea1b456e3..4edda08d0 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta @@ -275,7 +275,7 @@ units = index dimensions = (horizontal_loop_extent) type = integer - intent = in + intent = in [refl_10cm] standard_name = radar_reflectivity_10cm long_name = instantaneous refl_10cm @@ -956,6 +956,46 @@ dimensions = (horizontal_loop_extent) type = integer intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_epsm1] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one + long_name = (rd/rv) - 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_epsq] + standard_name = minimum_value_of_specific_humidity + long_name = floor value for specific humidity + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rog] + standard_name = ratio_of_gas_constant_dry_air_to_gravitational_acceleration + long_name = (rd/g) + units = J s2 K-1 kg-1 m-1 + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -971,4 +1011,3 @@ dimensions = () type = integer intent = out - diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 index 4d1391e20..2dcb71fe8 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 @@ -2,7 +2,7 @@ !! This file contains !> \defgroup GFS_rrtmg_setup_mod GFS RRTMG Scheme Setup -!! This subroutine initializes RRTMG. +!! This subroutine initializes RRTMG. !> @{ module GFS_rrtmg_setup @@ -42,7 +42,8 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & iovr_max, iovr_dcorr, iovr_exp, iovr_exprand, icliq_sw, lcrick, & lcnorm, imp_physics, lnoprec, idate, iflip, do_RRTMGP, me, lalw1bd, & iaermdl, iaerflg, aeros_file, con_pi, con_t0c, con_c, con_boltz, & - con_plnk, con_solr_2008, con_solr_2002, con_g, con_rd, co2usr_file, & + con_plnk, con_solr_2008, con_solr_2002, con_g, con_rd, con_cp, & + co2usr_file, & co2cyc_file, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, isubclw,& iswmode, ipsd0, ltp, lextop, errmsg, errflg) ! ================= subprogram documentation block ================ ! @@ -162,7 +163,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & character(len=26),intent(in) :: aeros_file, solar_file, co2usr_file,& co2cyc_file real(kind_phys), intent(in) :: con_pi, con_t0c, con_c, con_boltz, & - con_plnk, con_solr_2008, con_solr_2002, con_g, con_rd + con_plnk, con_solr_2008, con_solr_2002, con_g, con_rd, con_cp integer, intent(inout) :: ipsd0 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -171,7 +172,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & ! Initialize the CCPP error handling variables errmsg = '' errflg = 0 - + if (do_RRTMGP) then write(errmsg,'(*(a))') "Logic error: do_RRTMGP must be set to .false." errflg = 1 @@ -181,7 +182,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & if ( ictm==0 .or. ictm==-2 ) then iaerflg = mod(iaer, 100) ! no volcanic aerosols for clim hindcast else - iaerflg = mod(iaer, 1000) + iaerflg = mod(iaer, 1000) endif iaermdl = iaer/1000 ! control flag for aerosol scheme selection @@ -222,12 +223,12 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & call rlwinit ( me, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, & iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & - iovr_exp, iovr_exprand, errflg, errmsg ) + iovr_exp, iovr_exprand, con_g, con_cp, errflg, errmsg ) if(errflg/=0) return call rswinit ( me, rad_hr_units, inc_minor_gas, icliq_sw, isubclw, & iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & - iovr_exp, iovr_exprand,iswmode, errflg, errmsg ) + iovr_exp, iovr_exprand,iswmode, con_g, con_cp, errflg, errmsg ) if(errflg/=0) return if ( me == 0 ) then diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.meta index a8030d969..b090dfa5a 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.meta @@ -341,6 +341,14 @@ type = real kind = kind_phys intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in [lalw1bd] standard_name = do_longwave_aerosol_band_properties long_name = control of band or multiband longwave aerosol properties diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.F90 index a159d899d..80148f738 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.F90 @@ -3,7 +3,8 @@ module GFS_time_vary_pre - use funcphys, only: gfuncphys + use funcphys, only: gfuncphys, funcphys_init + use ugwp_common_v0, only: ugwp_common_v0_init implicit none @@ -21,10 +22,21 @@ module GFS_time_vary_pre !> \section arg_table_GFS_time_vary_pre_init Argument Table !! \htmlinclude GFS_time_vary_pre_init.html !! - subroutine GFS_time_vary_pre_init (errmsg, errflg) + subroutine GFS_time_vary_pre_init ( & + con_cp, con_rd, con_cvap, con_cliq, & + con_rv, con_hvap, con_ttp, con_psat, & + con_csol, con_hfus, con_rocp, con_eps, & + con_pi, con_g, con_fvirt, con_rerth, & + errmsg, errflg) implicit none + real(kind=kind_phys), intent(in) :: con_cp, con_rd, con_cvap + real(kind=kind_phys), intent(in) :: con_cliq, con_rv, con_hvap + real(kind=kind_phys), intent(in) :: con_ttp, con_psat, con_csol + real(kind=kind_phys), intent(in) :: con_hfus, con_rocp, con_eps + real(kind=kind_phys), intent(in) :: con_pi, con_g, con_fvirt, con_rerth + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -34,6 +46,13 @@ subroutine GFS_time_vary_pre_init (errmsg, errflg) if (is_initialized) return + !--- Initialize constants in modules + call funcphys_init(con_cp, con_rd, con_cvap, con_cliq, & + con_rv, con_hvap, con_ttp, con_psat, con_csol, & + con_hfus, con_rocp, con_eps) + call ugwp_common_v0_init(con_pi, con_g, con_rd, con_rv, & + con_cp, con_fvirt, con_rerth) + !--- Call gfuncphys (funcphys.f) to compute all physics function tables. call gfuncphys () diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.meta index bdf4ec8d5..7b898c4bd 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.meta @@ -3,11 +3,140 @@ type = scheme dependencies_path = ../../ dependencies = tools/funcphys.f90,hooks/machine.F + dependencies = GWD/ugwp_common_v0.f90 ######################################################################## [ccpp-arg-table] name = GFS_time_vary_pre_init type = scheme +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cvap] + standard_name = specific_heat_of_water_vapor_at_constant_pressure + long_name = specific heat of water vapor at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cliq] + standard_name = specific_heat_of_liquid_water_at_constant_pressure + long_name = specific heat of liquid water at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_ttp] + standard_name = triple_point_temperature_of_water + long_name = triple point temperature of water + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[con_psat] + standard_name = saturation_pressure_at_triple_point_of_water + long_name = saturation pressure at triple point of water + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in +[con_csol] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rocp] + standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure + long_name = (rd/cp) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -73,14 +202,14 @@ [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls - units = + units = dimensions = () type = integer intent = in [nslwr] standard_name = number_of_timesteps_between_longwave_radiation_calls long_name = number of timesteps between longwave radiation calls - units = + units = dimensions = () type = integer intent = in diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.F90 index 5f305d24f..4e80d27e8 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.F90 @@ -3,7 +3,8 @@ module GFS_time_vary_pre - use funcphys, only: gfuncphys + use funcphys, only: gfuncphys, funcphys_init + use ugwp_common_v0, only: ugwp_common_v0_init implicit none @@ -18,10 +19,22 @@ module GFS_time_vary_pre !> \section arg_table_GFS_time_vary_pre_init Argument Table !! \htmlinclude GFS_time_vary_pre_init.html !! - subroutine GFS_time_vary_pre_init (errmsg, errflg) - + subroutine GFS_time_vary_pre_init ( & + con_cp, con_rd, con_cvap, con_cliq, & + con_rv, con_hvap, con_ttp, con_psat, & + con_csol, con_hfus, con_rocp, con_eps, & + con_pi, con_g, con_fvirt, con_rerth, & + errmsg, errflg) + + use machine, only: kind_phys implicit none + real(kind=kind_phys), intent(in) :: con_cp, con_rd, con_cvap + real(kind=kind_phys), intent(in) :: con_cliq, con_rv, con_hvap + real(kind=kind_phys), intent(in) :: con_ttp, con_psat, con_csol + real(kind=kind_phys), intent(in) :: con_hfus, con_rocp, con_eps + real(kind=kind_phys), intent(in) :: con_pi, con_g, con_fvirt, con_rerth + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -31,6 +44,13 @@ subroutine GFS_time_vary_pre_init (errmsg, errflg) if (is_initialized) return + !--- Initialize funcphys constants + call funcphys_init(con_cp, con_rd, con_cvap, con_cliq, & + con_rv, con_hvap, con_ttp, con_psat, con_csol, & + con_hfus, con_rocp, con_eps) + call ugwp_common_v0_init(con_pi, con_g, con_rd, con_rv, & + con_cp, con_fvirt, con_rerth) + !--- Call gfuncphys (funcphys.f) to compute all physics function tables. call gfuncphys () @@ -72,20 +92,20 @@ subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, nsswr, & use machine, only: kind_phys, kind_dbl_prec, kind_sngl_prec implicit none - + integer, intent(in) :: idate(:) integer, intent(in) :: jdat(:), idat(:) integer, intent(in) :: nsswr, nslwr, me, & master, nscyc logical, intent(in) :: debug real(kind=kind_phys), intent(in) :: dtp - + integer, intent(out) :: kdt, yearlen, ipt logical, intent(out) :: lprnt, lssav, lsswr, & lslwr real(kind=kind_phys), intent(out) :: sec, phour, zhour, & fhour, julian, solhr - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -129,13 +149,13 @@ subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, nsswr, & zhour = phour fhour = (sec + dtp)/con_hr kdt = nint((sec + dtp)/dtp) - - !GJF* These calculations were originally in GFS_physics_driver.F90 for - ! NoahMP. They were moved to this routine since they only depends - ! on time (not space). Note that this code is included as-is from - ! GFS_physics_driver.F90, but it may be simplified by using more - ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day - ! of year and W3DIFDAT to determine the integer number of days in + + !GJF* These calculations were originally in GFS_physics_driver.F90 for + ! NoahMP. They were moved to this routine since they only depends + ! on time (not space). Note that this code is included as-is from + ! GFS_physics_driver.F90, but it may be simplified by using more + ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day + ! of year and W3DIFDAT to determine the integer number of days in ! a given year). *GJF ! Julian day calculation (fcst day of the year) ! we need yearln and julian to @@ -148,7 +168,7 @@ subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, nsswr, & fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 julian = float(jd1-jd0) + fjd - + ! ! Year length ! diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.meta index 3bebfbe65..cc7934e42 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.meta @@ -3,11 +3,140 @@ type = scheme dependencies_path = ../../ dependencies = tools/funcphys.f90,hooks/machine.F + dependencies = GWD/ugwp_common_v0.f90 ######################################################################## [ccpp-arg-table] name = GFS_time_vary_pre_init type = scheme +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cvap] + standard_name = specific_heat_of_water_vapor_at_constant_pressure + long_name = specific heat of water vapor at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cliq] + standard_name = specific_heat_of_liquid_water_at_constant_pressure + long_name = specific heat of liquid water at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_ttp] + standard_name = triple_point_temperature_of_water + long_name = triple point temperature of water + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[con_psat] + standard_name = saturation_pressure_at_triple_point_of_water + long_name = saturation pressure at triple point of water + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in +[con_csol] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rocp] + standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure + long_name = (rd/cp) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -73,14 +202,14 @@ [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls - units = + units = dimensions = () type = integer intent = in [nslwr] standard_name = number_of_timesteps_between_longwave_radiation_calls long_name = number of timesteps between longwave radiation calls - units = + units = dimensions = () type = integer intent = in @@ -176,7 +305,7 @@ [ipt] standard_name = index_of_horizontal_gridpoint_for_debug_output long_name = horizontal index for point used for diagnostic printout - units = index + units = index dimensions = () type = integer intent = out diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.meta index 57fa61dfe..1af83a346 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.meta @@ -3,7 +3,7 @@ type = scheme dependencies_path = ../../ dependencies = tools/funcphys.f90,hooks/machine.F - dependencies = hooks/physcons.F90,Radiation/RRTMG/radcons.f90 + dependencies = Radiation/RRTMG/radcons.f90 dependencies = Radiation/radiation_clouds.f,MP/module_mp_radar.F90,MP/Thompson/module_mp_thompson.F90 ######################################################################## @@ -276,7 +276,7 @@ type = integer intent = in [conv_cf_opt] - standard_name = option_for_convection_scheme_cloud_fraction_computation + standard_name = option_for_convection_scheme_cloud_fraction_computation long_name = option for convection scheme cloud fraction computation units = flag dimensions = () @@ -419,7 +419,7 @@ dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys - intent = in + intent = in [xlat] standard_name = latitude long_name = grid latitude diff --git a/physics/MP/GFDL/fv_sat_adj.F90 b/physics/MP/GFDL/fv_sat_adj.F90 index 6fb0d73a1..0d6432ee4 100644 --- a/physics/MP/GFDL/fv_sat_adj.F90 +++ b/physics/MP/GFDL/fv_sat_adj.F90 @@ -1,21 +1,21 @@ !>\file fv_sat_adj.F90 !! This file contains the GFDL in-core fast saturation adjustment. -!! and it is an "intermediate physics" implemented in the remapping Lagrangian to +!! and it is an "intermediate physics" implemented in the remapping Lagrangian to !! Eulerian loop of FV3 solver. !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Cloud Microphysics. !* -!* The GFDL Cloud Microphysics is free software: you can +!* The GFDL Cloud Microphysics is free software: you can !8 redistribute it and/or modify it under the terms of the !* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or +!* Free Software Foundation, either version 3 of the License, or !* (at your option) any later version. !* !* The GFDL Cloud Microphysics is distributed in the hope it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !* See the GNU General Public License for more details. !* !* You should have received a copy of the GNU Lesser General Public @@ -23,7 +23,7 @@ !* If not, see . !*********************************************************************** -!> This module contains the GFDL in-core fast saturation adjustment +!> This module contains the GFDL in-core fast saturation adjustment !! called in FV3 dynamics solver. module fv_sat_adj ! Modules Included: @@ -52,14 +52,6 @@ module fv_sat_adj ! rad_rain, rad_snow, rad_graupel, dw_ocean, dw_land, tintqs ! ! - ! DH* TODO - MAKE THIS INPUT ARGUMENTS *DH - use physcons, only : rdgas => con_rd_dyn, & - rvgas => con_rv_dyn, & - grav => con_g_dyn, & - hlv => con_hvap_dyn, & - hlf => con_hfus_dyn, & - cp_air => con_cp_dyn - ! *DH use machine, only: kind_grid, kind_dyn use module_gfdlmp_param, only: ql_gen, qi_gen, qi0_max, ql_mlt, ql0_max, qi_lim, qs_mlt use module_gfdlmp_param, only: icloud_f, sat_adj0, t_sub, cld_min @@ -74,18 +66,17 @@ module fv_sat_adj #endif implicit none - + private public fv_sat_adj_init, fv_sat_adj_run, fv_sat_adj_finalize logical :: is_initialized = .false. - real(kind=kind_dyn), parameter :: rrg = -rdgas/grav - ! real, parameter :: cp_air = cp_air ! 1004.6, heat capacity of dry air at constant pressure, come from constants_mod - real(kind=kind_dyn), parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapor at constant pressure - real(kind=kind_dyn), parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume - real(kind=kind_dyn), parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume + real(kind=kind_dyn) :: rrg = 1.0E30_kind_dyn + real(kind=kind_dyn) :: cp_vap = 1.0E30_kind_dyn + real(kind=kind_dyn) :: cv_air = 1.0E30_kind_dyn + real(kind=kind_dyn) :: cv_vap = 1.0E30_kind_dyn ! http: / / www.engineeringtoolbox.com / ice - thermal - properties - d_576.html ! c_ice = 2050.0 at 0 deg c ! c_ice = 1972.0 at - 15 deg c @@ -98,19 +89,19 @@ module fv_sat_adj ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c real(kind=kind_dyn), parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c real(kind=kind_dyn), parameter :: c_liq = 4185.5 !< gfdl: heat capacity of liquid at 15 deg c - real(kind=kind_dyn), parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling + real(kind=kind_dyn) :: dc_vap = 1.0E30_kind_dyn real(kind=kind_dyn), parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling real(kind=kind_dyn), parameter :: tice = 273.16 !< freezing temperature real(kind=kind_dyn), parameter :: t_wfr = tice - 40. !< homogeneous freezing temperature - real(kind=kind_dyn), parameter :: lv0 = hlv - dc_vap * tice !< 3.13905782e6, evaporation latent heat coefficient at 0 deg k - real(kind=kind_dyn), parameter :: li00 = hlf - dc_ice * tice !< - 2.7105966e5, fusion latent heat coefficient at 0 deg k + real(kind=kind_dyn) :: lv0 = 1.0E30_kind_dyn + real(kind=kind_dyn) :: li00 = 1.0E30_kind_dyn ! real (kind_grid), parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c real (kind_grid), parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c - real (kind_grid), parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling - real (kind_grid), parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k - real(kind=kind_dyn), parameter :: lat2 = (hlv + hlf) ** 2 !< used in bigg mechanism - real(kind=kind_dyn) :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap - real(kind=kind_dyn) :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap + real (kind_grid) :: d2ice = 1.0E30_kind_grid + real (kind_grid) :: li2 = 1.0E30_kind_grid + real(kind=kind_dyn) :: lat2 = 1.0E30_kind_dyn + real(kind=kind_dyn) :: d0_vap = 1.0E30_kind_dyn !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap + real(kind=kind_dyn) :: lv00 = 1.0E30_kind_dyn !< the same as lv0, except that cp_vap can be cp_vap or cv_vap real(kind=kind_dyn), allocatable :: table (:), table2 (:), tablew (:), des2 (:), desw (:) contains @@ -120,7 +111,9 @@ module fv_sat_adj !! \htmlinclude fv_sat_adj_init.html !! subroutine fv_sat_adj_init(do_sat_adj, kmp, nwat, ngas, rilist, cpilist, & - mpirank, mpiroot, errmsg, errflg) + mpirank, mpiroot, con_rd, con_cp, & + con_g, con_hvap, con_hfus, & + errmsg, errflg) implicit none @@ -133,13 +126,48 @@ subroutine fv_sat_adj_init(do_sat_adj, kmp, nwat, ngas, rilist, cpilist, & real(kind_dyn), intent(in ) :: cpilist(0:ngas) integer, intent(in ) :: mpirank integer, intent(in ) :: mpiroot + real(kind_phys), intent(in ) :: con_rd + real(kind_phys), intent(in ) :: con_cp + real(kind_phys), intent(in ) :: con_g + real(kind_phys), intent(in ) :: con_hvap + real(kind_phys), intent(in ) :: con_hfus character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg ! Local variables integer, parameter :: length = 2621 + real(kind_dyn) :: con_rd_dyn + real(kind_dyn) :: con_cp_dyn + real(kind_dyn) :: cp_air integer :: i + con_rd_dyn = real(con_rd, kind=kind_dyn) + con_cp_dyn = real(con_cp, kind=kind_dyn) + rdgas = con_rd_dyn + rvgas = con_rv_dyn + grav = real(con_g, kind=kind_dyn) + hlv = real(con_hvap, kind=kind_dyn) + hlf = real(con_hfus, kind=kind_dyn) + + ! initialize module variables + rrg = -rdgas/grav + cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapor at constant pressure + ! real, parameter :: cp_air = cp_air ! 1004.6, heat capacity of dry air at constant pressure, come from constants_mod + cp_air = real(con_cp, kind=kind_dyn) + cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume + cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume + dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling + lv0 = hlv - dc_vap * tice !< 3.13905782e6, evaporation latent heat coefficient at 0 deg k + li00 = hlf - dc_ice * tice !< - 2.7105966e5, fusion latent heat coefficient at 0 deg k + d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling + li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k + lat2 = (hlv + hlf) ** 2 !< used in bigg mechanism + + + + con_rd_dyn = real(con_rd, kind=kind_dyn) + con_cp_dyn = real(con_cp, kind=kind_dyn) + ! Initialize the CCPP error handling variables errmsg = '' errflg = 0 @@ -179,7 +207,8 @@ subroutine fv_sat_adj_init(do_sat_adj, kmp, nwat, ngas, rilist, cpilist, & desw (length) = desw (length - 1) #ifdef MULTI_GASES - call multi_gases_init(ngas,nwat,rilist,cpilist,mpirank==mpiroot) + call multi_gases_init(ngas,nwat,rilist,cpilist,mpirank==mpiroot, & + con_rd_dyn, con_cp_dyn) #endif is_initialized = .true. @@ -234,9 +263,9 @@ end subroutine fv_sat_adj_finalize subroutine fv_sat_adj_run(mdt, zvir, is, ie, isd, ied, isc1, iec1, isc2, iec2, kmp, km, kmdelz, js, je, jsd, jed, jsc1, jec1, jsc2, jec2, & ng, hydrostatic, fast_mp_consv, te0_2d, te0, ngas, qvi, qv, ql, qi, qr, & qs, qg, hs, peln, delz, delp, pt, pkz, q_con, akap, cappa, area, dtdt, & - out_dt, last_step, do_qa, qa, & - nthreads, errmsg, errflg) - + out_dt, last_step, do_qa, qa, nthreads & + con_rd, con_rv, con_g, con_hvap, con_hfus, con_cp, & + errmsg, errflg) implicit none ! Interface variables @@ -309,10 +338,24 @@ subroutine fv_sat_adj_run(mdt, zvir, is, ie, isd, ied, isc1, iec1, isc2, iec2, k logical, intent(in) :: do_qa real(kind=kind_dyn), intent( out) :: qa(isd:ied, jsd:jed, 1:km) integer, intent(in) :: nthreads + real(kind=kind_phys),intent(in) :: con_rd + real(kind=kind_phys),intent(in) :: con_rv + real(kind=kind_phys),intent(in) :: con_g + real(kind=kind_phys),intent(in) :: con_hvap + real(kind=kind_phys),intent(in) :: con_hfus + real(kind=kind_phys),intent(in) :: con_cp character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg ! Local variables + real(kind=kind_dyn) :: rdgas + real(kind=kind_dyn) :: rvgas + real(kind=kind_dyn) :: grav + real(kind=kind_dyn) :: hlv + real(kind=kind_dyn) :: hfl + real(kind=kind_dyn) :: cp_air + + real(kind=kind_dyn), dimension(is:ie,js:je) :: dpln integer :: kdelz integer :: k, j, i @@ -321,6 +364,14 @@ subroutine fv_sat_adj_run(mdt, zvir, is, ie, isd, ied, isc1, iec1, isc2, iec2, k errmsg = '' errflg = 0 + ! Initialize from input constants + rdgas = real(con_rd, kind=kind_dyn) + rvgas = real(con_rv, kind=kind_dyn) + grav = real(con_g, kind=kind_dyn) + hlv = real(con_hvap, kind=kind_dyn) + hlf = real(con_hfus, kind=kind_dyn) + cp_air = real(con_cp, kind=kind_dyn) + #ifndef FV3 ! Open parallel region if not already opened by host model !$OMP parallel num_threads(nthreads) default(none) & @@ -403,9 +454,9 @@ end subroutine fv_sat_adj_run subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, te0, & #ifdef MULTI_GASES qvi, & -#else +#else qv, & -#endif +#endif ql, qi, qr, qs, qg, hs, dpln, delz, pt, dp, q_con, cappa, & area, dtdt, out_dt, last_step, do_qa, qa) @@ -450,28 +501,28 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, #endif sdt = 0.5 * mdt ! half remapping time step dt_bigg = mdt ! bigg mechinism time step - + tice0 = tice - 0.01 ! 273.15, standard freezing temperature - + ! ----------------------------------------------------------------------- !> - Define conversion scalar / factor. ! ----------------------------------------------------------------------- - + fac_i2s = 1. - exp (- mdt / tau_i2s) fac_v2l = 1. - exp (- sdt / tau_v2l) fac_r2g = 1. - exp (- mdt / tau_r2g) fac_l2r = 1. - exp (- mdt / tau_l2r) - + fac_l2v = 1. - exp (- sdt / tau_l2v) fac_l2v = min (sat_adj0, fac_l2v) - + fac_imlt = 1. - exp (- sdt / tau_imlt) fac_smlt = 1. - exp (- mdt / tau_smlt) - + ! ----------------------------------------------------------------------- !> - Define heat capacity of dry air and water vapor based on hydrostatical property. ! ----------------------------------------------------------------------- - + if (hydrostatic) then c_air = cp_air c_vap = cp_vap @@ -483,9 +534,9 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, lv00 = hlv - d0_vap * tice ! dc_vap = cp_vap - c_liq ! - 2339.5 ! d0_vap = cv_vap - c_liq ! - 2801.0 - + do j = js, je ! start j loop - + do i = is, ie q_liq (i) = ql (i, j) + qr (i, j) q_sol (i) = qi (i, j) + qs (i, j) + qg (i, j) @@ -502,11 +553,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, t0 (i) = pt1 (i) ! true temperature qpz (i) = qpz (i) + qv (i, j) ! total_wat conserved in this routine enddo - + ! ----------------------------------------------------------------------- !> - Define air density based on hydrostatical property. ! ----------------------------------------------------------------------- - + if (hydrostatic) then do i = is, ie den (i) = dp (i, j) / (dpln (i, j) * rdgas * pt (i, j)) @@ -516,11 +567,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, den (i) = - dp (i, j) / (grav * delz (i, j)) ! moist_air density enddo endif - + ! ----------------------------------------------------------------------- !> - Define heat capacity and latend heat coefficient. ! ----------------------------------------------------------------------- - + do i = is, ie #ifdef MULTI_GASES if (hydrostatic) then @@ -534,11 +585,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, lhi (i) = li00 + dc_ice * pt1 (i) icp2 (i) = lhi (i) / cvm (i) enddo - + ! ----------------------------------------------------------------------- !> - Fix energy conservation. ! ----------------------------------------------------------------------- - + if (consv_te) then if (hydrostatic) then do i = is, ie @@ -560,22 +611,22 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, enddo endif endif - + ! ----------------------------------------------------------------------- !> - Fix negative cloud ice with snow. ! ----------------------------------------------------------------------- - + do i = is, ie if (qi (i, j) < 0.) then qs (i, j) = qs (i, j) + qi (i, j) qi (i, j) = 0. endif enddo - + ! ----------------------------------------------------------------------- !> - Melting of cloud ice to cloud water and rain. ! ----------------------------------------------------------------------- - + do i = is, ie if (qi (i, j) > 1.e-8 .and. pt1 (i) > tice) then sink (i) = min (qi (i, j), fac_imlt * (pt1 (i) - tice) / icp2 (i)) @@ -592,20 +643,20 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, pt1 (i) = pt1 (i) - sink (i) * lhi (i) / cvm (i) endif enddo - + ! ----------------------------------------------------------------------- !> - Update latend heat coefficient. ! ----------------------------------------------------------------------- - + do i = is, ie lhi (i) = li00 + dc_ice * pt1 (i) icp2 (i) = lhi (i) / cvm (i) enddo - + ! ----------------------------------------------------------------------- !> - Fix negative snow with graupel or graupel with available snow. ! ----------------------------------------------------------------------- - + do i = is, ie if (qs (i, j) < 0.) then qg (i, j) = qg (i, j) + qs (i, j) @@ -616,13 +667,13 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, qs (i, j) = qs (i, j) - tmp endif enddo - + ! after this point cloud ice & snow are positive definite - + ! ----------------------------------------------------------------------- !> - Fix negative cloud water with rain or rain with available cloud water. ! ----------------------------------------------------------------------- - + do i = is, ie if (ql (i, j) < 0.) then tmp = min (- ql (i, j), max (0., qr (i, j))) @@ -634,7 +685,7 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, qr (i, j) = qr (i, j) + tmp endif enddo - + ! ----------------------------------------------------------------------- !> - Enforce complete freezing of cloud water to cloud ice below - 48 c. ! ----------------------------------------------------------------------- @@ -651,11 +702,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, pt1 (i) = pt1 (i) + sink (i) * lhi (i) / cvm (i) endif enddo - + ! ----------------------------------------------------------------------- !> - Update latend heat coefficient. ! ----------------------------------------------------------------------- - + do i = is, ie lhl (i) = lv00 + d0_vap * pt1 (i) lhi (i) = li00 + dc_ice * pt1 (i) @@ -663,13 +714,13 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, icp2 (i) = lhi (i) / cvm (i) tcp3 (i) = lcp2 (i) + icp2 (i) * min (1., dim (tice, pt1 (i)) /48.) enddo - + ! ----------------------------------------------------------------------- !> - Condensation/evaporation between water vapor and cloud water. ! ----------------------------------------------------------------------- - + call wqs2_vect (is, ie, pt1, den, wqsat, dq2dt) - + adj_fac = sat_adj0 do i = is, ie dq0 = (qv (i, j) - wqsat (i)) / (1. + tcp3 (i) * dq2dt (i)) @@ -692,11 +743,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, cvm (i) = mc_air (i) + qv (i, j) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice pt1 (i) = pt1 (i) + src (i) * lhl (i) / cvm (i) enddo - + ! ----------------------------------------------------------------------- !> - Update latend heat coefficient. ! ----------------------------------------------------------------------- - + do i = is, ie lhl (i) = lv00 + d0_vap * pt1 (i) lhi (i) = li00 + dc_ice * pt1 (i) @@ -704,17 +755,17 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, icp2 (i) = lhi (i) / cvm (i) tcp3 (i) = lcp2 (i) + icp2 (i) * min (1., dim (tice, pt1 (i)) / 48.) enddo - + if (last_step) then - + ! ----------------------------------------------------------------------- !> - condensation/evaporation between water vapor and cloud water, last time step !! enforce upper (no super_sat) & lower (critical rh) bounds. ! final iteration: ! ----------------------------------------------------------------------- - + call wqs2_vect (is, ie, pt1, den, wqsat, dq2dt) - + do i = is, ie dq0 = (qv (i, j) - wqsat (i)) / (1. + tcp3 (i) * dq2dt (i)) if (dq0 > 0.) then ! remove super - saturation, prevent super saturation over water @@ -736,24 +787,24 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, cvm (i) = mc_air (i) + qv (i, j) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice pt1 (i) = pt1 (i) + src (i) * lhl (i) / cvm (i) enddo - + ! ----------------------------------------------------------------------- !> - Update latend heat coefficient. ! ----------------------------------------------------------------------- - + do i = is, ie lhl (i) = lv00 + d0_vap * pt1 (i) lhi (i) = li00 + dc_ice * pt1 (i) lcp2 (i) = lhl (i) / cvm (i) icp2 (i) = lhi (i) / cvm (i) enddo - + endif - + ! ----------------------------------------------------------------------- !> - Homogeneous freezing of cloud water to cloud ice. ! ----------------------------------------------------------------------- - + do i = is, ie dtmp = t_wfr - pt1 (i) ! [ - 40, - 48] if (ql (i, j) > 0. .and. dtmp > 0.) then @@ -766,20 +817,20 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, pt1 (i) = pt1 (i) + sink (i) * lhi (i) / cvm (i) endif enddo - + ! ----------------------------------------------------------------------- !> - Update latend heat coefficient. ! ----------------------------------------------------------------------- - + do i = is, ie lhi (i) = li00 + dc_ice * pt1 (i) icp2 (i) = lhi (i) / cvm (i) enddo - + ! ----------------------------------------------------------------------- !> - bigg mechanism (heterogeneous freezing of cloud water to cloud ice). ! ----------------------------------------------------------------------- - + do i = is, ie tc = tice0 - pt1 (i) if (ql (i, j) > 0.0 .and. tc > 0.) then @@ -793,20 +844,20 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, pt1 (i) = pt1 (i) + sink (i) * lhi (i) / cvm (i) endif enddo - + ! ----------------------------------------------------------------------- !> - Update latend heat coefficient. ! ----------------------------------------------------------------------- - + do i = is, ie lhi (i) = li00 + dc_ice * pt1 (i) icp2 (i) = lhi (i) / cvm (i) enddo - + ! ----------------------------------------------------------------------- !> - Freezing of rain to graupel. ! ----------------------------------------------------------------------- - + do i = is, ie dtmp = (tice - 0.1) - pt1 (i) if (qr (i, j) > 1.e-7 .and. dtmp > 0.) then @@ -820,20 +871,20 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, pt1 (i) = pt1 (i) + sink (i) * lhi (i) / cvm (i) endif enddo - + ! ----------------------------------------------------------------------- !> - Update latend heat coefficient. ! ----------------------------------------------------------------------- - + do i = is, ie lhi (i) = li00 + dc_ice * pt1 (i) icp2 (i) = lhi (i) / cvm (i) enddo - + ! ----------------------------------------------------------------------- !> - Melting of snow to rain or cloud water. ! ----------------------------------------------------------------------- - + do i = is, ie dtmp = pt1 (i) - (tice + 0.1) if (qs (i, j) > 1.e-7 .and. dtmp > 0.) then @@ -850,11 +901,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, pt1 (i) = pt1 (i) - sink (i) * lhi (i) / cvm (i) endif enddo - + ! ----------------------------------------------------------------------- !> - Autoconversion from cloud water to rain. ! ----------------------------------------------------------------------- - + do i = is, ie if (ql (i, j) > ql0_max) then sink (i) = fac_l2r * (ql (i, j) - ql0_max) @@ -862,11 +913,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, ql (i, j) = ql (i, j) - sink (i) endif enddo - + ! ----------------------------------------------------------------------- !> - Update latend heat coefficient. ! ----------------------------------------------------------------------- - + do i = is, ie lhi (i) = li00 + dc_ice * pt1 (i) lhl (i) = lv00 + d0_vap * pt1 (i) @@ -874,11 +925,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, icp2 (i) = lhi (i) / cvm (i) tcp2 (i) = lcp2 (i) + icp2 (i) enddo - + ! ----------------------------------------------------------------------- !> - Sublimation/deposition between water vapor and cloud ice. ! ----------------------------------------------------------------------- - + do i = is, ie src (i) = 0. if (pt1 (i) < t_sub) then ! too cold to be accurate; freeze qv as a fix @@ -911,11 +962,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, cvm (i) = mc_air (i) + qv (i, j) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice pt1 (i) = pt1 (i) + src (i) * (lhl (i) + lhi (i)) / cvm (i) enddo - + ! ----------------------------------------------------------------------- !> - Virtual temperature updated. ! ----------------------------------------------------------------------- - + do i = is, ie #ifdef USE_COND q_con (i, j) = q_liq (i) + q_sol (i) @@ -936,11 +987,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, #endif #endif enddo - + ! ----------------------------------------------------------------------- !> - Fix negative graupel with available cloud ice. ! ----------------------------------------------------------------------- - + do i = is, ie if (qg (i, j) < 0.) then tmp = min (- qg (i, j), max (0., qi (i, j))) @@ -948,11 +999,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, qi (i, j) = qi (i, j) - tmp endif enddo - + ! ----------------------------------------------------------------------- !> - Autoconversion from cloud ice to snow. ! ----------------------------------------------------------------------- - + do i = is, ie qim = qi0_max / den (i) if (qi (i, j) > qim) then @@ -961,17 +1012,17 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, qs (i, j) = qs (i, j) + sink (i) endif enddo - + if (out_dt) then do i = is, ie dtdt (i, j) = dtdt (i, j) + pt1 (i) - t0 (i) enddo endif - + ! ----------------------------------------------------------------------- !> - Fix energy conservation. ! ----------------------------------------------------------------------- - + if (consv_te) then do i = is, ie if (hydrostatic) then @@ -991,11 +1042,11 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, endif enddo endif - + ! ----------------------------------------------------------------------- !> - Update latend heat coefficient. ! ----------------------------------------------------------------------- - + do i = is, ie lhi (i) = li00 + dc_ice * pt1 (i) lhl (i) = lv00 + d0_vap * pt1 (i) @@ -1003,17 +1054,17 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, lcp2 (i) = lhl (i) / cvm (i) icp2 (i) = lhi (i) / cvm (i) enddo - + ! ----------------------------------------------------------------------- !> - Compute cloud fraction. ! ----------------------------------------------------------------------- - + if (do_qa .and. last_step) then - + ! ----------------------------------------------------------------------- !> - If it is the last step, combine water species. ! ----------------------------------------------------------------------- - + if (rad_snow) then if (rad_graupel) then do i = is, ie @@ -1041,25 +1092,25 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, do i = is, ie q_cond (i) = q_sol (i) + q_liq (i) enddo - + ! ----------------------------------------------------------------------- !> - Use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity. ! ----------------------------------------------------------------------- - + do i = is, ie - - if(tintqs) then + + if(tintqs) then tin = pt1(i) - else + else tin = pt1 (i) - (lcp2 (i) * q_cond (i) + icp2 (i) * q_sol (i)) ! minimum temperature ! tin = pt1 (i) - ((lv00 + d0_vap * pt1 (i)) * q_cond (i) + & ! (li00 + dc_ice * pt1 (i)) * q_sol (i)) / (mc_air (i) + qpz (i) * c_vap) - endif - + endif + ! ----------------------------------------------------------------------- ! determine saturated specific humidity ! ----------------------------------------------------------------------- - + if (tin <= t_wfr) then ! ice phase: qstar (i) = iqs1 (tin, den (i)) @@ -1082,21 +1133,21 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, dw = dw_ocean + (dw_land - dw_ocean) * min (1., abs (hs (i, j)) / (10. * grav)) !> - "scale - aware" subgrid variability: 100 - km as the base hvar (i) = min (0.2, max (0.01, dw * sqrt (sqrt (area (i, j)) / 100.e3))) - + ! ----------------------------------------------------------------------- !> - calculate partial cloudiness by pdf; !! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the !! binary cloud scheme; qa = 0.5 if qstar (i) == qpz ! ----------------------------------------------------------------------- - + rh = qpz (i) / qstar (i) - + ! ----------------------------------------------------------------------- ! icloud_f = 0: bug - fixed ! icloud_f = 1: old fvgfs gfdl) mp implementation ! icloud_f = 2: binary cloud scheme (0 / 1) ! ----------------------------------------------------------------------- - + if (rh > 0.75 .and. qpz (i) > 1.e-8) then dq = hvar (i) * qpz (i) q_plus = qpz (i) + dq @@ -1133,19 +1184,19 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, else qa (i, j) = 0. endif - + enddo - + endif - + enddo ! end j loop - + end subroutine fv_sat_adj_work !> @} ! ======================================================================= !>\ingroup fast_sat_adj -!>\brief the function 'wqs1' computes the +!>\brief the function 'wqs1' computes the !! saturated specific humidity for table ii. ! ======================================================================= real(kind=kind_dyn) function wqs1 (ta, den) @@ -1172,7 +1223,7 @@ end function wqs1 ! ======================================================================= !>\ingroup fast_sat_adj -!>\brief the function 'wqs1' computes the saturated specific humidity +!>\brief the function 'wqs1' computes the saturated specific humidity !! for table iii ! ======================================================================= real(kind=kind_dyn) function iqs1 (ta, den) @@ -1199,7 +1250,7 @@ end function iqs1 ! ======================================================================= !>\ingroup fast_sat_adj -!>\brief The function 'wqs2'computes the gradient of saturated specific +!>\brief The function 'wqs2'computes the gradient of saturated specific !! humidity for table ii ! ======================================================================= real(kind=kind_dyn) function wqs2 (ta, den, dqdt) @@ -1231,7 +1282,7 @@ end function wqs2 ! ======================================================================= !>\ingroup fast_sat_adj -!>\brief The function wqs2_vect computes the gradient of saturated +!>\brief The function wqs2_vect computes the gradient of saturated !! specific humidity for table ii. !! It is the same as "wqs2", but written as vector function. ! ======================================================================= @@ -1269,7 +1320,7 @@ end subroutine wqs2_vect ! ======================================================================= !>\ingroup fast_sat_adj -!>\brief The function 'iqs2' computes the gradient of saturated specific +!>\brief The function 'iqs2' computes the gradient of saturated specific !! humidity for table iii. ! ======================================================================= real(kind=kind_dyn) function iqs2 (ta, den, dqdt) @@ -1306,22 +1357,22 @@ end function iqs2 ! ======================================================================= subroutine qs_table (n) - + implicit none - + integer, intent (in) :: n real (kind_grid) :: delt = 0.1 real (kind_grid) :: tmin, tem, esh20 real (kind_grid) :: wice, wh2o, fac0, fac1, fac2 real (kind_grid) :: esupc (200) integer :: i - + tmin = tice - 160. - + ! ----------------------------------------------------------------------- ! compute es over ice between - 160 deg c and 0 deg c. ! ----------------------------------------------------------------------- - + do i = 1, 1600 tem = tmin + delt * real (i - 1) fac0 = (tem - tice) / (tem * tice) @@ -1329,11 +1380,11 @@ subroutine qs_table (n) fac2 = (d2ice * log (tem / tice) + fac1) / rvgas table (i) = e00 * exp (fac2) enddo - + ! ----------------------------------------------------------------------- ! compute es over water between - 20 deg c and 102 deg c. ! ----------------------------------------------------------------------- - + do i = 1, 1221 tem = 253.16 + delt * real (i - 1) fac0 = (tem - tice) / (tem * tice) @@ -1346,18 +1397,18 @@ subroutine qs_table (n) table (i + 1400) = esh20 endif enddo - + ! ----------------------------------------------------------------------- ! derive blended es over ice and supercooled water between - 20 deg c and 0 deg c ! ----------------------------------------------------------------------- - + do i = 1, 200 tem = 253.16 + delt * real (i - 1) wice = 0.05 * (tice - tem) wh2o = 0.05 * (tem - 253.16) table (i + 1400) = wice * table (i + 1400) + wh2o * esupc (i) enddo - + end subroutine qs_table ! ======================================================================= @@ -1367,20 +1418,20 @@ end subroutine qs_table ! ======================================================================= subroutine qs_tablew (n) - + implicit none - + integer, intent (in) :: n real (kind_grid) :: delt = 0.1 real (kind_grid) :: tmin, tem, fac0, fac1, fac2 integer :: i - + tmin = tice - 160. - + ! ----------------------------------------------------------------------- ! compute es over water ! ----------------------------------------------------------------------- - + do i = 1, n tem = tmin + delt * real (i - 1) fac0 = (tem - tice) / (tem * tice) @@ -1388,7 +1439,7 @@ subroutine qs_tablew (n) fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas tablew (i) = e00 * exp (fac2) enddo - + end subroutine qs_tablew ! ======================================================================= @@ -1398,16 +1449,16 @@ end subroutine qs_tablew ! ======================================================================= subroutine qs_table2 (n) - + implicit none - + integer, intent (in) :: n real (kind_grid) :: delt = 0.1 real (kind_grid) :: tmin, tem0, tem1, fac0, fac1, fac2 integer :: i, i0, i1 - + tmin = tice - 160. - + do i = 1, n tem0 = tmin + delt * real (i - 1) fac0 = (tem0 - tice) / (tem0 * tice) @@ -1426,18 +1477,18 @@ subroutine qs_table2 (n) endif table2 (i) = e00 * exp (fac2) enddo - + ! ----------------------------------------------------------------------- ! smoother around 0 deg c ! ----------------------------------------------------------------------- - + i0 = 1600 i1 = 1601 tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) table2 (i0) = tem0 table2 (i1) = tem1 - + end subroutine qs_table2 end module fv_sat_adj diff --git a/physics/MP/GFDL/fv_sat_adj.meta b/physics/MP/GFDL/fv_sat_adj.meta index 98d803583..396e2a222 100644 --- a/physics/MP/GFDL/fv_sat_adj.meta +++ b/physics/MP/GFDL/fv_sat_adj.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = fv_sat_adj type = scheme - dependencies = ../../hooks/machine.F,../../hooks/physcons.F90 + dependencies = ../../hooks/machine.F dependencies = ../multi_gases.F90,../module_mp_radar.F90 dependencies = module_gfdlmp_param.F90 @@ -67,6 +67,46 @@ dimensions = () type = integer intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -480,6 +520,54 @@ dimensions = () type = integer intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.F90 b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.F90 index eae68d4f3..ccde8942a 100644 --- a/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.F90 +++ b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.F90 @@ -3,10 +3,11 @@ !! \cite chen_and_lin_2013 ). module gfdl_cloud_microphys_v3 + use machine, only: kind_phys use gfdl_cloud_microphys_v3_mod, only: gfdl_cloud_microphys_v3_mod_init, & gfdl_cloud_microphys_v3_mod_driver, & gfdl_cloud_microphys_v3_mod_end, & - rad_ref, cld_eff_rad + rad_ref, cld_eff_rad implicit none @@ -31,7 +32,16 @@ module gfdl_cloud_microphys_v3 subroutine gfdl_cloud_microphys_v3_init (me, master, nlunit, input_nml_file, logunit, & fn_nml, imp_physics, imp_physics_gfdl, do_shoc, & - hydrostatic, errmsg, errflg) + hydrostatic, con_g, con_1ovg, & + con_pi, con_boltz, con_sbc, con_rd, & + con_rv, con_fvirt, con_runiver, con_cp, & + con_csol, con_hvap, con_hfus, con_rhoair_IFS, & + con_rhosnow, con_one, con_amd, con_amw, & + con_visd, con_visk, con_vdifu, con_tcond, & + con_cdg, con_cdh, con_rhocw, con_rhoci, & + con_rhocr, con_rhocg, con_rhoch, con_qcmin, & + con_qfmin, errmsg, errflg) + implicit none @@ -45,6 +55,37 @@ subroutine gfdl_cloud_microphys_v3_init (me, master, nlunit, input_nml_file, log integer, intent( in) :: imp_physics_gfdl logical, intent( in) :: do_shoc logical, intent( in) :: hydrostatic + real(kind_phys), intent(in) :: con_g + real(kind_phys), intent(in) :: con_1ovg + real(kind_phys), intent(in) :: con_pi + real(kind_phys), intent(in) :: con_boltz + real(kind_phys), intent(in) :: con_sbc + real(kind_phys), intent(in) :: con_rd + real(kind_phys), intent(in) :: con_rv + real(kind_phys), intent(in) :: con_fvirt + real(kind_phys), intent(in) :: con_runiver + real(kind_phys), intent(in) :: con_cp + real(kind_phys), intent(in) :: con_csol + real(kind_phys), intent(in) :: con_hvap + real(kind_phys), intent(in) :: con_hfus + real(kind_phys), intent(in) :: con_rhoair_IFS + real(kind_phys), intent(in) :: con_rhosnow + real(kind_phys), intent(in) :: con_one + real(kind_phys), intent(in) :: con_amd + real(kind_phys), intent(in) :: con_amw + real(kind_phys), intent(in) :: con_visd + real(kind_phys), intent(in) :: con_visk + real(kind_phys), intent(in) :: con_vdifu + real(kind_phys), intent(in) :: con_tcond + real(kind_phys), intent(in) :: con_cdg + real(kind_phys), intent(in) :: con_cdh + real(kind_phys), intent(in) :: con_rhocw + real(kind_phys), intent(in) :: con_rhoci + real(kind_phys), intent(in) :: con_rhocr + real(kind_phys), intent(in) :: con_rhocg + real(kind_phys), intent(in) :: con_rhoch + real(kind_phys), intent(in) :: con_qcmin + real(kind_phys), intent(in) :: con_qfmin character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -66,7 +107,16 @@ subroutine gfdl_cloud_microphys_v3_init (me, master, nlunit, input_nml_file, log return endif - call gfdl_cloud_microphys_v3_mod_init(me, master, nlunit, input_nml_file, logunit, fn_nml, hydrostatic, errmsg, errflg) + call gfdl_cloud_microphys_v3_mod_init(me, master, nlunit, input_nml_file, logunit, & + fn_nml, hydrostatic, con_g, con_1ovg, & + con_pi, con_boltz, con_sbc, con_rd, & + con_rv, con_fvirt, con_runiver, con_cp, & + con_csol, con_hvap, con_hfus, con_rhoair_IFS, & + con_rhosnow, con_one, con_amd, con_amw, & + con_visd, con_visk, con_vdifu, con_tcond, & + con_cdg, con_cdh, con_rhocw, con_rhoci, & + con_rhocr, con_rhocg, con_rhoch, con_qcmin, & + con_qfmin, errmsg, errflg) is_initialized = .true. @@ -132,7 +182,7 @@ subroutine gfdl_cloud_microphys_v3_run(fast_mp_consv, integer, intent(in ) :: levs, im real(kind=kind_phys), intent(in ) :: con_g, con_fvirt, con_rd, con_eps, rainmin real(kind=kind_phys), intent(in ) :: con_one, con_p001, con_secinday - real(kind=kind_phys), intent(in ), dimension(:) :: garea, slmsk, snowd, oro + real(kind=kind_phys), intent(in ), dimension(:) :: garea, slmsk, snowd, oro real(kind=kind_phys), intent(inout), dimension(:,:) :: gq0, gq0_ntcw, gq0_ntrw, gq0_ntiw, & gq0_ntsw, gq0_ntgl, gq0_ntclamt real(kind_phys), intent(in ), dimension(:,:,:) :: aerfld @@ -154,7 +204,7 @@ subroutine gfdl_cloud_microphys_v3_run(fast_mp_consv, logical, intent (in) :: lradar real(kind=kind_phys), intent(inout), dimension(:,:) :: refl_10cm - logical, intent (in) :: reset, effr_in + logical, intent (in) :: reset, effr_in real(kind=kind_phys), intent(inout), dimension(:,:), optional :: rew, rei, rer, res, reg logical, intent (in) :: cplchm ! ice and liquid water 3d precipitation fluxes - only allocated if cplchm is .true. @@ -166,10 +216,10 @@ subroutine gfdl_cloud_microphys_v3_run(fast_mp_consv, ! local variables integer :: iis, iie, jjs, jje, kks, kke, kbot, ktop integer :: i, k, kk - real(kind=kind_phys), dimension(1:im,1:levs) :: delp, dz, uin, vin, pt, qv1, ql1, qi1, qr1, qs1, qg1, & + real(kind=kind_phys), dimension(1:im,1:levs) :: delp, dz, uin, vin, pt, qv1, ql1, qi1, qr1, qs1, qg1, & qa1, qnl, qni, pt_dt, qa_dt, u_dt, v_dt, w, qv_dt, ql_dt,& qr_dt, qi_dt, qs_dt, qg_dt, p123, refl - real(kind=kind_phys), dimension(1:im,1:levs) :: q_con, cappa !for inline MP option + real(kind=kind_phys), dimension(1:im,1:levs) :: q_con, cappa !for inline MP option real(kind=kind_phys), dimension(1:im,1,1:levs) :: pfils, pflls real(kind=kind_phys), dimension(1:im,1,1:levs) :: adj_vmr, te real(kind=kind_phys), dimension(1:im,1:levs) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg @@ -210,16 +260,16 @@ subroutine gfdl_cloud_microphys_v3_run(fast_mp_consv, pt_dt(i,k) = 0.0 u_dt(i,k) = 0.0 v_dt(i,k) = 0.0 - qnl(i,k) = aerfld(i,kk,11) ! sulfate + qnl(i,k) = aerfld(i,kk,11) ! sulfate pfils(i,1,k) = 0.0 pflls(i,1,k) = 0.0 - prefluxw(i,k) =0.0 - prefluxi(i,k) =0.0 - prefluxr(i,k) =0.0 - prefluxs(i,k) =0.0 - prefluxg(i,k) =0.0 + prefluxw(i,k) =0.0 + prefluxi(i,k) =0.0 + prefluxr(i,k) =0.0 + prefluxs(i,k) =0.0 + prefluxg(i,k) =0.0 - ! flip vertical (k) coordinate top =1 + ! flip vertical (k) coordinate top =1 qv1(i,k) = gq0(i,kk) ql1(i,k) = gq0_ntcw(i,kk) qr1(i,k) = gq0_ntrw(i,kk) @@ -236,8 +286,8 @@ subroutine gfdl_cloud_microphys_v3_run(fast_mp_consv, dz(i,k) = (phii(i,kk)-phii(i,kk+1))*onebg p123(i,k) = prsl(i,kk) qni(i,k) = 10. - q_con(i,k) = 0.0 - cappa(i,k) = 0.0 + q_con(i,k) = 0.0 + cappa(i,k) = 0.0 enddo enddo @@ -247,7 +297,7 @@ subroutine gfdl_cloud_microphys_v3_run(fast_mp_consv, ice0 = 0 snow0 = 0 graupel0 = 0 - + ! Call MP driver last_step = .false. do_inline_mp = .false. @@ -343,19 +393,19 @@ subroutine gfdl_cloud_microphys_v3_run(fast_mp_consv, res(1:im,1:levs), reg(1:im,1:levs),snowd(1:im)) endif - if(lradar) then + if(lradar) then call rad_ref (1, im, 1, 1, qv1(1:im,1:levs), qr1(1:im,1:levs), & - qs1(1:im,1:levs),qg1(1:im,1:levs),pt(1:im,1:levs), & - delp(1:im,1:levs), dz(1:im,1:levs), refl(1:im,1:levs), levs, hydrostatic, & + qs1(1:im,1:levs),qg1(1:im,1:levs),pt(1:im,1:levs), & + delp(1:im,1:levs), dz(1:im,1:levs), refl(1:im,1:levs), levs, hydrostatic, & do_inline_mp, 1) do k=1,levs kk = levs-k+1 do i=1,im refl_10cm(i,k) = max(-35.,refl(i,kk)) - enddo - enddo - endif + enddo + enddo + endif end subroutine gfdl_cloud_microphys_v3_run diff --git a/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.meta b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.meta index 3b022bf25..380f8524a 100644 --- a/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.meta +++ b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.meta @@ -2,7 +2,6 @@ name = gfdl_cloud_microphys_v3 type = scheme dependencies = ../../../hooks/machine.F - dependencies = ../../../hooks/physcons.F90 dependencies = gfdl_cloud_microphys_v3_mod.F90 ######################################################################## @@ -81,6 +80,254 @@ dimensions = () type = logical intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_1ovg] + standard_name = one_divided_by_the_gravitational_acceleration + long_name = inverse of gravitational acceleration + units = s2 m-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_boltz] + standard_name = boltzmann_constant + long_name = Boltzmann constant + units = J K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_sbc] + standard_name = stefan_boltzmann_constant + long_name = Steffan-Boltzmann constant + units = W m-2 K-4 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_runiver] + standard_name = molar_gas_constant + long_name = universal ideal molar gas constant + units = J K-1 mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + intent = in + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys +[con_csol] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rhoair_IFS] + standard_name = density_of_air_IFS + long_name = density of air IFS + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rhosnow] + standard_name = density_of_snow + long_name = density of snow + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_one] + standard_name = constant_one + long_name = mathematical constant of one + units = 1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amd] + standard_name = molecular_weight_of_dry_air + long_name = molecular weight of dry air + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amw] + standard_name = molecular_weight_of_water_vapor + long_name = molecular weight of water vapor + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_visd] + standard_name = dynamic_viscosity_of_air + long_name = dynamic viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) + units = kg m-1 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_visk] + standard_name = kinematic_viscosity_of_air + long_name = kinematic viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_vdifu] + standard_name = diffusivity_of_water_vapor_in_air + long_name = diffusivity of water vapor in air at 0 deg C and 1000 hPa (Mason, 1971) + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_tcond] + standard_name = thermal_conductivity_of_air + long_name = thermal conductivity of air at 0 deg C and 1000 hPa (Mason, 1971) + units = W m-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cdg] + standard_name = drag_coefficient_of_graupel + long_name = drag coefficient of graupel (Locatelli and Hobbs, 1974) + units = 1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cdh] + standard_name = drag_coefficient_of_hail + long_name = drag coefficient of hail (Heymsfield and Wright, 2014) + units = 1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rhocw] + standard_name = density_of_cloud_water + long_name = density of cloud water + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rhoci] + standard_name = density_of_cloud_ice + long_name = density of cloud ice + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rhocr] + standard_name = density_of_rain + long_name = density of rain (Lin et al., 1983) + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rhocg] + standard_name = density_of_graupel + long_name = density of graupel (Rutledge and Hobbs, 1984) + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rhoch] + standard_name = density_of_hail + long_name = density of hail (Lin et al., 1983) + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_qcmin] + standard_name = minimum_mass_mixing_ratio_of_cloud_condensate + long_name = minimum value for cloud condensates + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_qfmin] + standard_name = minimum_mass_mixing_ratio_for_sedimentation + long_name = minimum value for sedimentation + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3_mod.F90 b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3_mod.F90 index b15f2efd9..1833412b7 100644 --- a/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3_mod.F90 +++ b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3_mod.F90 @@ -59,31 +59,6 @@ module gfdl_cloud_microphys_v3_mod ss_fac, gs_fac, rh_fac_evap, rh_fac_cond, snow_grauple_combine, do_psd_water_num, & do_psd_ice_num, vdiffflag, rewfac, reifac, cp_heating, nconds, do_evap_timescale, & delay_cond_evap, do_subgrid_proc, fast_fr_mlt, fast_dep_sub, qi_gen, tice - use physcons, only: grav => con_g, & - rgrav => con_1ovg, & - pi => con_pi, & - boltzmann => con_boltz, & - avogadro => con_sbc, & - rdgas => con_rd, & - rvgas => con_rv, & - zvir => con_fvirt, & - runiver => con_runiver, & - cp_air => con_cp, & - c_ice => con_csol, & - !c_liq => con_cliq, & - !e00 => con_psat, & - hlv => con_hvap, & - hlf => con_hfus, & - rho0 => rhoair_IFS, & - rhos => rhosnow, & - one_r8 => con_one, & - con_amd, con_amw, visd, & - visk, vdifu, tcond, cdg, & - cdh, rhow => rhocw, & - rhoi => rhoci, & - rhor => rhocr, & - rhog => rhocg, & - rhoh => rhoch, qcmin, qfmin private ! ----------------------------------------------------------------------- @@ -137,6 +112,39 @@ module gfdl_cloud_microphys_v3_mod logical :: tables_are_initialized = .false. ! initialize satuation tables + real(kind_phys) :: grav = 1.0E30 + real(kind_phys) :: rgrav = 1.0E30 + real(kind_phys) :: pi = 1.0E30 + real(kind_phys) :: boltzmann = 1.0E30 + real(kind_phys) :: avogadro = 1.0E30 + real(kind_phys) :: rdgas = 1.0E30 + real(kind_phys) :: rvgas = 1.0E30 + real(kind_phys) :: zvir = 1.0E30 + real(kind_phys) :: runiver = 1.0E30 + real(kind_phys) :: cp_air = 1.0E30 + real(kind_phys) :: c_ice = 1.0E30 + real(kind_phys) :: hlv = 1.0E30 + real(kind_phys) :: hlf = 1.0E30 + real(kind_phys) :: rho0 = 1.0E30 + real(kind_phys) :: rhos = 1.0E30 + real(kind_phys) :: one_r8 = 1.0E30 + real(kind_phys) :: con_amd = 1.0E30 + real(kind_phys) :: con_amw = 1.0E30 + real(kind_phys) :: visd = 1.0E30 + real(kind_phys) :: visk = 1.0E30 + real(kind_phys) :: vdifu = 1.0E30 + real(kind_phys) :: tcond = 1.0E30 + real(kind_phys) :: cdg = 1.0E30 + real(kind_phys) :: cdh = 1.0E30 + real(kind_phys) :: rhow = 1.0E30 + real(kind_phys) :: rhoi = 1.0E30 + real(kind_phys) :: rhor = 1.0E30 + real(kind_phys) :: rhog = 1.0E30 + real(kind_phys) :: rhoh = 1.0E30 + real(kind_phys) :: qcmin = 1.0E30 + real(kind_phys) :: qfmin = 1.0E30 + + ! ----------------------------------------------------------------------- ! Physical constants that differ from physcons ! ----------------------------------------------------------------------- @@ -146,14 +154,14 @@ module gfdl_cloud_microphys_v3_mod ! ----------------------------------------------------------------------- ! derived physics constants ! ----------------------------------------------------------------------- - real(kind_phys), parameter :: mmd = con_amd*1e-3 ! (g/mol) -> (kg/mol) - real(kind_phys), parameter :: mmv = con_amw*1e-3 ! (g/mol) -> (kg/mol) - real(kind_phys), parameter :: cv_air = cp_air - rdgas - real(kind_phys), parameter :: cp_vap = 4.0 * rvgas - real(kind_phys), parameter :: cv_vap = 3.0 * rvgas - real(kind_phys), parameter :: dc_vap = cp_vap - c_liq - real(kind_phys), parameter :: dc_ice = c_liq - c_ice - real(kind_phys), parameter :: d2_ice = cp_vap - c_ice + real(kind_phys) :: mmd = 1.0E30 + real(kind_phys) :: mmv = 1.0E30 + real(kind_phys) :: cv_air = 1.0E30 + real(kind_phys) :: cp_vap = 1.0E30 + real(kind_phys) :: cv_vap = 1.0E30 + real(kind_phys) :: dc_vap = 1.0E30 + real(kind_phys) :: dc_ice = 1.0E30 + real(kind_phys) :: d2_ice = 1.0E30 ! ----------------------------------------------------------------------- ! predefined parameters @@ -207,7 +215,15 @@ module gfdl_cloud_microphys_v3_mod ! ======================================================================= subroutine gfdl_cloud_microphys_v3_mod_init (me, master, nlunit, input_nml_file, logunit, & - fn_nml, hydrostatic, errmsg, errflg) + fn_nml, hydrostatic, con_g, con_1ovg, & + con_pi, con_boltz, con_sbc, con_rd, & + con_rv, con_fvirt, con_runiver, con_cp, & + con_csol, con_hvap, con_hfus, con_rhoair_IFS, & + con_rhosnow, con_one, con_amd_in, con_amw_in, & + con_visd, con_visk, con_vdifu, con_tcond, & + con_cdg, con_cdh, con_rhocw, con_rhoci, & + con_rhocr, con_rhocg, con_rhoch, con_qcmin, & + con_qfmin, errmsg, errflg) implicit none @@ -223,8 +239,39 @@ subroutine gfdl_cloud_microphys_v3_mod_init (me, master, nlunit, input_nml_file, character (len = 64), intent (in) :: fn_nml character (len = *), intent (in) :: input_nml_file (:) logical, intent (in) :: hydrostatic - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(in) :: con_g + real(kind_phys), intent(in) :: con_1ovg + real(kind_phys), intent(in) :: con_pi + real(kind_phys), intent(in) :: con_boltz + real(kind_phys), intent(in) :: con_sbc + real(kind_phys), intent(in) :: con_rd + real(kind_phys), intent(in) :: con_rv + real(kind_phys), intent(in) :: con_fvirt + real(kind_phys), intent(in) :: con_runiver + real(kind_phys), intent(in) :: con_cp + real(kind_phys), intent(in) :: con_csol + real(kind_phys), intent(in) :: con_hvap + real(kind_phys), intent(in) :: con_hfus + real(kind_phys), intent(in) :: con_rhoair_IFS + real(kind_phys), intent(in) :: con_rhosnow + real(kind_phys), intent(in) :: con_one + real(kind_phys), intent(in) :: con_amd_in + real(kind_phys), intent(in) :: con_amw_in + real(kind_phys), intent(in) :: con_visd + real(kind_phys), intent(in) :: con_visk + real(kind_phys), intent(in) :: con_vdifu + real(kind_phys), intent(in) :: con_tcond + real(kind_phys), intent(in) :: con_cdg + real(kind_phys), intent(in) :: con_cdh + real(kind_phys), intent(in) :: con_rhocw + real(kind_phys), intent(in) :: con_rhoci + real(kind_phys), intent(in) :: con_rhocr + real(kind_phys), intent(in) :: con_rhocg + real(kind_phys), intent(in) :: con_rhoch + real(kind_phys), intent(in) :: con_qcmin + real(kind_phys), intent(in) :: con_qfmin + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! ----------------------------------------------------------------------- @@ -238,6 +285,48 @@ subroutine gfdl_cloud_microphys_v3_mod_init (me, master, nlunit, input_nml_file, errflg = 0 errmsg = '' + ! Initialize CCPP module level constants + grav = con_g + rgrav = con_1ovg + pi = con_pi + boltzmann = con_boltz + avogadro = con_sbc + rdgas = con_rd + rvgas = con_rv + zvir = con_fvirt + runiver = con_runiver + cp_air = con_cp + c_ice = con_csol + hlv = con_hvap + hlf = con_hfus + rho0 = con_rhoair_IFS + rhos = con_rhosnow + one_r8 = con_one + rhow = con_rhocw + rhoi = con_rhoci + rhor = con_rhocr + rhog = con_rhocg + rhoh = con_rhoch + con_amd = con_amd_in + con_amw = con_amw_in + visd = con_visd + visk = con_visk + vdifu = con_vdifu + tcond = con_tcond + cdg = con_cdg + cdh = con_cdh + qcmin = con_qcmin + qfmin = con_qfmin + + mmd = con_amd*1e-3 ! (g/mol) -> (kg/mol) + mmv = con_amw*1e-3 ! (g/mol) -> (kg/mol) + cv_air = cp_air - rdgas + cp_vap = 4.0 * rvgas + cv_vap = 3.0 * rvgas + dc_vap = cp_vap - c_liq + dc_ice = c_liq - c_ice + d2_ice = cp_vap - c_ice + ! ----------------------------------------------------------------------- ! Read namelist ! ----------------------------------------------------------------------- @@ -1243,7 +1332,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & qs (i, k) = qsz (k) qg (i, k) = qgz (k) qa (i, k) = qaz (k) - + ! ----------------------------------------------------------------------- ! calculate some more variables needed outside ! ----------------------------------------------------------------------- @@ -1612,10 +1701,10 @@ subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, ! ----------------------------------------------------------------------- ! temperature sentive high vertical resolution processes ! ----------------------------------------------------------------------- - + call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, & qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step) - + condensation = condensation + cond * convt deposition = deposition + dep * convt evaporation = evaporation + reevap * convt @@ -5778,7 +5867,7 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, (8.0 + (14.0 - 8.0) * min (1.0, max (0.0, - tc / 30.0))) * & (1.0 - abs (mask - 1.0)) rew (i, k) = rew (i, k) + (14.0 - rew (i, k)) * & - min (1.0, max (0.0, snowd (i) / 1000.0)) ! snowd is in mm + min (1.0, max (0.0, snowd (i) / 1000.0)) ! snowd is in mm rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) else qcw (i, k) = 0.0 @@ -6052,7 +6141,7 @@ subroutine rad_ref (is, ie, js, je, qv, qr, qs, qg, pt, delp, & real(kind_phys), intent (in), dimension (is:ie, js:je, npz) :: pt, delp - real(kind_phys), intent (in), dimension (is:ie, js:je, npz) :: qv, qr, qs, qg + real(kind_phys), intent (in), dimension (is:ie, js:je, npz) :: qv, qr, qs, qg !real(kind_phys), intent (in), dimension (is:ie, npz + 1, js:je) :: peln diff --git a/physics/MP/Morrison_Gettelman/aer_cloud.F b/physics/MP/Morrison_Gettelman/aer_cloud.F index 36bdf47ac..6540d0232 100644 --- a/physics/MP/Morrison_Gettelman/aer_cloud.F +++ b/physics/MP/Morrison_Gettelman/aer_cloud.F @@ -2,12 +2,12 @@ !! This file contains the models of Nenes and Seinfeld (2003) \cite Nenes_2003 , !! Fountoukis and Nenes (2005) \cite Fountoukis_2005 and Barahona and !! Nenes (2008, 2009) \cite Barahona_2008 \cite Barahona_2009 . -!>\author Donifan Barahona donifan.o.barahona@nasa.gov +!>\author Donifan Barahona donifan.o.barahona@nasa.gov !>\ingroup mg2mg3 !>\defgroup aer_cloud_mod Morrison-Gettelman MP aer_cloud Module -!! according to the models of Nenes & Seinfeld (2003) \cite Nenes_2003, -!! Fountoukis and Nenes (2005) \cite Fountoukis_2005 +!! according to the models of Nenes & Seinfeld (2003) \cite Nenes_2003, +!! Fountoukis and Nenes (2005) \cite Fountoukis_2005 !! and Barahona and Nenes (2008, 2009) \cite Barahona_2008 \cite Barahona_2009 . !! *** Code Developer: Donifan Barahona donifan.o.barahona@nasa.gov MODULE aer_cloud @@ -16,7 +16,6 @@ MODULE aer_cloud use MAPL_ConstantsMod, r8 => MAPL_R8 #endif #ifdef NEMS_GSM - use physcons, only : MAPL_PI => con_pi use machine, only : r8 => kind_phys #endif @@ -94,29 +93,33 @@ MODULE aer_cloud &, grav_par=9.81d0, rgas_par=8.31d0 &, accom_par=1.0d0, eps_par=1d-6 &, zero_par=1.0e-20, great_par=1d20 - &, pi_par=mapl_pi, sq2pi_par=sqrt(pi_par) ! &, pi_par=3.1415927d0, sq2pi_par=sqrt(pi_par) &, sq2_par=1.41421356237d0 ! &, wmw_ice=018d0, amw_ice=0.029d0 &, rgas_ice=8.314d0, grav_ice=9.81d0 - &, cpa_ice=1005.1d0, pi_ice=pi_par + &, cpa_ice=1005.1d0 &, depcoef_ice=0.1d0, thaccom_ice=0.7d0 ! &, To_ice=272.15d0, Tmin_ice=185.d0 &, Pmin_ice=100.0d0, Thom=236.0d0 &, rv_ice=rgas_ice/wmw_ice - + real :: pi_par=1.0E30_r8, sq2pi_par=1.0E30_r8 + &, pi_ice=1.0E30_r8 CONTAINS !>\ingroup aer_cloud_mod !! This subroutine calculates - subroutine aer_cloud_init() - + subroutine aer_cloud_init(mapl_pi) + real(kind=r8), intent(in) :: mapl_pi real*8 :: daux, sigaux integer ::ix + pi_par=mapl_pi + sq2pi_par=sqrt(pi_par) + pi_ice=pi_par + call AerConversion_base acorr_dust = 2.7e7 @@ -187,7 +190,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, & & cdncr8, smaxliqr8, incr8, smaxicer8, nheticer8, INimmr8, & & dINimmr8, Ncdepr8, Ncdhfr8, sc_icer8, fdust_immr8, fdust_depr8, & & fdust_dhfr8, nlimr8, use_average_v, CCN_param, IN_param, fd_dust,& - & fd_soot, pfrz_inc_r8, sigma_nuc, rhi_cell,nccn) + & fd_soot, pfrz_inc_r8, sigma_nuc, rhi_cell,nccn) ! & fd_soot, pfrz_inc_r8, sigma_nuc, rhi_cell,nccn, lprnt) diff --git a/physics/MP/Morrison_Gettelman/cldmacro.F b/physics/MP/Morrison_Gettelman/cldmacro.F index a2d5aeb70..5e0ff5fd7 100644 --- a/physics/MP/Morrison_Gettelman/cldmacro.F +++ b/physics/MP/Morrison_Gettelman/cldmacro.F @@ -20,14 +20,6 @@ module cldmacro & MAPL_AIRMW, MAPL_RVAP , MAPL_PI , MAPL_R8 , MAPL_R4 use MAPL_BaseMod, only: MAPL_UNDEF #endif -#ifdef NEMS_GSM - use physcons, MAPL_TICE => con_t0c, MAPL_GRAV => con_g, - & MAPL_CP => con_cp, MAPL_ALHL => con_hvap, - & MAPL_ALHF => con_hfus, MAPL_PI => con_pi, - & MAPL_RGAS => con_rd, MAPL_RVAP => con_rv -#endif - - implicit none @@ -39,6 +31,7 @@ module cldmacro public meltfrz_inst public fix_up_clouds_2M PUBLIC CLOUD_PTR_STUBS + public cldmacro_init !! Some parameters set by PHYSPARAMS @@ -89,15 +82,24 @@ module cldmacro real :: turnrhcrit_upper real :: MIN_RI, MAX_RI, MIN_RL, MAX_RL, RI_ANV - - real, parameter :: T_ICE_MAX = MAPL_TICE +#ifdef NEMS_GSM + real :: MAPL_TICE = 1.0E30 + real :: MAPL_GRAV = 1.0E30 + real :: MAPL_CP = 1.0E30 + real :: MAPL_ALHL = 1.0E30 + real :: MAPL_ALHF = 1.0E30 + real :: MAPL_PI = 1.0E30 + real :: MAPL_RGAS = 1.0E30 + real :: MAPL_RVAP = 1.0E30 + real :: T_ICE_MAX = 1.0E30 + real :: MAPL_ALHS = 1.0E30 + real :: alhlbcp = 1.0E30 + real :: alhfbcp = 1.0E30 + real :: alhsbcp = 1.0E30 +#endif real, parameter :: RHO_W = 1.0e3 real, parameter :: MIN_CLD_FRAC = 1.0e-8 - real, parameter :: MAPL_ALHS = MAPL_ALHL+MAPL_ALHF - real, parameter :: alhlbcp = MAPL_ALHL/MAPL_CP - &, alhfbcp = MAPL_ALHF/MAPL_CP - &, alhsbcp = alhlbcp+alhfbcp ! real, parameter :: PI_0 = 4.*atan(1.) @@ -107,6 +109,28 @@ module cldmacro contains +#ifdef NEMS_GSM + subroutine cldmacro_init(con_t0c, con_g, con_cp, con_hvap & + &, con_hfus, con_pi, con_rd, con_rv) + real, intent(in) :: con_t0c, con_g, con_cp, con_hvap + real, intent(in) :: con_hfus, con_pi, con_rd, con_rv + MAPL_TICE = con_t0c + MAPL_GRAV = con_g + MAPL_CP = con_cp + MAPL_ALHL = con_hvap + MAPL_ALHF = con_hfus + MAPL_PI = con_pi + MAPL_RGAS = con_rd + MAPL_RVAP = con_rv + + T_ICE_MAX = MAPL_TICE + MAPL_ALHS = MAPL_ALHL+MAPL_ALHF + alhlbcp = MAPL_ALHL/MAPL_CP + alhfbcp = MAPL_ALHF/MAPL_CP + alhsbcp = alhlbcp+alhfbcp + end subroutine cldmacro_init +#endif + !>\ingroup cldmacro_mod !! This subroutine is the cloud macrophysics scheme in MG micriphysics. subroutine macro_cloud(IRUN, LM, DT, alf_fac, PP_dev, PPE_dev & @@ -195,7 +219,7 @@ subroutine macro_cloud(IRUN, LM, DT, alf_fac, PP_dev, PPE_dev & ! real :: MASS, iMASS, TOTFRC, QRN_CU_1D, QSN_CU, QRN_ALL, QSN_ALL ! &, QTMP1, QTMP2, QTMP3, QTOT, TEMP, RHCRIT, AA3, BB3, ALPHA ! &, VFALL, VFALLRN, VFALLSN, TOT_PREC_UPD, AREA_UPD_PRC -! &, AREA_UPD_PRC_tolayer +! &, AREA_UPD_PRC_tolayer ! &, PRN_CU_above, PSN_CU_above ! &, AREA_UPD_PRC_tolayer, U_above,U_below, V_above,V_below ! &, DZET_above,DZET_below, PRN_CU_above, PSN_CU_above @@ -371,7 +395,7 @@ subroutine macro_cloud(IRUN, LM, DT, alf_fac, PP_dev, PPE_dev & NCPL_dev(I,K) = max(NCPL_dev(I,K)+CNV_NDROP_dev(I,K)*tx1,0.0) NCPI_dev(I,K) = max(NCPI_dev(I,K)+CNV_NICE_dev(I,K)*tx1,0.0) - + ! TEND = RMFDTR_dev(I,K)*iMASS * SCLMFDFR ! ANVFRC_dev(I,K) = min(ANVFRC_dev(I,K) + TEND*DT, 1.0) @@ -470,7 +494,7 @@ subroutine macro_cloud(IRUN, LM, DT, alf_fac, PP_dev, PPE_dev & ! QTMP1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) ! QTMP2 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) ! QTOT = QTMP1 + QTMP2 - + ! call PRECIP3 (K, LM, DT, FRLAND_dev(I), RHCRIT, QRN_CU_1D, ! & QSN_CU, QTMP1, QTMP2, TEMP, Q_dev(I,K), mass, ! & imass, PP_dev(I,K), DZET_dev(I,K), @@ -733,8 +757,8 @@ subroutine update_cld( irun, lm, DT, ALPHA, qc_min, & QC = QCl(i,k) + QCi(i,k) QA = QAl(i,k) + QAi(i,k) !Anning do not let empty cloud exist - if(QC <= 0.) CF(i,k) = 0. - if(QA <= 0.) AF(i,k) = 0. + if(QC <= 0.) CF(i,k) = 0. + if(QA <= 0.) AF(i,k) = 0. QCx = QC + QA QT = QCx + QV(i,k) CFALL = AF(i,k) + CF(i,k) @@ -905,7 +929,7 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, qc_min, PL, QV, QCl, QAl& ! TEp = TEo QSn = QSx - TEn = TE + TEn = TE CFn = CFx QVn = QVx QCn = QCx @@ -1034,7 +1058,7 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, qc_min, PL, QV, QCl, QAl& dQAl = 0.0 dQAi = 0.0 -!large scale QCx is not in envi +!large scale QCx is not in envi QCx = QCo - QC ! Anning Cheng prevented unstable here @@ -1047,7 +1071,7 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, qc_min, PL, QV, QCl, QAl& dQCl = QCx - dQCi end if -!Anvil QAx is not in anvil +!Anvil QAx is not in anvil QAx = QAo - QA ! Anning Cheng prevented unstable here ! if(QAx < -1.e-3) QAx = -1.e-3 @@ -1128,7 +1152,7 @@ subroutine pdffrac (flag,qtmean,sigmaqt1,sigmaqt2,qstar,clfrac) if(qtmax < qstar) then clfrac = 0. elseif ( (qtmode <= qstar).and.(qstar < qtmax) ) then - clfrac = (qtmax-qstar)*(qtmax-qstar) / + clfrac = (qtmax-qstar)*(qtmax-qstar) / & ((qtmax-qtmin)*(qtmax-qtmode)) elseif ( (qtmin <= qstar).and.(qstar < qtmode) ) then clfrac = 1. - ((qstar-qtmin)*(qstar-qtmin) @@ -1238,7 +1262,7 @@ subroutine cnvsrc( DT, ICEPARAM, SCLMFDFR, MASS, iMASS, PL, & & TE, QV, DCF, DMF, QLA, QIA, CF, AF, QS, & & NL, NI, CNVFICE, CNVNDROP, CNVNICE) - real, intent(in) :: DT, ICEPARAM, SCLMFDFR, MASS, iMASS, QS & + real, intent(in) :: DT, ICEPARAM, SCLMFDFR, MASS, iMASS, QS & &, DMF,PL, DCF, CF real, intent(inout) :: TE, AF,QV, QLA, QIA, NI, NL & &, CNVFICE, CNVNDROP, CNVNICE @@ -1478,7 +1502,7 @@ subroutine PRECIP3( K,LM , DT , FRLAND , RHCR3 , QPl , QPi , & RAINRAT0 = Ifactor*QPl*MASS/DT SNOWRAT0 = Ifactor*QPi*MASS/DT - + call MARSHPALMQ2(RAINRAT0,PL,DIAMrn,NRAIN,FALLrn,VErn) call MARSHPALMQ2(SNOWRAT0,PL,DIAMsn,NSNOW,FALLsn,VEsn) @@ -1728,7 +1752,7 @@ subroutine MARSHPALMQ2(RAIN,PR,DIAM3,NTOTAL,W,VE) RX = (/ 0. , 5. , 20. , 80. , 320. , 1280., 4*1280., 16*1280. /) - D3X = (/ 0.019, 0.032, 0.043, 0.057, 0.076, 0.102, 0.137 , + D3X = (/ 0.019, 0.032, 0.043, 0.057, 0.076, 0.102, 0.137 , & 0.183 /) RAIN_DAY = RAIN * 3600. *24. @@ -1912,7 +1936,7 @@ subroutine Bergeron_iter ( DTIME , PL , TE , QV , QILS , QICN , & NIX real esl,esi, esn,desdt,weight,hlatsb,hlatvp,hltalt,tterm, & gam,pl100 - + pl100=pl*100 DIFF = 0.0 @@ -2203,7 +2227,7 @@ subroutine cloud_ptr_stubs ( & & SC_ICE, CFICE, CFLIQ, RHICE, RHLIQ, ALPH, RAD_CF, RAD_QL, RAD_QI,& & RAD_QS, RAD_QR, RAD_QV, CLDREFFI, CLDREFFL, NHET_IMM, NHET_DEP, & & NHET_DHF, DUST_IMM, DUST_DEP, DUST_DHF, SCF, SCF_ALL, SIGW_GW, & - & SIGW_CNV, SIGW_TURB, SIGW_RC, RHCmicro, DNHET_IMM, NONDUST_IMM, & + & SIGW_CNV, SIGW_TURB, SIGW_RC, RHCmicro, DNHET_IMM, NONDUST_IMM, & & NONDUST_DEP, BERG, BERGSO, MELT, DNHET_CT, DTDT_macro, QCRES, & & DT_RASP, FRZPP_LS, SNOWMELT_LS, QIRES, AUTICE, PFRZ, DNCNUC, & & DNCHMSPLIT, DNCSUBL, DNCAUTICE, DNCACRIS, DNDCCN, DNDACRLS, & diff --git a/physics/MP/Morrison_Gettelman/cldwat2m_micro.F b/physics/MP/Morrison_Gettelman/cldwat2m_micro.F index a80790eb6..d90bc4138 100644 --- a/physics/MP/Morrison_Gettelman/cldwat2m_micro.F +++ b/physics/MP/Morrison_Gettelman/cldwat2m_micro.F @@ -24,11 +24,6 @@ module cldwat2m_micro #ifdef NEMS_GSM use machine, only : r8 => kind_phys - use physcons, gravit => con_g, rair => con_rd, & - & rh2o => con_rv, epsilon => con_eps, & - & tmelt => con_tice, cpair => con_cp, & - & latvap => con_hvap, latice => con_hfus, & - & pi => con_pi use wv_saturation, only : estblf, hlatv, tmin, hlatf, rgasv, pcf,& & epsqs, ttrice, vqsatd2,cp, & & vqsatd2_single,polysvp,gestbl @@ -68,10 +63,21 @@ module cldwat2m_micro real(r8), parameter :: zero=0.0_r8, one=1.0_r8, two=2.0_r8 & &, three=3.0_r8, four=4.0_r8, five=5.0_r8 & - &, half=0.5_r8, oneb3=one/three & - &, onebcp=one/cpair + &, half=0.5_r8, oneb3=one/three + #ifdef NEMS_GSM ! + real(r8) :: gravit = 1.0E30_r8 + real(r8) :: rair = 1.0E30_r8 + real(r8) :: rh2o = 1.0E30_r8 + real(r8) :: epsilon = 1.0E30_r8 + real(r8) :: tmelt = 1.0E30_r8 + real(r8) :: cpair = 1.0E30_r8 + real(r8) :: latvap = 1.0E30_r8 + real(r8) :: latice = 1.0E30_r8 + real(r8) :: pi = 1.0E30_r8 + real(r8) :: onebcp = 1.0E30_r8 + integer, parameter :: iulog = 6 real(r8), parameter :: rhmini = 0.80_r8 @@ -170,8 +176,13 @@ module cldwat2m_micro &, lammins, lammaxs !> parameters for snow/rain fraction for convective clouds +#ifdef NEMS_GSM + real(r8), private :: tmax_fsnow = 1.0E30_r8 + real(r8), private :: tmin_fsnow = 1.0E30_r8 +#else real(r8), private, parameter :: tmax_fsnow = tmelt &, tmin_fsnow = tmelt-5._r8 +#endif !needed for findsp real(r8), private:: tt0 @@ -187,7 +198,11 @@ module cldwat2m_micro !>\ingroup cldwat2m_micro_mod !! This subroutine initializes constants for MG microphysics. !!\author Andrew Gettelman - subroutine ini_micro(Dcs_, QCVAR_, ts_auto_ice_) + subroutine ini_micro(Dcs_, QCVAR_, ts_auto_ice_ & +#ifdef NEMS_GSM + & , cpair_in & +#endif + & ) !----------------------------------------------------------------------- ! @@ -210,10 +225,13 @@ subroutine ini_micro(Dcs_, QCVAR_, ts_auto_ice_) character(len=16) :: eddy_scheme = ' ' logical :: history_microphysics +#ifdef NEMS_GSM + real(r8), intent(in) :: cpair_in + cpair = cpair_in + onebcp=one/cpair +#endif - - -#ifdef CAM +#ifdef CAM call phys_getopts(eddy_scheme_out = eddy_scheme, & history_microphysics_out = history_microphysics ) @@ -1166,7 +1184,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & !initialize aerosol number ! naer2(i,k,:) = zero dum2l(i,k) = zero - dum2i(i,k) = zero + dum2i(i,k) = zero ncmax(i,k) = zero ! for debug purpose @@ -1327,7 +1345,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & ! miu_ice = mui_hemp_l(lami(k)) miu_ice(k) = max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, - & 10.0_r8), 0.1_r8) + & 10.0_r8), 0.1_r8) tx1 = one + miu_ice(k) tx2 = one / gamma(tx1) aux = (gamma(tx1+di)*tx2) ** oneodi @@ -1542,7 +1560,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & dum2i(i,k) = naai(i,k) else - + ! cooper curve (factor of 1000 is to convert from L-1 to m-3) dum2i(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) & * 1000._r8 @@ -1690,7 +1708,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & km = k - 1 ! set cwml and cwmi to current qc and qi - + cwml(i,k) = qc(i,k) cwmi(i,k) = qi(i,k) @@ -1874,7 +1892,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & ! add upper limit to in-cloud number concentration to prevent numerical error ncic(i,k) = min(ncic(i,k),qcic(i,k)*1.e20_r8) - + ncic(i,k) = max(ncic(i,k),cdnl*irho(i,k)) ! get pgam from fit to observations of martin et al. 1994 @@ -1956,9 +1974,9 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & ! prc(k) = cons2/(cons3*cons18)*1350._r8 ! & * qcic(i,k)**2.47_r8 ! & * (1.e-6_r8*ncic(i,k)*rho(i,k))**(-1.79_r8) - + if (auto_option == 1) then - + tx1 = qcic(i,k)*rho(i, k)/3.0e-4 prc(k) = 1.0e-3 * qcic(i,k) * (one-exp(-tx1*tx1)) & * gamma(one+qcvar)/(cons3*qcvar) @@ -1996,7 +2014,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & & / (gamma(qcvar)*(qcvar*qcvar)) prc(k) = prc(k)*dcrit - + xs = 1/xs else prc(k) = cons2/(cons3*cons18)*1350._r8 @@ -2084,7 +2102,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & if (.false.) then vaux = ts_auto_ice * 10.0_r8 - + nprci(k) = (niic(i, k)/vaux)*exp(-lami(k)*dcs) tx1 = one / lami(k) tx2 = tx1 * tx1 @@ -2330,7 +2348,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & if ((nnucct(k)+nnuccc(k))*deltat > ncic(i, k)) then - + tx1 = tx2 * tx3 nnuccc(k) = ncic(i, k)*dti mnuccc(k) = cons9/(cons3*cons19)* pi*pirhow/36._r8 @@ -2434,12 +2452,12 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & tx4 = tx1 * tx1 tx5 = pi * ecr * rho(i,k) *n0r(k) * n0s(k) - pracs(k) = pirhow*tx2*tx5 * + pracs(k) = pirhow*tx2*tx5 * & (tx4*tx4*tx3*(five*tx4+tx3*(two*tx1+half*tx3))) tx2 = unr(k) - uns(k) - tx2 = sqrt(1.7_r8*tx2*tx2 + 0.3_r8*unr(k)*uns(k)) + tx2 = sqrt(1.7_r8*tx2*tx2 + 0.3_r8*unr(k)*uns(k)) npracs(k) = half*tx2*tx5*tx1*tx3*(tx4+tx3*(tx1+tx3)) @@ -2493,7 +2511,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & !....................................................................... ! Self-collection of rain drops ! from Beheng(1994) - + if (qric(i,k) >= qsmall) then nragg(k) = -8._r8*nric(i,k)*qric(i,k)*rho(i,k) else @@ -2514,7 +2532,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & nprai(k) = tx1 * niic(i,k) nprai(k)= min(nprai(k), 1.0e10) - + else prai(k) = zero nprai(k) = zero @@ -2658,7 +2676,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & & * cons14 / (lams(k)**((five+bs)*half))) bergs(k) = epss*(qvs-qvi)/abi else - bergs(k) = zero + bergs(k) = zero end if @@ -2744,7 +2762,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & ratio = (nie*dti+(nnucct(k)+nsacwi(k))*lcldm(i,k)) & / ((nprci(k)+nprai(k)-nsubi(k))*icldm(i,k))*omsm else - + ratio = zero end if nprci(k) = nprci(k) * ratio @@ -2850,8 +2868,8 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & & + berg(i,k)) * xlf -! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 -! & .and.xlat<1.347.and.k==38) +! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 +! & .and.xlat<1.347.and.k==38) ! & write(*,*)"anning_m0",pre(k),prds(k),cmei(i,k), ! & bergs(k),psacws(k), ! & mnuccc(k),mnucct(k),msacwi(k),mnuccr(k),pracs(k),berg(i,k) @@ -2869,7 +2887,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & qrtend(i,k) = qrtend(i,k) & + (pra(k)+prc(k))*lcldm(i,k) & + (pre(k)-pracs(k)-mnuccr(k))*cldmax(i,k) - + qnitend(i,k) = qnitend(i,k) & + (prai(k)+prci(k))*icldm(i,k) & + (psacws(k)+bergs(k))*lcldm(i,k) @@ -2877,7 +2895,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & ! if (lprint) write(0,*)' k=',k,' qnitend=',qnitend(i,k), ! & prai(k), prci(k), icldm(i,k),psacws(k),bergs(k),lcldm(i,k) -! &,prds(k),pracs(k),mnuccr(k),' cldmax=',cldmax(i,k) +! &,prds(k),pracs(k),mnuccr(k),' cldmax=',cldmax(i,k) ! add output for cmei (accumulate)!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! cmeiout(i,k) = cmeiout(i,k) + cmei(i,k) @@ -3079,8 +3097,8 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & tlat(i,k) = tlat(i,k) + tmp -! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 -! & .and.xlat<1.347.and.k==38) +! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 +! & .and.xlat<1.347.and.k==38) ! & write(*,*)"anning_m1",tmp qrtot = qrtot + dum*qstot @@ -3120,10 +3138,10 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & tlat(i,k) = tlat(i,k) + tmp -! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 -! & .and.xlat<1.347.and.k==38) +! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 +! & .and.xlat<1.347.and.k==38) ! & write(*,*)"anning_m2",tmp - + qstot = qstot + dum*qrtot qrtot = (one-dum)*qrtot nstot = nstot + dum*nrtot @@ -3142,7 +3160,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & ! if rain/snow mix ratio is zero so should number concentration if (qniic(i,k) < qsmall) then - qniic(i,k) = zero + qniic(i,k) = zero nsic(i,k) = zero end if @@ -3189,7 +3207,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & tx2 = 9.1_r8*rhof(i,k) unr(k) = min(tx1*cons4, tx2) umr(k) = min(tx1*(cons5/6._r8),tx2) - + else lamr(k) = zero n0r(k) = zero @@ -3590,7 +3608,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & faloutni(k) = max(fni(k) * dumni(i,k), zero) faloutc(k) = max(fc(k) * dumc(i,k), zero) faloutnc(k) = max(fnc(k) * dumnc(i,k), zero) - end do + end do ! top of model @@ -3711,7 +3729,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & ! end sedimentation !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! calculate sedimentation for rain and snow -! Anning Cheng 9/19/2016, forecast rain and snow +! Anning Cheng 9/19/2016, forecast rain and snow ! reuse dummy variable for cloud water and ice ! iter =1 for fprcp >= 1 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -3860,7 +3878,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & faloutni(k) = max(fni(k) * nsnw(i,k), zero) faloutc(k) = max(fc(k) * qrn(i,k), zero) faloutnc(k) = max(fnc(k) * nrn(i,k), zero) - end do + end do ! top of model @@ -3894,7 +3912,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & faltndc = (faloutc(k) - faloutc(k-1)) * tx1 faltndnc = (faloutnc(k) - faloutnc(k-1)) * tx1 - + faltndi = (falouti(k) - falouti(k-1)) * tx1 faltndni = (faloutni(k) - faloutni(k-1)) * tx1 @@ -4155,7 +4173,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & dumc(i,k) = min(dumc(i,k),5.e-3_r8) dumi(i,k) = min(dumi(i,k),5.e-3_r8) - + !................... ! cloud ice effective radius @@ -4252,13 +4270,13 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & !assign output fields for shape here lamcrad(i,k) = lamc(k) pgamrad(i,k) = pgam(k) - + else effc(i,k) = 10._r8 lamcrad(i,k) = zero pgamrad(i,k) = zero end if - + ! ice effective diameter for david mitchell's optics deffi(i,k) = effi(i,k) * (rhoi / 917._r8*two) diff --git a/physics/MP/Morrison_Gettelman/m_micro.F90 b/physics/MP/Morrison_Gettelman/m_micro.F90 index 1cc866689..c25311950 100644 --- a/physics/MP/Morrison_Gettelman/m_micro.F90 +++ b/physics/MP/Morrison_Gettelman/m_micro.F90 @@ -40,9 +40,11 @@ subroutine m_micro_init(imp_physics, imp_physics_mg, fprcp, gravit, rair, rh2o, mg_precip_frac_method, mg_berg_eff_factor, sed_supersat, & do_sb_physics, mg_do_hail, mg_do_graupel, mg_nccons, & mg_nicons, mg_ngcons, mg_ncnst, mg_ninst, mg_ngnst, & - mg_do_ice_gmao, mg_do_liq_liu, errmsg, errflg) + mg_do_ice_gmao, mg_do_liq_liu, & + errmsg, errflg) use machine, only: kind_phys + use cldmacro, only: cldmacro_init use cldwat2m_micro, only: ini_micro use micro_mg2_0, only: micro_mg_init2_0 => micro_mg_init use micro_mg3_0, only: micro_mg_init3_0 => micro_mg_init @@ -92,7 +94,7 @@ subroutine m_micro_init(imp_physics, imp_physics_mg, fprcp, gravit, rair, rh2o, lsbcp = (hvap+hfus)*onebcp if (fprcp <= 0) then - call ini_micro (mg_dcs, mg_qcvar, mg_ts_auto_ice(1)) + call ini_micro (mg_dcs, mg_qcvar, mg_ts_auto_ice(1), cpair) elseif (fprcp == 1) then call micro_mg_init2_0(kind_phys, gravit, rair, rh2o, cpair, & eps, tmelt, latvap, latice, mg_rhmini,& @@ -127,14 +129,17 @@ subroutine m_micro_init(imp_physics, imp_physics_mg, fprcp, gravit, rair, rh2o, errmsg = 'ERROR(m_micro_init): fprcp is not a valid option' return endif - call aer_cloud_init () - + call aer_cloud_init(pi_in) +#ifdef NEMS_GSM + call cldmacro_init(tice_in, gravit, cpair, latvap, & + latice, pi_in, rair, rh2o) +#endif is_initialized = .true. end subroutine m_micro_init !> \defgroup mg2mg3 Morrison-Gettelman MP Driver Module -!! \brief This subroutine is the Morrison-Gettelman MP driver, which computes +!! \brief This subroutine is the Morrison-Gettelman MP driver, which computes !! grid-scale condensation and evaporation of cloud condensate. !! !> \section arg_table_m_micro_run Argument Table @@ -160,8 +165,9 @@ subroutine m_micro_run( im, lm, flipv, dt_i & &, naai_i, npccn_i, iccn & &, skip_macro & &, alf_fac, qc_min, pdfflag & - &, kdt, xlat, xlon, rhc_i, & - & errmsg, errflg) + &, kdt, xlat, xlon, rhc_i & + &, con_g, con_cp, con_rd, con_fvirt & + &, errmsg, errflg) ! use funcphys, only: fpvs !< saturation vapor pressure for water-ice mixed ! use funcphys, only: fpvsl, fpvsi, fpvs !< saturation vapor pressure for water,ice & mixed @@ -189,12 +195,12 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! real, parameter :: r_air = 3.47d-3 integer, parameter :: kp = kind_phys real(kind=kind_phys), intent(in ) :: rainmin - + integer, parameter :: ncolmicro = 1 integer,intent(in) :: im, lm, kdt, fprcp, pdfflag, iccn, ntrcaer logical,intent(in) :: flipv, skip_macro real (kind=kind_phys), intent(in):: dt_i, alf_fac, qc_min(:) - + real (kind=kind_phys), intent(in):: con_g, con_cp, con_rd, con_fvirt real (kind=kind_phys), dimension(:,:),intent(in) :: & & prsl_i,u_i,v_i,phil, omega_i, QLLS_i,QILS_i, & & lwheat_i,swheat_i @@ -711,7 +717,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & !need an estimate of convective area !======================================================================================================================= !======================================================================================================================= -!> -# Nucleation of cloud droplets and ice crystals +!> -# Nucleation of cloud droplets and ice crystals !! Aerosol cloud interactions. Calculate maxCCN tendency using Fountoukis and Nenes (2005) or Abdul Razzak and Ghan (2002) !! liquid Activation Parameterization !! Ice activation follows the Barahona & Nenes ice activation scheme, ACP, (2008, 2009). @@ -819,7 +825,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & call gw_prof (1, LM, 1, tm_gw, pm_gw, pi_gw, rhoi_gw, ni_gw, & - & ti_gw, nm_gw, q1(i,:)) + & ti_gw, nm_gw, q1(i,:), con_g, con_cp, con_rd, con_fvirt) do k=1,lm nm_gw(k) = max(nm_gw(k), 0.005_kp) @@ -1224,7 +1230,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & !===========================Two-moment stratiform microphysics =============================== !===========This is the implementation of the Morrison and Gettelman (2008) microphysics ===== !============================================================================================= -!> -# Two-moment stratiform microphysics: this is the implementation of the Morrison and +!> -# Two-moment stratiform microphysics: this is the implementation of the Morrison and !! Gettelman (2008) microphysics \cite Morrison_2008 do I=1,IM @@ -1295,7 +1301,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! else ! call init_Aer(AeroAux) ! end if -!> - Call getinsubset() to extract dust properties +!> - Call getinsubset() to extract dust properties call getINsubset(1, AeroAux, AeroAux_b) naux = AeroAux_b%nmods if (nbincontactdust < naux) then @@ -1904,15 +1910,13 @@ end subroutine m_micro_run !=============================================================================== !>\ingroup mg2mg3 -!> This subroutine computes profiles of background state quantities for +!> This subroutine computes profiles of background state quantities for !! the multiple gravity wave drag parameterization. !!\section gw_prof_gen MG gw_prof General Algorithm !> @{ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & - nm, sph) + nm, sph, grav, cp, rgas, fv) use machine , only : kind_phys - use physcons, grav => con_g, cp => con_cp, rgas => con_rd, & - fv => con_fvirt implicit none integer, parameter :: kp = kind_phys !----------------------------------------------------------------------- @@ -1932,19 +1936,29 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & real(kind=kind_phys), intent(in) :: pi(pcols,0:pver) real(kind=kind_phys), intent(in) :: sph(pcols,pver) + real(kind=kind_phys), intent(in) :: grav ! con_g + real(kind=kind_phys), intent(in) :: cp ! con_cp + real(kind=kind_phys), intent(in) :: rgas ! con_rd + real(kind=kind_phys), intent(in) :: fv ! con_fvirt + + real(kind=kind_phys), intent(out) :: rhoi(pcols,0:pver) real(kind=kind_phys), intent(out) :: ni(pcols,0:pver) real(kind=kind_phys), intent(out) :: ti(pcols,0:pver) real(kind=kind_phys), intent(out) :: nm(pcols,pver) - real(kind=kind_phys), parameter :: r=rgas, cpair=cp, g=grav, & - oneocp=1.0_kp/cp, n2min=1.0e-8_kp - !---------------------------Local storage------------------------------- + real(kind=kind_phys), parameter :: n2min=1.0e-8_kp + real(kind=kind_phys) :: r, cpair, g, oneocp integer :: ix,kx real :: dtdp, n2 + r=rgas + cpair=cp + g=grav + oneocp=1.0_kp/cp + !----------------------------------------------------------------------------- !> -# Determine the interface densities and Brunt-Vaisala frequencies. !----------------------------------------------------------------------------- diff --git a/physics/MP/Morrison_Gettelman/m_micro.meta b/physics/MP/Morrison_Gettelman/m_micro.meta index 16efc5cc4..dee3435c8 100644 --- a/physics/MP/Morrison_Gettelman/m_micro.meta +++ b/physics/MP/Morrison_Gettelman/m_micro.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = m_micro type = scheme - dependencies = ../../hooks/machine.F,../../hooks/physcons.F90 + dependencies = ../../hooks/machine.F dependencies = aer_cloud.F,aerclm_def.F,cldmacro.F,cldwat2m_micro.F dependencies = micro_mg_utils.F90,micro_mg2_0.F90,micro_mg3_0.F90,wv_saturation.F @@ -828,6 +828,38 @@ type = real kind = kind_phys intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/MP/NSSL/module_mp_nssl_2mom.F90 b/physics/MP/NSSL/module_mp_nssl_2mom.F90 index 130f9bf9a..667215e73 100644 --- a/physics/MP/NSSL/module_mp_nssl_2mom.F90 +++ b/physics/MP/NSSL/module_mp_nssl_2mom.F90 @@ -53,14 +53,14 @@ ! ! !--------------------------------------------------------------------- -! Feb. 2025 +! 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 +! - 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 +! - 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) @@ -137,7 +137,7 @@ ! Adjusted Meyers number of activated nuclei by the local air density to compensate for using data at surface ! Minor updates to rain-ice crystal and hail-rain collection efficiencies ! -! +! ! Reduced minimum mean snow diameter from 100 microns to 10 microns ! !--------------------------------------------------------------------- @@ -168,14 +168,14 @@ !>\defgroup mod_nsslmp NSSL 2-moment microphysics modules -!!\ingroup nsslmp +!!\ingroup nsslmp !> This module contains 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). MODULE module_mp_nssl_2mom IMPLICIT NONE - + public nssl_2mom_driver public nssl_2mom_init public nssl_2mom_init_const @@ -186,7 +186,7 @@ MODULE module_mp_nssl_2mom private gamma_dp, gamxinfdp, gamma_dpr private delbk, delabk private gammadp - + logical, private :: cleardiag = .false. PRIVATE @@ -197,28 +197,28 @@ MODULE module_mp_nssl_2mom #endif LOGICAL, PRIVATE:: is_aerosol_aware = .false. - + logical, private :: turn_on_cin = .false. - + 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 double precision, parameter, public :: zscaleinv = 1.0d0/zscale ! 1.000e-10 - + real, parameter :: warmonly = 0.0 ! testing parameter, set to 1.0 to reduce to warm-rain physics (ice variables stay zero) - + logical, parameter :: lwsm6 = .false. ! act like wsm6 for some single moment interactions ! some constants from WSM6 real, parameter :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter real, parameter :: roqimax = 2.08e22*dimax**8 - + ! Params for dbz: integer :: iuseferrier = 1 ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel) integer :: idbzci = 1 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 + ! =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 ! microphysics @@ -233,7 +233,7 @@ MODULE module_mp_nssl_2mom real :: cnohmn = 1.e-2 ! minimum intercept for 2-moment graupel (alphah < 0.5) real :: cnohlmn = 1.e-2 ! minimum intercept for 2-moment hail (alphahl < 0.5) - + ! Autoconversion parameters real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) @@ -274,7 +274,7 @@ MODULE module_mp_nssl_2mom integer, private :: isfall = 2 ! default limit with method II (more restrictive) logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive) ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) - ! Mainly is an issue for small dz near the surface. + ! Mainly is an issue for small dz near the surface. integer, private :: interval_sedi_vt = 2 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.) integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) ! 1 -> uses mass-weighted fallspeed for N ALWAYS @@ -301,7 +301,7 @@ MODULE module_mp_nssl_2mom real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) real , private :: cdhldnmin = 500., cdhldnmax = 800.0 ! defaults for hail (icdx=4) real , private :: vtmaxsed = 70. ! Limit on fall speed (m/s, all moments) for sedimentation calculations. Not applied to fall speeds for microphysical rates - + 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 snow integer :: hssflg = 1 ! As above but for graupel @@ -314,7 +314,7 @@ MODULE module_mp_nssl_2mom integer, private :: inucopt = 0 integer, private :: ichaff = 0 integer, parameter :: ilimit = 0 - + real, private :: constccw = -1. real, private :: cimn = 1.0e3, cimx = 1.0e6 @@ -417,7 +417,7 @@ MODULE module_mp_nssl_2mom real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency real :: ehlr0 = 1.0 ! constant or max assumed hail-rain collection efficiency real , private :: exwmindiam = 0.0 ! minimum diameter of droplets for riming. If set > 0, will exclude that fraction of mass/number from accretion (idea from Furtado and Field 2017 JAS but also Fierro and Mansell 2017) - + real , private :: esilfo0 = 1.0 ! factor for LFO collection efficiency of snow for cloud ice. real , private :: ehslfo0 = 1.0 ! factor for LFO collection efficiency of hail/graupel for snow. @@ -481,8 +481,8 @@ MODULE module_mp_nssl_2mom ! 0 = no condensation on rain; 1 = bulk condensation on rain integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) - integer, private :: iqis0 = 2 ! = 1 for normal qis; = 2 to set qis to use T = 0C when T > 0C - + integer, private :: iqis0 = 2 ! = 1 for normal qis; = 2 to set qis to use T = 0C when T > 0C + real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 ! and for ciacrf for iacr=4 real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail @@ -493,9 +493,9 @@ MODULE module_mp_nssl_2mom integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail integer, private :: imltshddmr = 2 ! 0 (default)=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 - ! 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 + ! 1=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 @@ -520,7 +520,7 @@ MODULE module_mp_nssl_2mom real , private :: sheddiam = 8.0e-03 ! minimum diameter of graupel before shedding occurs 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 @@ -536,7 +536,7 @@ MODULE module_mp_nssl_2mom real :: fwmlarge = 0.2 ! maximum liquid water fraction on hail larger than sheddiam integer :: ifwmfall = 0 ! whether to interpolate toward rain fall speed for graupel and hail ! when diam < sheddiam and liquid fraction is predicted (0=no, 1=yes) - + 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) @@ -544,7 +544,7 @@ MODULE module_mp_nssl_2mom logical :: rescale_low_alphahl = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) real, parameter :: alpharmax = 8. ! limited for rwvent calculation - + integer, private :: ihlcnh = -1 ! which graupel -> hail conversion to use ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter ! 2 = Straka and Mansell (2005) conversion using size threshold @@ -576,7 +576,7 @@ MODULE module_mp_nssl_2mom integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) integer, private :: 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, private :: imaxdiaopt = 3 + integer, private :: imaxdiaopt = 3 ! = 1 use mean diameter for breakup ! = 2 use maximum mass diameter for breakup ! = 3 use mass-weighted diameter for breakup @@ -592,7 +592,7 @@ MODULE module_mp_nssl_2mom 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) real :: qrbrthresh2 = 1.0e-3 ! upper threshold rain content (kg/m^3) for large drop breakup (irainbreak=11) - integer, private :: dmrauto = 0 + integer, private :: dmrauto = 0 ! = -1 no limiter on crcnw ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) ! = 1 DTD version based on MY code @@ -601,20 +601,20 @@ MODULE module_mp_nssl_2mom integer :: dmropt = 0 ! extra option for crcnw integer :: dmhlopt = 0 ! options for graupel -> hail conversion integer :: irescalerainopt = 3 ! 0 = default option - ! 1 = qx(mgs,lc) > qxmin(lc) + ! 1 = qx(mgs,lc) > qxmin(lc) ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 - ! 3 = temcg(mgs) > 0.0.and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + ! 3 = temcg(mgs) > 0.0.and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 real :: rescale_wthresh = 3.0 real :: rescale_tempthresh = 0.0 real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion real :: cxmin = 1.e-8 ! threshold cutoff for number concentration real :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment - + integer :: ithompsoncnoh = 0 ! For single moment graupel only ! 0 = fixed intercept ! 1 = intercept based on graupel mass - integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting + integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting ! when liquid fraction is not predicted logical, private :: iwetsoak = .true. ! soak and freeze during wet growth or not integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories @@ -624,27 +624,27 @@ MODULE module_mp_nssl_2mom integer, private :: isnowdens = 1 ! Option for choosing between snow density options ! 1 = constant of 100 kg m^-3 - ! 2 = Option based on Cox - + ! 2 = Option based on Cox + integer, private :: ibiggsnow = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction ! 3 = switch conversion over to snow for small frozen drops from both real :: biggsnowdiam = -1.0 ! If >0, use for ibiggsnow threshold - + integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) real, private :: takshedsize1 = 0.15 ! diameter (cm) of drop shed from ice with D > 1.9 cm real, private :: takshedsize2 = 0.3 ! diameter (cm) of drop shed from ice with D < 1.9 cm and D > 0.8 cm real, private :: takshedsize3 = 0.45 ! diameter (cm) of drop shed from ice with D < 1.6 cm and D > 0.8 cm integer, private :: numshedregimes = 3 - + real, private :: evapfac = 1.0 ! Multiplier on rain evaporation rate real, private :: depfac = 1.0 ! Multiplier on graupel/hail deposition/sublimation rate real,private,parameter :: meltfac = 1.0 ! Multiplier on graupel/hail melting rate - integer, private :: ibinhmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes + integer, private :: ibinhmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes ! =2 to test melting by temporary bins - integer, private :: ibinhlmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes + integer, private :: ibinhlmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes ! =2 to test melting by temporary bins integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1) integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr @@ -656,7 +656,7 @@ MODULE module_mp_nssl_2mom real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow. real, private :: alphasmlr0 = 14.0 ! shape parameter for drops formed from melting/shedding snow real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter - + integer, private :: iqvsopt = 1 ! =0 use old default for tabqvs with e/p approx; =1 use Bolton formulation (Rogers and Yau) with e/(p-e) integer :: imaxsupopt = 4 ! how to treat saturation adjustment in two-moment droplets @@ -667,7 +667,7 @@ MODULE module_mp_nssl_2mom real :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done real :: maxlowtempss = 1.08 ! Sat. ratio threshold for allowing droplet nucleation at T < tfrh real :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.) - + integer, parameter :: icespheres = 0 ! turn ice spheres (frozen droplets) on (1) or off (0). NOT COMPLETE IN WRF/ARPS/CM1 CODE! integer, parameter :: lqmx = 30 @@ -778,16 +778,16 @@ MODULE module_mp_nssl_2mom real, parameter :: rnumin = -0.8 real, parameter :: rnumax = 15.0 - + real :: cnu = 0.0 ! default value of droplet shape parameter. Can be diagnosed by setting idiagnosecnu=1 real, parameter :: rnu = -0.8, snu = -0.8, cinu = 0.0 ! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) - + real xnu(lc:lqmx) ! 1st shape parameter (mass) real xmu(lc:lqmx) ! 2nd shape parameter (mass) real dnu(lc:lqmx) ! 1st shape parameter (diameter) real dmu(lc:lqmx) ! 2nd shape parameter (diameter) - + real ax(lc:lqmx) real bx(lc:lqmx) real fx(lc:lqmx) @@ -804,7 +804,7 @@ MODULE module_mp_nssl_2mom integer :: isaund = 0 logical :: idoniconly = .false. integer, private :: elec_on_time = -1 ! time (seconds) to turn on charge separation. - integer, private :: elec_ramp_time = 0 ! time (interval) for linear ramp after elec_on_time + integer, private :: elec_ramp_time = 0 ! time (interval) for linear ramp after elec_on_time ! (i.e., linear factor on chg sep to smoothly turn on elec) ! full charging rate is achieved at time = elec_on_time + elec_ramp_time integer :: jchgs = 3 ! number of points near boundary where charging is turned off (to keep lightning from getting wonky) @@ -833,7 +833,7 @@ MODULE module_mp_nssl_2mom real, parameter :: maxratiolu = 100. ! 25. real, parameter :: maxalphalu = 15. real, parameter :: minalphalu = -0.95 - real, parameter :: dqiacralpha = maxalphalu/Float(nqiacralpha), dqiacrratio = maxratiolu/Float(nqiacrratio) + real, parameter :: dqiacralpha = maxalphalu/Float(nqiacralpha), dqiacrratio = maxratiolu/Float(nqiacrratio) real, parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha integer, parameter :: ialpstart = minalphalu*dqiacralphainv real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha) @@ -899,8 +899,8 @@ MODULE module_mp_nssl_2mom ! cs = 4.83607122 ! snow terminal velocity power law coefficient (LFO) ! ds = 0.25 ! snow terminal velocity power law coefficient (LFO) ! 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 :: cs = 12.42 ! snow terminal velocity power law coefficient + real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient real :: cp608 = 0.608 ! constant used in conversion of T to Tv real :: gr = 9.8 @@ -935,7 +935,7 @@ MODULE module_mp_nssl_2mom real, parameter :: xvimn=0.523599*(2.*5.e-6)**3 ! mks min volume = 5 micron radius real, parameter :: xvimx=0.523599*(2.*1.e-3)**3 ! mks max volume = 1 mm radius (solid sphere approx) - + real, private :: xvdmx = -1.0 ! 3.0e-3 real :: xvrmx parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 ) ! mks @@ -997,7 +997,7 @@ MODULE module_mp_nssl_2mom REAL, PRIVATE, parameter :: cvv = 1408.5 ! GHB - real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) + real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) real :: ventr, ventrn, ventc, c1sw @@ -1230,7 +1230,7 @@ REAL FUNCTION fqis(t) real :: t fqis = exp(cai*(t-273.15)/(t-cbi)) END FUNCTION fqis - + !==========================================================================================! @@ -1244,11 +1244,11 @@ END FUNCTION fqis !! NSSL MP subroutine to initialize physical constants provided by host model SUBROUTINE nssl_2mom_init_const( & con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) - + implicit none real, intent(in) :: con_g, con_rd, con_cp, con_rv, & con_t0c, con_cliq, con_csol, con_eps - + gr = con_g tfr = con_t0c cp = con_cp @@ -1262,8 +1262,8 @@ SUBROUTINE nssl_2mom_init_const( & tfrcbw = tfr - cbw tfrcbi = tfr - cbi rovcp = rd/cp - - + + RETURN END SUBROUTINE nssl_2mom_init_const @@ -1297,7 +1297,7 @@ SUBROUTINE nssl_2mom_init( & ) implicit none - + real, intent(in), optional :: & & nssl_graupelfallfac, & & nssl_hailfallfac, & @@ -1359,7 +1359,7 @@ SUBROUTINE nssl_2mom_init( & real :: alpjj, alpii, xnuii, xnujj integer :: ii, jj - + errmsg = '' errflg = 0 @@ -1369,7 +1369,7 @@ SUBROUTINE nssl_2mom_init( & ! IF ( present( igvol ) ) THEN ! igvol_local = igvol ! ENDIF - + IF ( present( nssl_hail_on ) ) THEN IF ( nssl_hail_on ) THEN hail_on = 1 @@ -1385,7 +1385,7 @@ SUBROUTINE nssl_2mom_init( & density_on = 0 ENDIF ENDIF - + IF ( present( nssl_icecrystals_on ) ) THEN IF ( nssl_icecrystals_on ) THEN icecrystals_on = 1 @@ -1454,7 +1454,7 @@ SUBROUTINE nssl_2mom_init( & ipconc = ipctmp - + IF ( ihlcnh <= 0 ) THEN IF ( ipconc < 5 ) THEN @@ -1475,18 +1475,18 @@ SUBROUTINE nssl_2mom_init( & irainbreak = 0 ENDIF ENDIF - + #ifdef INTERNAL_FILE_NML read (internal_nml, nml = nssl_mp_params, iostat=istat) #else - + namelist_inputfile = 'namelist.input' ! default for WRF/cm1 - IF ( present( namelist_filename ) ) THEN + IF ( present( namelist_filename ) ) THEN namelist_inputfile = namelist_filename ELSE namelist_inputfile = 'input.nml' ENDIF - + open(15,file=trim(namelist_inputfile),status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) @@ -1565,7 +1565,7 @@ SUBROUTINE nssl_2mom_init( & hail_on = 1 IF ( ihvol <= -1 .or. ihvol == 2 ) THEN IF ( ihvol == -1 .or. ihvol == -2 ) THEN - lhab = lhab - 1 ! turns off hail + lhab = lhab - 1 ! turns off hail lhl = 0 hail_on = 0 ! past me thought it would be a good idea to change graupel factors when hail is off.... @@ -1580,16 +1580,16 @@ SUBROUTINE nssl_2mom_init( & ! idoci = 0 ! try this later ENDIF ENDIF - + ELSE ! hail_on is set IF ( hail_on == 0 ) THEN - lhab = lhab - 1 ! turns off hail + lhab = lhab - 1 ! turns off hail lhl = 0 ELSE ! assume default that hail is on ENDIF ENDIF - + IF ( density_on == -1 ) THEN ! density flag not set, so default is to predict it density_on = 1 ENDIF @@ -1625,7 +1625,7 @@ SUBROUTINE nssl_2mom_init( & ax(lr) = 1647.81 fx(lr) = 135.477 - + IF ( icdx == 6 ) THEN bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. ax(lh) = 157.71 @@ -1674,10 +1674,10 @@ SUBROUTINE nssl_2mom_init( & ! (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) - + bxh1 = bx(lh) bxhl1 = bx(Max(lh,lhl)) - + ! DO j = 0,nqiacralpha DO j = ialpstart,nqiacralpha alp = float(j)*dqiacralpha @@ -1699,7 +1699,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 - + ! hail (.,.,.,2) gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) @@ -1724,7 +1724,7 @@ SUBROUTINE nssl_2mom_init( & gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio ) )/y gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio ) )/y ENDIF - + gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) ENDDO @@ -1737,7 +1737,7 @@ SUBROUTINE nssl_2mom_init( & y7 = gamma_sp(7.+alp) DO i = 0,nqiacrratio ratio = float(i)*dqiacrratio - + ! mass fraction x = gamxinfdp( 4.+alp, ratio ) ! write(0,*) 'i, x/y = ',i, x/y @@ -1778,7 +1778,7 @@ SUBROUTINE nssl_2mom_init( & lhlw = 0 denscale(:) = 0 - + ! lccn = 9 @@ -1910,9 +1910,9 @@ SUBROUTINE nssl_2mom_init( & - ! write(0,*) 'wrf_init: lh,lhl,lzh,lzhl = ',lh,lhl,lzh,lzhl + ! 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 + ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna IF ( turn_on_ccna ) THEN ltmp = ltmp + 1 lccna = ltmp @@ -1948,14 +1948,14 @@ SUBROUTINE nssl_2mom_init( & ipc(ls) = 4 ipc(lh) = 5 IF ( lhl .gt. 1 ) ipc(lhl) = 5 - + ldovol = .false. lvol(:) = 0 lvol(li) = lvi lvol(ls) = lvs lvol(lh) = lvh IF ( lhl .gt. 1 .and. lvhl .gt. 1 ) lvol(lhl) = lvhl - + lne = Max(lnh,lnhl) lne = Max(lne,lvh) lne = Max(lne,lvhl) @@ -1995,7 +1995,7 @@ SUBROUTINE nssl_2mom_init( & xnu(lc) = cnu xmu(lc) = 1. - + IF ( imurain == 3 ) THEN xnu(lr) = rnu xmu(lr) = 1. @@ -2033,39 +2033,39 @@ SUBROUTINE nssl_2mom_init( & IF ( imurain == 3 ) THEN ! rain is gamma of volume - rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr))) ! IF ( ipconc .lt. 5 ) alphahl = alphah - - rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ & + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ & & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(2. + xnu(lr))) rzs = 1. ! assume rain and snow are both gamma volume ELSE ! rain is gamma of diameter - - rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + + 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)) - - rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + 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)) - - rzs = & + + rzs = & & ((1. + alphar)*(2. + alphar)*(3. + alphar)*(2. + xnu(ls)))/ & & ((4. + alphar)*(5. + alphar)*(6. + alphar)*(1. + xnu(ls))) - + ENDIF - IF ( ipconc <= 5 ) THEN + IF ( ipconc <= 5 ) THEN imltshddmr = Min(1, imltshddmr) ibinhmlr = 0 ibinhlmlr = 0 ENDIF - IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN + IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN imltshddmr = Min(1, imltshddmr) ENDIF @@ -2200,7 +2200,7 @@ SUBROUTINE nssl_2mom_init( & xvhmx = pi/6.0*(morrdnglimit/cwch)**3 dhmx = morrdnglimit/cwch ENDIF - + IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh) IF ( qhacidn < 0. ) qhacidn = xdnmn(lh) @@ -2235,7 +2235,7 @@ SUBROUTINE nssl_2mom_init( & ! cwmasn = xvmn(lc)*1000. ! minimum mass, defined by minimum droplet volume ! cwradn = 1.0e-6 ! minimum radius ! cwmasx = xvmx(lc)*1000. ! maximum mass, defined by maximum droplet volume - + ENDIF ! rwmasn = xvmn(lr)*1000. ! minimum mass, defined by minimum rain volume ! rwmasx = xvmx(lr)*1000. ! maximum mass, defined by maximum rain volume @@ -2249,7 +2249,7 @@ SUBROUTINE nssl_2mom_init( & ! ELSE ventrn = Gamma_sp(rnu + 1.5 + br/6.)/(Gamma_sp(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent ! ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent -! ventr = Gamma_sp(rnu + 4./3.)/Gamma_sp(rnu + 1.) +! ventr = Gamma_sp(rnu + 4./3.)/Gamma_sp(rnu + 1.) ! ENDIF ELSE ! imurain == 1 ! IF ( iferwisventr == 1 ) THEN @@ -2328,7 +2328,7 @@ SUBROUTINE nssl_2mom_init( & dab0lu(:,:,:,:) = 0.0 dab1lu(:,:,:,:) = 0.0 - + IF ( ipconc >= 6 ) THEN DO il = lc,lhab ! collector DO j = lc,lhab ! collected @@ -2340,17 +2340,17 @@ SUBROUTINE nssl_2mom_init( & DO ii = ialpstart,nqiacralpha alpii = float(ii)*dqiacralpha xnuii = (alpii - 2.)/3. - + dab0lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 0) dab1lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 1) - + ENDDO ENDDO ! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j) ENDIF ENDDO ENDDO - + ENDIF gf4br = gamma_sp(4.0+br) @@ -2363,7 +2363,7 @@ SUBROUTINE nssl_2mom_init( & gfcinu2p22 = gamma_sp(cinu + 2.22117) gfcinu1p18 = gamma_sp(cinu + 1.18333) gfcinu2p18 = gamma_sp(cinu + 2.18333) - + gsnow1 = gamma_sp(snu + 1.0) gsnow53 = gamma_sp(snu + 5./3.) gsnow73 = gamma_sp(snu + 7./3.) @@ -2445,9 +2445,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw isedonly_in, & diagflag,ke_diag, & errmsg, errflg, & - nssl_progn, & ! wrf-chem + nssl_progn, & ! wrf-chem ! 20130903 acd_mb_washout start - wetscav_on, rainprod, evapprod, & ! wrf-chem + 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 @@ -2510,7 +2510,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & ! ncauto, niinit,nifrz, & ! re_liquid, re_graupel, re_hail, re_icesnow, & -! vtcloud, vtrain, vtsnow, vtgraupel, vthail +! vtcloud, vtrain, vtsnow, vtgraupel, vthail real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra @@ -2546,8 +2546,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg - LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem - + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem + ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop LOGICAL :: flag_qndrop ! wrf-chem LOGICAL :: flag_qnifa , flag_qnwfa @@ -2616,11 +2616,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw 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 :: has_wetscav @@ -2630,9 +2630,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot real :: fach(kts:kte) - + logical, parameter :: debugdriver = .false. - + integer :: loopcnt, loopmax, outerloopcnt logical :: lastlooptmp @@ -2643,7 +2643,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw errflg = 0 rdt = 1.0/dtp - + IF ( debugdriver ) write(0,*) 'N2M: entering routine' flag_qndrop = .false. @@ -2652,17 +2652,17 @@ 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. - + IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf IF ( present ( nwp_diagnostics ) ) nwp_diagflag = ( nwp_diagnostics > 0 ) - IF ( present ( f_cn ) .and. present( cn ) ) THEN + IF ( present ( f_cn ) .and. present( cn ) ) THEN flag_ccn = f_cn ELSEIF ( present( cn ) ) THEN flag_ccn = .true. ENDIF - + IF ( present( f_qi ) ) THEN flag_qi = f_qi ELSE @@ -2672,14 +2672,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw flag_qi = .false. ENDIF ENDIF - + 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 IF ( PRESENT ( has_reqh ) ) has_reqh_local = has_reqh > 0 - + loopmax = 1 outerloopcnt = 1 lastlooptmp = .true. @@ -2688,7 +2688,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw outerloopcnt = ntcnt lastlooptmp = lastloop ENDIF - + has_wetscav = .false. IF ( wrfchem_flag > 0 ) THEN @@ -2699,18 +2699,18 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( f_cna ) ) THEN f_cnatmp = f_cna - ELSE + ELSE f_cnatmp = .false. ENDIF IF ( present( f_cina ) ) THEN f_cinatmp = f_cina - ELSE + ELSE f_cinatmp = .false. ENDIF - + IF ( present( vzf ) ) vzflag0 = 1 - + IF ( present( ipelectmp ) ) THEN ipelec = ipelectmp ELSE @@ -2741,25 +2741,25 @@ 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 ENDIF IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag - - + + nx = ite-its+1 ny = 1 ! set up as 2D slabs nz = kte-kts+1 ngs = 64 - + IF ( .not. flag_ccn ) THEN renucfrac = 1.0 ENDIF - + ! ENDIF ! itimestep == 1 @@ -2768,7 +2768,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! sedimentation settings infdo = 2 - + IF ( infall .ne. 1 .or. iscfall .ge. 2 ) THEN infdo = 1 ELSE @@ -2817,7 +2817,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO jy = jts,jye - + ! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn IF ( ( present( pcc2 ) .or. present( axtra ) ) .and. makediag ) THEN @@ -2832,7 +2832,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! copy from 3D array to 2D slab - + DO kz = kts,kte DO ix = its,ite IF ( present( tt ) ) THEN @@ -2853,7 +2853,7 @@ 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,kz,jy) 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,kz,jy) @@ -2868,9 +2868,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) ELSE - an(ix,1,kz,lccn) = qccn + an(ix,1,kz,lccn) = qccn ENDIF - + ENDIF ENDIF @@ -2893,7 +2893,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw an(ix,1,kz,lcina) = cni(ix,kz,jy) ENDIF ENDIF - + IF ( ipconc >= 5 ) THEN an(ix,1,kz,lnc) = ccw(ix,kz,jy) IF ( constccw > 0.0 ) THEN @@ -2917,16 +2917,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,kz,jy)*zscale IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,kz,jy)*zscale ENDIF - + ENDDO ENDDO - + DO kz = kts,kte DO ix = its,ite - + IF ( present( tt ) ) THEN t0(ix,1,kz) = tt(ix,kz,jy) ! temperature (Kelvin) ELSE @@ -2938,7 +2938,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw vzf2d(ix,1,kz) = 0.0 ENDDO ENDDO - + DO ix = its,ite RAINNCV(ix,jy) = 0.0 IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = 0.0 @@ -2947,11 +2947,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO DO loopcnt = 1,loopmax - + DO kz = kts,kte DO ix = its,ite - + t1(ix,1,kz) = 0.0 t2(ix,1,kz) = 0.0 t3(ix,1,kz) = 0.0 @@ -2969,7 +2969,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! wmax = Max(wmax,wn(ix,1,kz)) dz2d(ix,1,kz) = dz(ix,kz,jy) dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) - + ltemq = Int( (t0(ix,1,kz)-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) ! @@ -3014,48 +3014,48 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw t7(ix,1,kz) = dn1(ix,1,kz)/rho00*cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1) end if ENDIF - + ! t7max = Max(t7max, t7(ix,1,kz) ) ELSEIF ( icenucopt == 2 ) THEN ! Thompson/Cooper; Note Thompson 2004 has constants of ! 0.005 and 0.304 because the line function was estimated from Cooper plot - ! Here, the fit line values from Cooper 1986 are converted. Very little difference + ! Here, the fit line values from Cooper 1986 are converted. Very little difference ! in practice - + t7(ix,1,kz) = 1000.*0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) ) ! factor of 1000 to convert L**-1 to m**-3 ! write(0,*) 'Cooper t7,ssival = ',ix,kz,t7(ix,1,kz),ssival - + ELSEIF ( icenucopt == 3 ) THEN ! Phillips (Meyers/DeMott) if ( t0(ix,1,kz).le.268.15 .and. t0(ix,1,kz) > 243.15 ) then ! Meyers with factor of Psi=0.06 - + dp1 = 0.06*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) t7(ix,1,kz) = Min(dp1, 1.0d30) elseif ( t0(ix,1,kz) <= 243.15 ) then ! Phillips estimate of DeMott et al (2003) data dp1 = 1000.*( exp( Min( 57.0 ,cnin2a*(ssival-1.1) ) ) )**0.3 t7(ix,1,kz) = Min(dp1, 1.0d30) - + end if ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 - IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN ! - + IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d) ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 ! naer needs units of cm**-3, so mult by 1.e-6 - + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*cin*dn(ix,1,kz))**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) tmp = 1.e-6*naer dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * tmp**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) t7(ix,1,kz) = Min(dp1, 1.0d30) - + ELSE ! t7(ix,1,kz) = 0.0 ENDIF - + ENDIF ! icenucopt @@ -3072,10 +3072,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 ENDIF ENDIF - + ! transform from number mixing ratios to number conc. - + IF ( loopcnt == 1 ) THEN DO il = lnb,na IF ( denscale(il) == 1 ) THEN @@ -3088,10 +3088,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! il ENDIF - + ! sedimentation xfall(:,:,:) = 0.0 - + ! IF ( .true. ) THEN @@ -3113,14 +3113,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( qscuten ) ) ancuten(ix,1,kz,ls) = dtp*qscuten(ix,kz,jy) IF ( present( qicuten ) ) ancuten(ix,1,kz,li) = dtp*qicuten(ix,kz,jy) IF ( present( qccuten ) ) ancuten(ix,1,kz,lc) = dtp*qccuten(ix,kz,jy) - + ENDDO ENDDO - + call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) ENDIF !} - + ENDIF !} @@ -3158,7 +3158,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF 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 ( present( GRPLNCV ) ) 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) ELSE @@ -3189,11 +3189,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF ENDDO - + ENDIF ! isedonly_local ! ENDIF ! .false. - + IF ( isedonly /= 1 ) THEN ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics @@ -3232,15 +3232,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ! isedonly /= 1 - + ! droplet nucleation/condensation/evaporation IF ( .true. ) THEN CALL NUCOND & - & (nx,ny,nz,na,jy & + & (nx,ny,nz,na,jy & & ,nor,nor,dtp,nx & - & ,dz2d & - & ,t0,t9 & - & ,an,dn1,t77 & + & ,dz2d & + & ,t0,t9 & + & ,an,dn1,t77 & & ,pn,wn & & ,ngs & & ,axtra2d, makediag & @@ -3248,13 +3248,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! Clean up tiny values of mixing ratio and final checks on max/min sizes CALL smallvalues & - & (nx,ny,nz,na,jy & + & (nx,ny,nz,na,jy & & ,nor,nor,dtp,nx & - & ,t0 & - & ,an,dn1,wn & + & ,t0 & + & ,an,dn1,wn & & ,t77,flag_qndrop) -! recalculate dn1 after temperature changes +! recalculate dn1 after temperature changes DO kz = kts,kte DO ix = its,ite dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv)) @@ -3299,7 +3299,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( c1 > 0. ) THEN ssat3d(ix,kz,jy) = 100.*(an(ix,1,kz,lv)/c1 - 1.0) ! from "new" values ENDIF - + ENDIF IF ( present( ssati ) .and. nssl_ssat_output >= 2 ) THEN @@ -3316,7 +3316,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! 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 @@ -3327,7 +3327,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0) ENDIF ! .false. - + DO kz = kts,kediagloc ! kte DO ix = its,ite dbz(ix,kz,jy) = dbz2d(ix,1,kz) @@ -3369,10 +3369,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw call calc_eff_radius & - & (nx,ny,nz,na,jy & - & ,nor,nor & + & (nx,ny,nz,na,jy & + & ,nor,nor & & ,t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6 & - & ,f_t4=has_reqr_local,f_t5=has_reqg_local, f_t6=has_reqh_local & + & ,f_t4=has_reqr_local,f_t5=has_reqg_local, f_t6=has_reqh_local & & ,an=an,dn=dn1 ) DO kz = kts,kte @@ -3414,7 +3414,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDIF ENDIF - + ENDIF ENDIF @@ -3434,7 +3434,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! ENDIF ENDIF - + ! transform concentrations back to mixing ratios DO il = lnb,na IF ( denscale(il) == 1 ) THEN @@ -3445,13 +3445,13 @@ 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 - + DO kz = kts,kte DO ix = its,ite - + IF ( present( tt ) ) THEN tt(ix,kz,jy) = t0(ix,1,kz) ELSE @@ -3465,7 +3465,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw qs(ix,kz,jy) = an(ix,1,kz,ls) qh(ix,kz,jy) = an(ix,1,kz,lh) IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) - + IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN ! not used here ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN @@ -3537,10 +3537,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO ! jy - - - + + + @@ -3567,13 +3567,13 @@ REAL FUNCTION GAMMA_SP(xx) & 24.01409824083091d0, & & -1.231739572450155d0, & & 0.1208650973866179d-2,& - & -0.5395239384953d-5/ + & -0.5395239384953d-5/ DATA stp/2.5066282746310005d0/ IF ( xx <= 0.0 ) THEN write(0,*) 'Argument to gamma must be > 0!! xx = ',xx ENDIF - + x = xx y = x tmp = x + 5.5d0 @@ -3597,14 +3597,14 @@ DOUBLE PRECISION FUNCTION GAMMA_DPR(x) implicit none real :: x double precision :: xx - + xx = x - + gamma_dpr = gamma_dp(xx) - + return end FUNCTION GAMMA_DPR - + @@ -3618,7 +3618,7 @@ real function GAMXINF(A1,X1) ! Purpose: Compute the incomplete gamma function ! from x to infinity ! Input : a --- Parameter ( a 170 ) -! x --- Argument +! x --- Argument ! Output: GIM --- gamma(a,x) t=x,Infinity ! Routine called: GAMMA for computing gamma(x) ! =================================================== @@ -3629,7 +3629,7 @@ real function GAMXINF(A1,X1) double precision :: xam,dlog,s,r,ga,t0,a,x integer :: k double precision :: gin, gim - + a = a1 x = x1 IF ( x1 <= 0.0 ) THEN @@ -3663,7 +3663,7 @@ real function GAMXINF(A1,X1) ! GA = GAMMA_SP(A1) ! GIN=GA-GIM ENDIF - + gamxinf = GIM return END function GAMXINF @@ -3678,7 +3678,7 @@ double precision function GAMXINFDP(A1,X1) ! Purpose: Compute the incomplete gamma function ! from x to infinity ! Input : a --- Parameter ( a < 170 ) -! x --- Argument +! x --- Argument ! Output: GIM --- Gamma(a,x) t=x,Infinity ! Routine called: GAMMA for computing gamma_dp(x) ! =================================================== @@ -3691,7 +3691,7 @@ double precision function GAMXINFDP(A1,X1) double precision :: xam,dlog,s,r,ga,t0,a,x integer :: k double precision :: gin, gim - + a = a1 x = x1 IF ( x1 <= 0.0 ) THEN @@ -3725,7 +3725,7 @@ double precision function GAMXINFDP(A1,X1) ! GA = GAMMA_dp(A) ! GIN=GA-GIM ENDIF - + gamxinfdp = GIM return END function GAMXINFDP @@ -3736,22 +3736,22 @@ END function GAMXINFDP !>\ingroup mod_nsslmp !! Function to interpolate from a table of incomplete gamma function values real function gaminterp(ratio, alp, luindex, ilh) - + implicit none real, intent(in) :: ratio, alp integer, intent(in) :: ilh ! 1 = graupel, 2 = hail - integer, intent(in) :: luindex ! which argument: + integer, intent(in) :: luindex ! which argument: ! gamxinflu(i,j,1,1) = x/y ! gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y ! gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y ! gamxinflu(i,j,5,1) = gamxinf( 5.0+alp, ratio )/y ! gamxinflu(i,j,6,1) = gamxinf( 5.5+alp+0.5*bxh, ratio )/y - + real :: delx, dely, tmp1, tmp2, temp3 integer :: i,j,ip1,jp1 !,ilh - + ! ilh = Abs(ilh0) @@ -3762,39 +3762,39 @@ real function gaminterp(ratio, alp, luindex, ilh) ip1 = Min( i+1, nqiacrratio ) jp1 = Min( j+1, nqiacralpha ) - ! interpolate along x, i.e., ratio; + ! interpolate along x, i.e., ratio; tmp1 = gamxinflu(i,j,luindex,ilh) + delx*dqiacrratioinv* & & (gamxinflu(ip1,j,luindex,ilh) - gamxinflu(i,j,luindex,ilh)) tmp2 = gamxinflu(i,jp1,luindex,ilh) + delx*dqiacrratioinv* & & (gamxinflu(ip1,jp1,luindex,ilh) - gamxinflu(i,jp1,luindex,ilh)) - - ! interpolate along alpha; - + + ! interpolate along alpha; + gaminterp = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1)) - + ! debug ! IF ( ilh0 < 0 ) THEN ! write(0,*) 'gaminterp: ',i,j,ilh,ratio,delx,dely,gamxinflu(i,j,luindex,ilh),tmp1,tmp2 ! ENDIF - + END FUNCTION gaminterp ! ##################################################################### -!**************************** GAML02 *********************** +!**************************** GAML02 *********************** ! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio -! It is used for qiacr with the gamma of volume to calculate what +! 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) ! ********************************************************** !>\ingroup mod_nsslmp !! Function calculates Gamma(0.2,x)/Gamma[0.2] for 40 micro drops ( imurain == 3 ) - real FUNCTION GAML02(x) + real FUNCTION GAML02(x) implicit none integer ig, i, ii, n, np real x integer ng parameter(ng=12) real gamxg(ng), xg(ng) - DATA xg/0.01,0.02,0.025,0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA xg/0.01,0.02,0.025,0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ DATA gamxg/ & & 7.391019203578037e-8,0.02212726874591478,0.06959352407989682, & & 0.2355654024970809,0.46135930387500346,0.545435791452399, & @@ -3815,18 +3815,18 @@ real FUNCTION GAML02(x) n = i np = n + 1 IF ( x .ge. xg(i) ) THEN -! GOTO 2 +! GOTO 2 gaml02 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & - & ( gamxg(NP) - gamxg(N) ) + & ( gamxg(NP) - gamxg(N) ) RETURN ENDIF ENDDO RETURN END FUNCTION GAML02 -!**************************** GAML02d300 *********************** +!**************************** GAML02d300 *********************** ! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio -! It is used for qiacr with the gamma of volume to calculate what +! 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) ! ********************************************************** !>\ingroup mod_nsslmp @@ -3838,7 +3838,7 @@ real FUNCTION GAML02d300(x) integer ng parameter(ng=9) real gamxg(ng), xg(ng) - DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ DATA gamxg/ & & 0.0, & & 7.391019203578011e-8,0.0002260640810600053, & @@ -3859,9 +3859,9 @@ real FUNCTION GAML02d300(x) n = i np = n + 1 IF ( x .ge. xg(i) ) THEN -! GOTO 2 +! GOTO 2 GAML02d300 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & - & ( gamxg(NP) - gamxg(N) ) + & ( gamxg(NP) - gamxg(N) ) RETURN ENDIF ENDDO @@ -3872,21 +3872,21 @@ END FUNCTION GAML02d300 ! ##################################################################### ! ##################################################################### -!**************************** GAML02 *********************** +!**************************** GAML02 *********************** ! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio -! It is used for qiacr with the gamma of volume to calculate what +! 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) ! ********************************************************** !>\ingroup mod_nsslmp !! Function calculates Gamma(0.2,x)/Gamma[0.2] for 500 micro drops ( imurain == 3 ) - real FUNCTION GAML02d500(x) + real FUNCTION GAML02d500(x) implicit none integer ig, i, ii, n, np real x integer ng parameter(ng=9) real gamxg(ng), xg(ng) - DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ DATA gamxg/ & & 0.0,0.0, & & 2.2346039e-13, 0.0221272687459, & @@ -3906,9 +3906,9 @@ real FUNCTION GAML02d500(x) n = i np = n + 1 IF ( x .ge. xg(i) ) THEN -! GOTO 2 +! GOTO 2 GAML02d500 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & - & ( gamxg(NP) - gamxg(N) ) + & ( gamxg(NP) - gamxg(N) ) RETURN ENDIF ENDDO @@ -3935,7 +3935,7 @@ real function BETA(P,Q) implicit none double precision p1,gp,q1,gq, ppq,gpq real p,q - + p1 = p q1 = q CALL GAMMADP(P1,GP) @@ -3964,7 +3964,7 @@ DOUBLE PRECISION FUNCTION GAMMA_DP(xx) & 24.01409824083091d0, & & -1.231739572450155d0, & & 0.1208650973866179d-2,& - & -0.5395239384953d-5/ + & -0.5395239384953d-5/ DATA stp/2.5066282746310005d0/ x = xx @@ -3995,11 +3995,11 @@ SUBROUTINE GAMMADP(X,GA) ! ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none - + double precision, parameter :: PI=3.141592653589793D0 double precision :: x,ga,z,r,gr integer :: k,m1,m - + double precision :: G(26) DATA G/1.0D0,0.5772156649015329D0, & @@ -4014,7 +4014,7 @@ SUBROUTINE GAMMADP(X,GA) & .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 GA=1.0D0 @@ -4059,7 +4059,7 @@ END SUBROUTINE GAMMADP !>\ingroup mod_nsslmp !! Function calculates collection coefficients following Siefert (2006) Function delbk(bb,nu,mu,k) -! +! ! Purpose: Caluculates collection coefficients following Siefert (2006) ! ! delbk is equation (90) (b collecting b -- self-collection) @@ -4077,7 +4077,7 @@ Function delbk(bb,nu,mu,k) real delbk real nu, mu, bb integer k - + real tmp, del real x1, x2, x3, x4 integer i @@ -4096,7 +4096,7 @@ Function delbk(bb,nu,mu,k) i = Int(dgami*(tmp)) del = tmp - dgam*i x3 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - + ! delbk = & ! & ((Gamma_sp((1.0 + nu)/mu)/Gamma_sp((2.0 + nu)/mu))**(2.0*bb + k)* & ! & Gamma_sp((1.0 + 2.0*bb + k + nu)/mu))/Gamma_sp((1.0 + nu)/mu) @@ -4104,10 +4104,10 @@ Function delbk(bb,nu,mu,k) delbk = & & ((x1/x2)**(2.0*bb + k)* & & x3)/x1 - + RETURN END Function delbk - + ! ##################################################################### ! ! @@ -4116,18 +4116,18 @@ END Function delbk !>\ingroup mod_nsslmp !! Function calculates collection coefficients following Siefert (2006) Function delabk(ba,bb,nua,nub,mua,mub,k) - + implicit none real delabk real nua, mua, ba integer k real nub, mub, bb - + integer i real tmp,del - + real g1pnua, g2pnua, g1pbapnua, g1pbbpk, g1pnub, g2pnub - + tmp = (1. + nua)/mua i = Int(dgami*(tmp)) del = tmp - dgam*i @@ -4167,8 +4167,8 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) & g1pbapnua* & & (g1pnub/g2pnub)**(bb + k)* & & g1pbbpk)/ & - & (g1pnua*g1pnub) - + & (g1pnua*g1pnub) + RETURN END Function delabk @@ -4178,9 +4178,9 @@ END Function delabk ! HAILMAXD - calculated maximum expected hail size ! ####################################################################### !>\ingroup mod_nsslmp -!! Hail max size subroutine. +!! Hail max size subroutine. subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & - & hailmax1d,hailmaxk1,jslab ) + & hailmax1d,hailmaxk1,jslab ) ! ! Calculate maximum hail size from the tail of of the distribution. The value ! of thresh_conc sets the minimum concentration in the integral over (Dmax, Inf). @@ -4196,7 +4196,7 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & integer nx,ny,nz,nor,norz,ngt,jgs,na,ia integer id ! =1 use density, =0 no density ! integer :: its,ite ! x-range to calculate - + integer ng1 parameter(ng1 = 1) @@ -4209,17 +4209,17 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & real :: hailmax1d(nx,ny),hailmaxk1(nx,ny) integer infdo integer jslab ! which line of xfall to use - + integer ix,jy,kz,ndfall,n,k,il,in double precision :: tmp, ratio, del, g1palp real, parameter :: dz = 200. real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) - + real :: rhovtzx(nz,nx) real :: alp, diam, diam1, hwdn - + ! real, parameter :: cmin = 0.001 ! threshold number per m^3 for maximum diamter (threshold from diag_nwp) DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.0005d0 ! number conc. of graupel/hail per cubic meter real :: cwchtmp,cwchltmp, maxdia @@ -4287,7 +4287,7 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1) ! cxd1 = cx(mgs,lh)*(tmp)/g1palp ! tmp = thresh_conc*g1palp/cx - ! + ! tmp = thresh_conc*g1palp/an(ix,jy,kz,lnh) alp = alpha2d(ix,1,kz,2) ! gamxinflu(i,j,luindex,ilh) @@ -4305,7 +4305,7 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & exit ENDIF ENDDO - + IF ( ratio > 0.0 ) THEN maxdia = ratio*diam1 ! units of m ENDIF @@ -4320,10 +4320,10 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & ! gamxinflu(4,j,1,1) ! ENDIF ENDIF - + hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) - ! + ! ENDIF @@ -4358,7 +4358,7 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1) ! cxd1 = cx(mgs,lh)*(tmp)/g1palp ! tmp = thresh_conc*g1palp/cx - ! + ! tmp = thresh_conc*g1palp/an(ix,jy,kz,lnhl) alp = alpha2d(ix,1,kz,3) ! gamxinflu(i,j,luindex,ilh) @@ -4376,7 +4376,7 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & exit ENDIF ENDDO - + IF ( ratio > 0.0 ) THEN maxdia = ratio*diam1 ! units of m ENDIF @@ -4391,10 +4391,10 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & ! gamxinflu(4,j,1,1) ! ENDIF ENDIF - + hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) - ! + ! ENDIF @@ -4424,7 +4424,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & 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 - + integer ng1 parameter(ng1 = 1) @@ -4440,7 +4440,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & real xfall(nx,ny,na) ! array for stuff landing on the ground integer infdo integer jslab ! which line of xfall to use - + integer ix,jy,kz,ndfall,n,k,il,in real tmp, vtmax, dtptmp, dtfrac real, parameter :: dz = 200. @@ -4448,13 +4448,13 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) ! db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) real, allocatable :: rhovtzx(:,:) real, allocatable :: xfall0(:,:), xvt(:,:,:,:),tmpn(:,:,:),tmpn2(:,:,:),z(:,:,:) - + double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy double precision :: dt1,dt2,dt3,dt4 integer :: ngs ! = 512 integer :: ngscnt,mgs,ipconc0 - + real, allocatable :: qx(:,:) real, allocatable :: qxw(:,:) @@ -4470,22 +4470,22 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & logical, allocatable :: hasmass(:,:) integer, allocatable :: igs(:),kgs(:) - + real, allocatable :: rho0(:),temcg(:) real, allocatable :: temg(:) - + real, allocatable :: rhovt(:) - + real, allocatable :: cwnc(:),cinc(:) real, allocatable :: fadvisc(:),cwdia(:),cipmas(:) - + real, allocatable :: cnina(:),cimas(:) - + real, allocatable :: cnostmp(:) - + real :: cimasn,cimasx - + !----------------------------------------------------------------------------- @@ -4501,7 +4501,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & allocate( tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz), z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)) ngs = nz+3 - + allocate( qx(ngs,lv:lhab), & qxw(ngs,ls:lhab), & cx(ngs,lc:lhab), & @@ -4552,7 +4552,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO kz = kzb,kze DO ix = ixb,ixe dtz1(kz,ix,0) = dz3dinv(ix,jy,kz) - dtz1(kz,ix,1) = dz3dinv(ix,jy,kz)*db1inv(ix,kz) + dtz1(kz,ix,1) = dz3dinv(ix,jy,kz)*db1inv(ix,kz) dz2dinv(kz,ix) = dz3dinv(ix,jy,kz) ENDDO ENDDO @@ -4565,7 +4565,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ENDIF - + DO il = lc+1,lhab DO ix = ixb,ixe ! hasmass(ix,il) = Any( an(ix,jy,:,il) > qxmin(il) ) @@ -4579,15 +4579,15 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! loop over columns DO ix = ixb,ixe - + dummy = 0.d0 - - call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & - & xvt, rhovtzx, & - & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & - & cwradn, & - & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & & cnostmp, & @@ -4606,14 +4606,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & vtmax = 0.0 - + do kz = kzb,kze ! apply limit vtmaxsed (08/20/2015) xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) - + vtmax = Max(vtmax,xvt(kz,ix,1,il)*dz2dinv(kz,ix)) vtmax = Max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix)) vtmax = Max(vtmax,xvt(kz,ix,3,il)*dz2dinv(kz,ix)) @@ -4621,19 +4621,19 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! IF ( dtp*xvt(kz,ix,1,il)*dz2dinv(kz,ix) >= 0.7 .or. & ! & dtp*xvt(kz,ix,2,il)*dz2dinv(kz,ix) >= 0.7 .or. & ! & dtp*xvt(kz,ix,3,il)*dz2dinv(kz,ix) >= 0.7 ) THEN -! +! ! zmaxsed = Max(zmaxsed, float(kz) ) !! plo = Min(plo,kz) !! phi = Max(phi,kz) -! +! ! ENDIF - + ENDDO - + IF ( vtmax == 0.0 ) CYCLE - + IF ( dtp*vtmax .lt. 0.7 ) THEN ! check whether multiple steps are needed. ndfall = 1 ELSE @@ -4643,7 +4643,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ndfall = 1+Int(dtp*vtmax + 0.301) ENDIF ENDIF - + IF ( ndfall .gt. 1 ) THEN dtptmp = dtp/Real(ndfall) ! write(0,*) 'subdivide fallout on its,jts,ix,plo,phi = ',its,jts,ix,plo,phi @@ -4651,7 +4651,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ELSE dtptmp = dtp ENDIF - + dtfrac = dtptmp/dtp @@ -4661,16 +4661,16 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ! zero the precip flux arrays (2d) ! - + 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, & - & xvt, rhovtzx, & - & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & - & cwradn, & - & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & & cnostmp, & @@ -4691,7 +4691,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & 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, & + 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 @@ -4699,7 +4699,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! mixing ratio - call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & & an,db1,il,1,xfall,dtz1,ix) @@ -4709,7 +4709,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & IF ( ldovol .and. il >= li ) THEN IF ( lvol(il) .gt. 1 ) THEN - call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & & an,db1,lvol(il),0,xfall,dtz1,ix) ENDIF ENDIF @@ -4718,14 +4718,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & IF ( ipconc .ge. 6 ) THEN IF ( lz(il) .gt. 1 ) THEN - call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & & an,db1,lz(il),0,xfall,dtz1,ix) ENDIF ENDIF if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' - + IF ( ipconc .gt. 0 ) THEN !{ IF ( ipconc .ge. ipc(il) ) THEN @@ -4743,7 +4743,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO kz = kzb,kze tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) ENDDO - + ELSE ! set up for method II only DO kz = kzb,kze @@ -4760,41 +4760,41 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & in = 2 IF ( linfall(il) .eq. 1 ) in = 1 - call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & + 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 ( linfall(il) >= 2 ) THEN + IF ( linfall(il) >= 2 ) THEN xfall0(:,jgs) = 0.0 - IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) & .or. (il .eq. ls .and. isfall .eq. infall) ) ) THEN - call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & & tmpn2,db1,1,0,xfall0,dtz1,ix) - call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & & tmpn,db1,1,0,xfall0,dtz1,ix) ELSE - call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & & tmpn,db1,1,0,xfall0,dtz1,ix) ENDIF 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 + ! 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, & + 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 ( linfall(il) .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN DO kz = kzb,kze 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 @@ -4804,7 +4804,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ENDIF !} ENDIF - + ENDIF !} lz(il) .lt. 1 ENDIF ! ipconc > ipc @@ -4815,7 +4815,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ! n=1,ndfall ENDDO ! il - + ENDDO ! ix @@ -4886,7 +4886,7 @@ subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & real db1(nx,nz+1),dtz1(nz+1,nx,0:1) ! Local - + integer ix,jy,kz,n,k integer iv1,iv2 real tmp @@ -4920,17 +4920,17 @@ subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & ix = ixcol qtmp1(nz+1) = 0.0 - + DO kz = kzb,kze ! DO ix = ixb,ixe -! cmax = Max(cmax, vt(ix,kz)*dz3dinv(ix,jy,kz)) - +! cmax = Max(cmax, vt(ix,kz)*dz3dinv(ix,jy,kz)) + IF ( id == 1 ) THEN qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)*db1(ix,kz) ELSE qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix) ENDIF - + IF ( a(ix,jgs,kz,ia) .ne. 0.0 ) THEN ! imn = Min(ix,imn) ! imx = Max(ix,imx) @@ -4939,21 +4939,21 @@ subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & ENDIF ! ENDDO ENDDO - + kmn = Max(1,kmn-1) - + ! first check if fallout is worth doing ! IF ( cmax .eq. 0.0 .or. imn .gt. imx ) THEN ! RETURN ! ENDIF - + IF ( kmn == 1 ) THEN - + kz = 1 ! do ix = imn,imx ! 1,nx-1 xfall(ix,jy,ia) = xfall(ix,jy,ia) + a(ix,jgs,kz,ia)*vt(kz,ix)*dtfrac ! enddo - + ENDIF do kz = 1,nz @@ -4962,7 +4962,7 @@ subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & ! enddo enddo - + RETURN END SUBROUTINE FALLOUT1D @@ -4998,21 +4998,21 @@ 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 - - + + jy = jgs ix = ixcol - + IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) & .or. ( l .eq. ls .and. imusnow == 1 ) ) THEN - - + + DO kz = 1,kze - - - + + + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN - + IF ( lvol .gt. 1 ) THEN IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) @@ -5045,21 +5045,21 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & ! IF ( ny.eq.2 .and. kz .ge. 25 .and. kz .le. 29 .and. z(ix,kz,l) .gt. 0. ) THEN ! write(*,*) 'calczgr: z,dbz,xdn = ',ix,kz,z(ix,kz,l),10*log10(z(ix,kz,l)),xdn ! ENDIF - + ELSE - + z(ix,kz,l) = 0.0 - + ENDIF - + ENDDO - + ELSEIF ( (l == ls .and. imusnow == 3) .or. ( l .eq. lr .and. imurain == 3 ) ) THEN xdn = rho_qx ! 1000. IF ( l == ls ) ynu = snu IF ( l == lr ) ynu = rnu - + DO kz = 1,kze IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN @@ -5069,26 +5069,26 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & z(ix,kz,l) = 3.6*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0) ! qr = a(ix,jy,kz,lr) ! nrx = a(ix,jy,kz,lnr) - + ELSE - + z(ix,kz,l) = 0.0 - + ENDIF - - + + ENDDO - + ENDIF - + RETURN - + END subroutine calczgr1d ! ############################################################################## ! ############################################################################## ! -! Subroutine to correct number concentration to prevent reflectivity growth by +! Subroutine to correct number concentration to prevent reflectivity growth by ! sedimentation in 2-moment ZXX scheme. ! Calculation is in a slab (constant jgs) ! @@ -5099,7 +5099,7 @@ 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) - + implicit none integer nx,ny,nz,nor,na,ngt,jgs,ixcol @@ -5111,7 +5111,7 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & real z0(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! initial reflectivity real db(nx,nz+1) ! air density - + integer ixe,kze real alpha real qmin @@ -5122,46 +5122,46 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & integer lvol ! index for volume real rho_qx integer infall - - + + integer ix,jy,kz 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 - + IF ( l .eq. lh .or. l .eq. lhl .or. ( l == lr .and. imurain == 1 ) ) THEN - + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) - + DO kz = 1,kze - + IF ( t0(ix,jy,kz) .gt. 0. ) THEN ! { - + IF ( lvol .gt. 1 ) THEN IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) xdn = Min( 900., Max( hdnmn, xdn ) ) - ELSE + ELSE xdn = rho_qx ENDIF ELSE xdn = rho_qx ENDIF - + IF ( l == lr ) xdn = 1000. - + qr = a(ix,jy,kz,l) xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) chw = a(ix,jy,kz,ln) @@ -5174,12 +5174,12 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & zx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw z = zx*(6./(pi*1000.))**2 - + IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN !{ - + zx = t0(ix,jy,kz)/((6./(pi*1000.))**2) - + 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 @@ -5200,7 +5200,7 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & ELSE nnwgt = nnwgt + 1 ENDIF - + a(ix,jy,kz,ln) = Max(Min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) ) ENDIF @@ -5229,20 +5229,20 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & ENDIF ENDIF ENDIF! } - + ENDDO - - + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN xdn = 1000. - + DO kz = 1,kze IF ( t0(ix,jy,kz) .gt. 0. ) THEN vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) z = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) - + IF ( z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & & t0(ix,jy,kz) .gt. 0.0 & & .and. t0(ix,jy,kz) .gt. z0(ix,kz,l) ) THEN @@ -5294,9 +5294,9 @@ 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 ) - - + + implicit none integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol @@ -5310,7 +5310,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & cccn,cccna,vhw,vhl,qv, spechum logical, optional, intent(in) :: invertccn_flag real, optional :: cwmasin - + integer ixe,kze real alpha real qmin @@ -5318,9 +5318,9 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & integer ipconc integer lvol ! index for volume integer infall - - - integer ix,jy,kz + + + integer ix,jy,kz double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv real, parameter :: xn0s = 3.0e8, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 @@ -5340,28 +5340,28 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & logical :: invertccn_local ! ------------------------------------------------------------------ - + IF ( present( invertccn_flag ) ) THEN invertccn_local = invertccn_flag ELSE invertccn_local = .false. ENDIF - + IF ( present( cwmasin ) ) THEN cwmasinv = 1.0/cwmasin ELSE cwmasinv = 1.0/cwmas09 ENDIF - + jy = 1 - - + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) - + IF ( imurain == 3 ) THEN g1r = (rnu+2.0)/(rnu+1.0) ELSE ! imurain == 1 @@ -5411,19 +5411,19 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & IF ( lccna > 1 .and. present( cccna ) ) an(ix,jy,kz,lccna) = cccna(ix,kz)*mixconv dninv = 1./dn(ix,kz) - + ! IF ( .not. present( qcw ) ) THEN ! Cloud droplets - + IF ( lnc > 1 ) THEN IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN - + an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)*cwmasinv )*dn(ix,kz) - + IF ( invertccn_local ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + an(ix,jy,kz,lnc) ELSE - + IF ( lccn > 1 .and. lccna < 1 ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) ENDIF @@ -5434,20 +5434,20 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN - + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) an(ix,jy,kz,lnc) = 0.0 an(ix,jy,kz,lc) = 0.0 - + ENDIF ENDIF ! Cloud ice - + IF ( lni > 1 ) THEN IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin_init(li) ) THEN an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims - + ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) .or. & ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) <= qxmin_init(li)) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) @@ -5457,20 +5457,20 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF ! rain - + IF ( lnr > 1 ) THEN IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin_init(lr) ) THEN q = an(ix,jy,kz,lr) - + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope - + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input - + nrx = n1*g1r/g0 ! number concentration for different shape parameter an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio - + ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. & ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) @@ -5493,11 +5493,11 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN q = an(ix,jy,kz,ls) - + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope - + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input - + nrx = n1*g1s/g0 ! number concentration for different shape parameter an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio @@ -5507,10 +5507,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) an(ix,jy,kz,lns) = 0.0 an(ix,jy,kz,ls) = 0.0 - + ENDIF ENDIF - + ! graupel IF ( lnh > 1 ) THEN @@ -5522,15 +5522,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF q = an(ix,jy,kz,lh) - + laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope - + n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input - + nrx = n1*g1h/g0 ! number concentration for different shape parameter nrx2 = dn(ix,kz) * q / xgms - + nrx = Min( nrx, nrx2 ) IF ( nrx > cxmin ) THEN @@ -5543,10 +5543,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. & ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN - + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) an(ix,jy,kz,lh) = 0.0 - + ENDIF ENDIF @@ -5570,21 +5570,21 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF q = an(ix,jy,kz,lhl) - + laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope - + n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input - + nrx = n1*g1hl/g0 ! number concentration for different shape parameter an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN - + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) an(ix,jy,kz,lhl) = 0.0 - + ENDIF ENDIF @@ -5596,8 +5596,8 @@ 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 ! spechum = qv_mp/(1.0_kind_phys+qv_mp) @@ -5640,15 +5640,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ! ELSE ! write(0,*) 'calcnfromq: lv = ',lv,lc,lr,li,ls,lh,lvh,lhl,lccn,lccna ! write(0,*) 'calcnfromq: nx,ny,nz,na = ',nx,ny,nz,na -! +! ! ENDIF - + ! IF ( present( qsw ) ) THEN ! write(0,*) 'calcnfromq: qsmax = ',qsmax,qsmax2,qsmax3,qsmax4 ! ENDIF - + RETURN - + END subroutine calcnfromq ! ############################################################################## @@ -5665,7 +5665,7 @@ END subroutine calcnfromq !! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio. subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) - + implicit none integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol @@ -5674,7 +5674,7 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) real anold(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) real dn(nx,nz+1) ! air density - + integer ixe,kze real alpha real qmin @@ -5682,8 +5682,8 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) integer ipconc integer lvol ! index for volume integer infall - - + + integer ix,jy,kz double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv @@ -5701,17 +5701,17 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) integer :: ndbz, nmwgt, nnwgt, nwlessthanz ! ------------------------------------------------------------------ - - + + jy = 1 - - + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) - + IF ( imurain == 3 ) THEN g1r = (rnu+2.0)/(rnu+1.0) ELSE ! imurain == 1 @@ -5720,14 +5720,14 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ENDIF g1s = (snu+2.0)/(snu+1.0) - + DO kz = 1,nz DO ix = 1,nx ! ixcol dninv = 1./dn(ix,kz) - + ! Cloud droplets - + IF ( lnc > 1 ) THEN ! IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN IF ( an(ix,jy,kz,lnc) > qxmin(lc) ) THEN @@ -5736,7 +5736,7 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ENDIF ! Cloud ice - + IF ( lni > 1 ) THEN IF ( an(ix,jy,kz,lni) > qxmin(li) ) THEN anold(ix,jy,kz,lni) = anold(ix,jy,kz,lni) + an(ix,jy,kz,li)/xims @@ -5744,18 +5744,18 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ENDIF ! rain - + IF ( lnr > 1 ) THEN IF ( an(ix,jy,kz,lr) > qxmin(lr) ) THEN ! adding rain mass from CU scheme - IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN + IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN q = an(ix,jy,kz,lr) - + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope - + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input - + nrx = n1*g1r/g0 ! number concentration for different shape parameter anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + nrx ! *dninv ! convert to number mixing ratio @@ -5765,7 +5765,7 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) xmass = anold(ix,jy,kz,lr)/anold(ix,jy,kz,lnr) 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 @@ -5776,29 +5776,29 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) IF ( lns > 1 ) THEN IF ( an(ix,jy,kz,ls) > qxmin(ls) ) THEN ! adding snow mass from CU scheme - IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN - + IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN + ! assume that there was no snow before this - + q = an(ix,jy,kz,ls) - + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope - + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input - + nrx = n1*g1s/g0 ! number concentration for different shape parameter anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + nrx ! *dninv ! convert to number mixing ratio - + ELSE ! assume mean particle mass of pre-existing snow xmass = anold(ix,jy,kz,ls)/anold(ix,jy,kz,lns) anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + an(ix,jy,kz,ls)/xmass ENDIF - + ENDIF ENDIF - + ! graupel ! IF ( lnh > 1 ) THEN @@ -5810,11 +5810,11 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ENDIF ! ! q = an(ix,jy,kz,lh) -! +! ! laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope -! +! ! n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input -! +! ! nrx = n1*g1h/g0 ! number concentration for different shape parameter ! ! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio @@ -5836,11 +5836,11 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ENDIF ! ! q = an(ix,jy,kz,lhl) -! +! ! laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope -! +! ! n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input -! +! ! nrx = n1*g1hl/g0 ! number concentration for different shape parameter ! ! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio @@ -5850,12 +5850,12 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ENDIF ! ENDIF ! ENDIF - + ENDDO ! ix ENDDO ! kz - + RETURN - + END subroutine calcnfromcuten ! ##################################################################### @@ -5864,9 +5864,9 @@ END subroutine calcnfromcuten !>\ingroup mod_nsslmp !! Subroutine to calculate effective radii for use by radiation routines SUBROUTINE calc_eff_radius & - & (nx,ny,nz,na,jyslab & - & ,nor,norz & - & ,t1,t2,t3,t4,t5,t6, f_t4, f_t5,f_t6 & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,t1,t2,t3,t4,t5,t6, f_t4, f_t5,f_t6 & & ,qcw,qci,qsw,qrw & & ,ccw,cci,csw,crw & & ,an,dn ) @@ -5894,15 +5894,15 @@ SUBROUTINE calc_eff_radius & real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw + real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw ! local - + real pb(-norz+ng1:nz+norz) real pinit(-norz+ng1:nz+norz) -! +! ! declarations microphysics and for gather/scatter ! integer nxmpb,nzmpb,nxz @@ -5914,7 +5914,7 @@ SUBROUTINE calc_eff_radius & integer ix,kz,i,n, kp1 integer :: jy, jgs integer ixb,ixe,jyb,jye,kzb,kze - + integer itile,jtile,ktile integer ixend,jyend,kzend,kzbeg integer nxend,nyend,nzend,nzbeg @@ -5926,16 +5926,16 @@ SUBROUTINE calc_eff_radius & real :: xdn(ngs,lc:lhab) real :: xdia(ngs,lc:lhab,3) real :: alpha(ngs,lc:lhab) - + real :: gamc1,gamc2,gami1,gami2,gams1,gams2, factor_c, factor_i, factor_s real :: lam_c, lam_i, lam_s, lam_r, lam_h, lam_hl real :: gamr1,gamr2,gamh1,gamh2,factor_r,factor_h,factor_hl integer :: il real :: hwdn,hldn 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 @@ -5952,7 +5952,7 @@ SUBROUTINE calc_eff_radius & nzend = nz kzbeg = 1 nzbeg = 1 - + flag_t4 = .false. flag_t5 = .false. flag_t6 = .false. @@ -6016,8 +6016,8 @@ SUBROUTINE calc_eff_radius & rho0(mgs) = dn(ix,jy,kz) IF ( present( an ) ) THEN DO il = lc,lhab - qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) - cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) + qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) + cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) ENDDO ELSE qx(mgs,:) = 0.0 @@ -6030,17 +6030,17 @@ SUBROUTINE calc_eff_radius & IF ( present(cci) ) cx(mgs,li) = cci(ix,kz)*rho0(mgs) IF ( present(csw) ) cx(mgs,ls) = csw(ix,kz)*rho0(mgs) IF ( present(crw) ) cx(mgs,lr) = crw(ix,kz)*rho0(mgs) - + ENDIF - + IF ( present( t1 ) .and. qx(mgs,lc) > qxmin(lc) .and. cx(mgs,lc) > cxmin ) THEN -! Lambda for cloud droplets +! Lambda for cloud droplets lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) t1(ix,jy,kz) = 0.5*factor_c/lam_c ENDIF IF ( present( t2 ) .and. qx(mgs,li) > qxmin(li) .and. cx(mgs,li) > cxmin ) THEN -! Lambda for cloud ice +! Lambda for cloud ice lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) t2(ix,jy,kz) = 0.5*factor_i/lam_i ENDIF @@ -6066,11 +6066,11 @@ SUBROUTINE calc_eff_radius & ENDIF IF ( present(t5) .and. flag_t5 ) THEN - + ! first: case when hail is off - + IF ( lhl < 1 .or. flag_t6 ) THEN - ! graupel only + ! graupel only IF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) ) THEN ! Lambda for graupel hwdn = xdn0(lh) @@ -6079,13 +6079,13 @@ SUBROUTINE calc_eff_radius & hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF - + 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 ENDIF - + ELSE ! have hail, too, but do not have t6 array - + IF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) < Max(qmin,qxmin(lhl)) ) THEN ! Lambda for graupel hwdn = xdn0(lh) @@ -6097,7 +6097,7 @@ 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(qmin,qxmin(lh)) .and. qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! Lambda for hail hldn = xdn0(lhl) @@ -6112,7 +6112,7 @@ SUBROUTINE calc_eff_radius & 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) > volmin ) THEN @@ -6126,27 +6126,27 @@ SUBROUTINE calc_eff_radius & hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF - + lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) - + numh = cx(mgs,lh)*(alphah+3.)*(alphah+2.)*(alphah+1.)/lam_h**3 numhl = cx(mgs,lhl)*(alphahl+3.)*(alphahl+2.)*(alphahl+1.)/lam_hl**3 - + denomh = cx(mgs,lh)*(alphah+2.)*(alphah+1.)/lam_h**2 denomhl = cx(mgs,lhl)*(alphahl+2.)*(alphahl+1.)/lam_hl**2 - + t5(ix,jy,kz) = 0.5*(numh + numhl)/(denomh + denomhl) ENDIF ! no t6 array - + ENDIF ! lhl - + ENDIF ! flag_t5 - + IF ( present(t6) .and. flag_t6 .and. lhl > 1 ) THEN - + IF ( qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! Lambda for hail hldn = xdn0(lhl) @@ -6155,15 +6155,15 @@ SUBROUTINE calc_eff_radius & hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF - + lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) t6(ix,jy,kz) = 0.5*(alphahl+3.)/lam_hl - + ENDIF - + ENDIF ! t6 - + ENDDO ! ix ENDDO ! kz @@ -6178,7 +6178,7 @@ END SUBROUTINE calc_eff_radius !! Subroutine that returns the maximum possible condensation 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 !##################################################################### @@ -6186,14 +6186,14 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & implicit none integer ngs,mgs,ngscnt - + real theta2temp - + real qvex - + integer nqsat real fqsat, cbw - + real ss1 ! 'target' supersaturation ! ! input arrays @@ -6202,12 +6202,12 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & real thetap0(ngs), theta0(ngs) real fcqv1(ngs), felvcp(ngs), pi0(ngs) real pk(ngs) - + real tabqvs(nqsat) ! ! Local stuff ! - + integer itertd integer ltemq real gamss, tmp @@ -6215,10 +6215,10 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs) real dqcw(ngs), dqwv(ngs), dqvcnd(ngs) real temg(ngs), temcg(ngs), thetap(ngs) - + real tfr parameter ( tfr = 273.15 ) - + ! real poo,cap ! parameter ( cap = rd/cp, poo = 1.0e+05 ) ! @@ -6241,7 +6241,7 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & ! ! reset temporaries for cloud particles and vapor ! - + qwv(mgs) = max( 0.0, qvap(mgs) ) qcw(mgs) = max( 0.0, qcw1(mgs) ) ! @@ -6356,10 +6356,10 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & implicit none - + integer ngscnt,ngs0,ngs,nz ! integer infall ! whether to calculate number-weighted fall speeds - + real xv(ngs,lc:lhab) real qx(ngs,lv:lhab) real qxw(ngs,ls:lhab) @@ -6373,31 +6373,31 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & real qxmin(lc:lhab) real cdx(lc:lhab) real alpha(ngs,lc:lhab) - + real rho0(ngs),rhovt(ngs),temcg(ngs) real cno(lc:lhab) real cnostmp(ngs) - + real cwc1, cimna, cimxa real cnina(ngs) integer igs(ngs),kgs(ngs) real fadvisc(ngs) real fsw - + integer ipconc1 integer ndebug1 - + integer, intent (in) :: itype1a,itype2a,infdo integer, intent (in) :: ildo ! which species to do, or all if ildo=0 real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) !! real :: axh(ngs),bxh(ngs) ! real :: axhl(ngs),bxhl(ngs) - + ! Local vars - - + + real swmasmx, dtmp real cd real cwc0 ! ,cwc1 @@ -6409,11 +6409,11 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & real cwrad real vr,rnux real alp - + real ccimx integer mgs - + real arx,frx,vtrain,fw real fwlo,fwhi,rfwdiff real ar,br,cs,ds @@ -6427,7 +6427,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! save gf4p5, gf4ds, gf4br, ifirst, gf1ds ! save gfcinu1, gfcinu1p47, gfcinu2p47 ! data ifirst /0/ - + real bta1,cnit parameter ( bta1 = 0.6, cnit = 1.0e-02 ) real x,y,tmp,del @@ -6451,14 +6451,14 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & fwlo = 0.2 ! water fraction to start weighting toward rain fall speed fwhi = 0.4 ! water fraction at which rain fall speed only is used rfwdiff = 1./(fwhi - fwlo) - + ! pi = 4.0*atan(1.0) pii = piinv ! 1.0/pi arx = 10. frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. - ar = 841.99666 + ar = 841.99666 br = 0.8 gr = 9.8 ! new values for cs and ds @@ -6482,7 +6482,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! gfcinu1 = gamma(cinu + 1.0) ! gfcinu1p47 = gamma(cinu + 1.47167) ! gfcinu2p47 = gamma(cinu + 2.47167) - + IF ( lh .gt. 1 ) THEN IF ( dmuh == 1.0 ) THEN cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) @@ -6499,11 +6499,11 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ENDIF IF ( ipconc .le. 5 ) THEN - IF ( lh .gt. 1 ) cwch(:) = cwchtmp + IF ( lh .gt. 1 ) cwch(:) = cwchtmp IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp ELSE DO mgs = 1,ngscnt - + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN IF ( dmuh == 1.0 ) THEN @@ -6528,11 +6528,11 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & cwchl(mgs) = cwchltmp ENDIF ENDIF - + ENDDO - + ENDIF - + cimasn = Min( cimas0, 6.88e-13) cimasx = 1.0e-8 @@ -6542,7 +6542,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & cwc0 = pii ! 6.0*pii mwfac = 6.0**(1./3.) - + if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter' ! @@ -6555,14 +6555,14 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! ! if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables' - + IF ( ildo == 0 .or. ildo == lc ) THEN - + do mgs = 1,ngscnt xv(mgs,lc) = 0.0 - + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{ - + IF ( ipconc .ge. 2 ) THEN IF ( cx(mgs,lc) .gt. cxmin) THEN !{ xmas(mgs,lc) = & @@ -6572,7 +6572,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) xmas(mgs,lc) = Min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) - + ENDIF ELSE IF ( ipconc .lt. 2 ) THEN @@ -6582,10 +6582,10 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & xmas(mgs,lc) = & & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & & xdn(mgs,lc)*xvmx(lc) ) - + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) - + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 1.0e-9 ) THEN cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) xmas(mgs,lc) = & @@ -6596,7 +6596,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) - + ELSE xmas(mgs,lc) = cwmasn xv(mgs,lc) = xmas(mgs,lc)/1000. @@ -6623,7 +6623,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,lc,1) = 0.0 ENDIF - + ELSE xmas(mgs,lc) = cwmasn xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) @@ -6633,11 +6633,11 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & xdia(mgs,lc,2) = 4.*cwradn**2 xdia(mgs,lc,3) = xdia(mgs,lc,1) vtxbar(mgs,lc,1) = 0.0 - + ENDIF !} qcw .gt. qxmin(lc) - + end do - + ENDIF @@ -6651,7 +6651,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! CLOUD ICE ! if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip' - + IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN do mgs = 1,ngscnt xdn(mgs,li) = 900.0 @@ -6673,7 +6673,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & cx(mgs,li) = max(1.0e-20,cx(mgs,li)) ! cx(mgs,li) = Min(ccimx, cx(mgs,li)) - + ELSEIF ( ipconc .ge. 1 ) THEN IF ( qx(mgs,li) .gt. qxmin(li) ) THEN cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) @@ -6681,12 +6681,12 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! cx(mgs,li) = Max(1.0,cx(mgs,li)) ENDIF ENDIF - + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN xmas(mgs,li) = & & max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn ) ! & min( max(qx(mgs,li)*rho0(mgs)/cx(mgs,li),cimasn),cimasx ) - + ! if ( temcg(mgs) .gt. 0.0 ) then ! xdia(mgs,li,1) = 0.0 ! else @@ -6717,29 +6717,29 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) vtxbar(mgs,li,2) = tmp*gfcinu1p47 vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) - vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) ELSEIF ( ixtaltype == 2 ) THEN ! disk -- but just use Ferrier (1994) snow fall speeds for now vtxbar(mgs,li,1) = 11.9495*rhovt(mgs)*(xv(mgs,li))**(0.14) vtxbar(mgs,li,2) = 7.02909*rhovt(mgs)*(xv(mgs,li))**(0.14) - vtxbar(mgs,li,3) = vtxbar(mgs,li,1) - + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + ENDIF - + ELSEIF ( icefallopt == 2 ) THEN ! ! Ferrier ice fall speed tmp = (82.3166*rhovt(mgs))/ & & (((1.0 + cinu)/xv(mgs,li))**0.22117*gfcinu1) vtxbar(mgs,li,2) = tmp*gfcinu1p22 vtxbar(mgs,li,1) = tmp*gfcinu2p22/(1. + cinu) - vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) ELSEIF ( icefallopt == 3 ) THEN ! ! Adjusted Ferrier (smaller exponent of 0.55 instead of 0.6635) - + tmp = (47.6273*rhovt(mgs))/ & & (((1.0 + cinu)/xv(mgs,li))**0.18333*gfcinu1) vtxbar(mgs,li,2) = tmp*gfcinu1p18 vtxbar(mgs,li,1) = tmp*gfcinu2p18/(1. + cinu) - vtxbar(mgs,li,3) = vtxbar(mgs,li,1) - + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + ENDIF ! vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu) ! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) @@ -6767,17 +6767,17 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! cicap(mgs) = 0.0 ! ciat(mgs) = 0.0 ENDIF - + IF ( icefallfac /= 1.0 ) THEN vtxbar(mgs,li,1) = icefallfac*vtxbar(mgs,li,1) vtxbar(mgs,li,2) = icefallfac*vtxbar(mgs,li,2) vtxbar(mgs,li,3) = icefallfac*vtxbar(mgs,li,3) ENDIF - - + + end do - + ENDIF ! li .gt. 1 @@ -6785,15 +6785,15 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! ! RAIN ! - + ! IF ( ildo == 0 .or. ildo == lr ) THEN do mgs = 1,ngscnt if ( qx(mgs,lr) .gt. qxmin(lr) ) then - + ! IF ( qx(mgs,lr) .gt. 10.0e-3 ) & ! & write(0,*) 'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr) - + if ( ipconc .ge. 3 ) then xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) xvbarmax = xvmx(lr) @@ -6803,16 +6803,16 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & IF ( imurain == 1 ) THEN xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) ELSEIF ( imurain == 3 ) THEN - + ENDIF ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter IF ( imurain == 1 ) THEN xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) ELSEIF ( imurain == 3 ) THEN - + ENDIF ENDIF - + IF ( xv(mgs,lr) .gt. xvbarmax ) THEN xv(mgs,lr) = xvbarmax cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr)) @@ -6838,7 +6838,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! & /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) ELSE xdia(mgs,lr,1) = & - & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) @@ -6853,7 +6853,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & xdia(mgs,lr,2) = xdia(mgs,lr,1)**2 ! xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 end do - + ENDIF ! ################################################################ ! @@ -6861,10 +6861,10 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN - - do mgs = 1,ngscnt + + do mgs = 1,ngscnt if ( qx(mgs,ls) .gt. qxmin(ls) ) then - if ( ipconc .ge. 4 ) then ! + if ( ipconc .ge. 4 ) then ! xmas(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(Max(1.0e-9,cx(mgs,ls))) swmasmx = 13.7e-6 @@ -6874,10 +6874,10 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! ENDIF IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship - + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) xdn(mgs,ls) = Max( 100.0, xdn(mgs,ls) ) ! limit snow to 100. to keep other equations in line - + IF ( xdn(mgs,ls) <= 900. ) THEN dtmp = Sqrt( xmas(mgs,ls)/0.069 ) ! diameter (meters) of mean mass particle using Cox 1998 relation (m = p d^2) xv(mgs,ls) = 28.8887*xmas(mgs,ls)**(3./2.) @@ -6886,7 +6886,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) ENDIF - + ELSE ! leave xdn(ls) at default value xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) @@ -6906,14 +6906,14 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & xmas(mgs,ls) = 0.106214*xv(mgs,ls)**(2./3.) cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) - xdia(mgs,ls,1) = Sqrt( xmas(mgs,ls)/0.069 ) + xdia(mgs,ls,1) = Sqrt( xmas(mgs,ls)/0.069 ) ENDIF xdia(mgs,ls,3) = xdia(mgs,ls,1) ELSE xdia(mgs,ls,1) = & - & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) + & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1) xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) @@ -6922,7 +6922,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & xdia(mgs,ls,1) = 1.e-9 xdia(mgs,ls,3) = 1.e-9 cx(mgs,ls) = 0.0 - + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship xdn(mgs,ls) = 90. ENDIF @@ -6932,7 +6932,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1) ! xmas(mgs,ls) = xdn(mgs,ls)*(pi/6.)*swdia3(mgs) end do - + ENDIF ! ls .gt 1 ! ! @@ -6942,8 +6942,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN - - do mgs = 1,ngscnt + + do mgs = 1,ngscnt if ( qx(mgs,lh) .gt. qxmin(lh) ) then if ( ipconc .ge. 5 ) then @@ -6965,10 +6965,10 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSE xdia(mgs,lh,1) = & - & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) + & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) - xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) end if else xdia(mgs,lh,1) = 1.e-9 @@ -6978,7 +6978,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) ! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) end do - + ENDIF ! @@ -6988,8 +6988,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN - - do mgs = 1,ngscnt + + do mgs = 1,ngscnt if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then if ( ipconc .ge. 5 ) then @@ -7009,14 +7009,14 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSE xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.) ENDIF - + ! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xdia(mgs,lhl,3) ELSE xdia(mgs,lhl,1) = & - & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) + & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1) xv(mgs,lhl) = Max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ) - xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) end if else xdia(mgs,lhl,1) = 1.e-9 @@ -7026,9 +7026,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) ! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) end do - + ENDIF -! +! ! ! ! Set terminal velocities... @@ -7057,40 +7057,40 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs) ! write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs) ELSE - + IF ( imurain == 1 ) THEN ! DSD of Diameter - + ! using functional form of arx*(1 - Exp(-frx*diameter) ), with arx = arx = 10. ! and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. ! Similar form as in Atlas et al. (1973), who had 9.65 - 10.3*Exp[-600 * d] - + alp = alpha(mgs,lr) - + vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted - + IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted ELSE vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) ENDIF - + IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted ELSE vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) ENDIF - + ! write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr) ELSEIF ( imurain == 3 ) THEN ! DSD of Volume - + IF ( lzr < 1 ) THEN ! not 3-moment rain rwdia = Min( xdia(mgs,lr,1), 8.0e-3 ) - + vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia - & & 1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4) - + IF ( infdo .ge. 1 ) THEN IF ( rssflg >= 1 ) THEN vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 + & @@ -7099,7 +7099,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) ENDIF ENDIF - + IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed vtxbar(mgs,lr,3) = rhovt(mgs)*( & & 0.0911229 + & @@ -7108,12 +7108,12 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & 4.944093e8*(rwdia**3) - & & 2.631718e10*(rwdia**4) ) ENDIF - + ELSE ! 3-moment rain, gamma-volume vr = xv(mgs,lr) rnux = alpha(mgs,lr) - + IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag vtxbar(mgs,lr,2) = rhovt(mgs)* & & (((1. + rnux)/vr)**(-1.333333)* & @@ -7137,12 +7137,12 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & 8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(3 + rnux) - & & 2.3303765697228556e9*vr**1.3333333333333333* & & Gamma_sp(3.333333333333333 + rnux))/ & - & ((1 + rnux)**2.333333333333333*Gamma_sp(1 + rnux)) - + & ((1 + rnux)**2.333333333333333*Gamma_sp(1 + rnux)) + IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) - ENDIF - + ENDIF + IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed vtxbar(mgs,lr,3) = rhovt(mgs)* & & ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(3. + rnux) + & @@ -7154,15 +7154,15 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & 2.3303765697228556e9*vr**1.3333333333333333* & & Gamma_sp(4.333333333333333 + rnux)))/ & & ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma_sp(1 + rnux)) - + ! write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo ! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) - + ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) ENDIF - - + + ENDIF ENDIF ! imurain @@ -7183,7 +7183,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & end if end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt' - + ENDIF ! ! ################################################################ @@ -7204,13 +7204,13 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & IF ( isnowdens == 1 ) THEN vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14) ELSE - vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) ENDIF ELSEIF ( isnowfall == 3 ) THEN ! Cox, mass distrib: vtxbar(mgs,ls,1) = 50.092*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) ENDIF - + IF(Abs(sssflg) >= 1) THEN IF ( isnowfall == 1 ) THEN vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.) @@ -7238,12 +7238,12 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,ls,3) = 61.0914*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) ENDIF ENDIF - + IF ( sssflg < 0 .and. temcg(mgs) > Abs(sssflg) ) THEN ! above a given temperature, effectively turn off size sorting vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1) ENDIF - + endif ELSE ! single-moment: vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) @@ -7262,7 +7262,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt' - + ENDIF ! ls .gt. 1 ! ! @@ -7271,7 +7271,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! GRAUPEL !Wisner et al. (1972) ! IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN - + do mgs = 1,ngscnt vtxbar(mgs,lh,1) = 0.0 if ( qx(mgs,lh) .gt. qxmin(lh) ) then @@ -7294,33 +7294,33 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1 indxr = Min( ngdnmm, Max(1,indxr) ) - - + + delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) IF ( indxr < ngdnmm ) THEN - + axx(mgs,lh) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) bxx(mgs,lh) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) - + ELSE axx(mgs,lh) = mmgraupvt(indxr,2) bxx(mgs,lh) = mmgraupvt(indxr,3) ENDIF - + aax = axx(mgs,lh) bbx = bxx(mgs,lh) cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) - - ELSEIF ( icdx <= 0 ) THEN ! + + ELSEIF ( icdx <= 0 ) THEN ! aax = ax(lh) bbx = bx(lh) cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) ELSE cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) ENDIF - + cdxgs(mgs,lh) = cd IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN ! axx(mgs,lh) = (gf4p5/6.0)* & @@ -7328,7 +7328,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! & (3.0*cd*rho0(mgs)) ) axx(mgs,lh) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) bxx(mgs,lh) = 0.5 - vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lh) * Sqrt(xdia(mgs,lh,1)) + vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lh) * Sqrt(xdia(mgs,lh,1)) ! vtxbar(mgs,lh,1) = (gf4p5/6.0)* & ! & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / & ! & (3.0*cd*rho0(mgs)) ) @@ -7343,10 +7343,10 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & i = Int(dgami*(tmp)) del = tmp - dgam*i y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - + ! aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) ) ! vtxbar(mgs,lh,1) = rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y - + IF ( icdx > 0 .and. icdx /= 6) THEN aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y @@ -7357,7 +7357,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSE ! icdx < 0 axx(mgs,lh) = ax(lh) bxx(mgs,lh) = bx(lh) - vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y ENDIF ! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) @@ -7367,11 +7367,11 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) 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' - + ENDIF ! lh .gt. 1 ! ! @@ -7380,7 +7380,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! HAIL ! IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN - + do mgs = 1,ngscnt vtxbar(mgs,lhl,1) = 0.0 if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then @@ -7398,25 +7398,25 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1 indxr = Min( ngdnmm, Max(1,indxr) ) - - + + delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) IF ( indxr < ngdnmm ) THEN - + axx(mgs,lhl) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) bxx(mgs,lhl) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) - + ELSE axx(mgs,lhl) = mmgraupvt(indxr,2) bxx(mgs,lhl) = mmgraupvt(indxr,3) ENDIF - + aax = axx(mgs,lhl) bbx = bxx(mgs,lhl) cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) - + ELSE ! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) ! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) @@ -7432,7 +7432,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! & (3.0*cd*rho0(mgs)) ) axx(mgs,lhl) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) bxx(mgs,lhl) = 0.5 - vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lhl) * Sqrt(xdia(mgs,lhl,1)) + vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lhl) * Sqrt(xdia(mgs,lhl,1)) ELSE IF ( icdxhl /= 6 ) bbx = bx(lhl) tmp = 4. + alpha(mgs,lhl) + bbx @@ -7457,7 +7457,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & bxx(mgs,lhl) = bx(lhl) vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y ENDIF - + ! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) ENDIF @@ -7465,7 +7465,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & end if end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' - + ENDIF ! lhl .gt. 1 @@ -7500,12 +7500,12 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & DO mgs = 1,ngscnt IF ( qx(mgs,il) .gt. qxmin(il) ) THEN IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting - + ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value, ! effectively turning off size-sorting IF ( il .eq. lh ) THEN ! { - + IF ( icdx .eq. 1 ) THEN cd = cdx(lh) ELSEIF ( icdx .eq. 2 ) THEN @@ -7524,13 +7524,13 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) aax = axx(mgs,lh) bbx = bxx(mgs,lh) - ELSEIF ( icdx <= 0 ) THEN ! + ELSEIF ( icdx <= 0 ) THEN ! aax = ax(lh) bbx = bx(lh) ENDIF - + ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN - + IF ( icdxhl .eq. 1 ) THEN cd = cdx(lhl) ELSEIF ( icdxhl .eq. 3 ) THEN @@ -7546,11 +7546,11 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) aax = axx(mgs,lhl) bbx = bxx(mgs,lhl) - ELSEIF ( icdxhl <= 0 ) THEN ! + ELSEIF ( icdxhl <= 0 ) THEN ! aax = ax(lhl) bbx = bx(lhl) ENDIF - + ENDIF ! } IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and. & @@ -7566,7 +7566,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & i = Int(dgami*(tmp)) del = tmp - dgam*i x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - + tmp = 1. + alpha(mgs,il) i = Int(dgami*(tmp)) del = tmp - dgam*i @@ -7604,7 +7604,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & i = Int(dgami*(tmp)) del = tmp - dgam*i x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - + tmp = 7. + alpha(mgs,il) i = Int(dgami*(tmp)) del = tmp - dgam*i @@ -7682,8 +7682,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8' - ENDIF ! lg .gt. 1 - + ENDIF ! lg .gt. 1 + ! ENDIF ! ENDDO @@ -7696,7 +7696,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! ENDIF ! ENDDO - ENDIF ! infdo .ge. 1 + ENDIF ! infdo .ge. 1 IF ( lh > 0 .and. graupelfallfac /= 1.0 ) THEN DO mgs = 1,ngscnt @@ -7715,7 +7715,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & axx(mgs,lhl) = hailfallfac*axx(mgs,lhl) ENDDO ENDIF - + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE' !############ SETVTZ ############################ @@ -7755,23 +7755,23 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! ! and need to put fallspeed values in cwvt etc. ! - + implicit none integer ng1 parameter(ng1 = 1) - + integer, intent(in) :: ixcol ! which column to return integer, intent(in) :: ildo - + integer nx,ny,nz,nor,norz,ngt,jgs,na real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) real dtp,dtz1 - + real :: rhovtzx(nz,nx) - + integer ndebugzf parameter (ndebugzf = 0) @@ -7789,19 +7789,19 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & integer :: ngs integer :: ngscnt,mgs,ipconc0 ! parameter ( ngs=200 ) - - real :: qx(ngs,lv:lhab) - real :: qxw(ngs,ls:lhab) - real :: cx(ngs,lc:lhab) - real :: xv(ngs,lc:lhab) - real :: vtxbar(ngs,lc:lhab,3) - real :: xmas(ngs,lc:lhab) - real :: xdn(ngs,lc:lhab) - real :: cdxgs(ngs,lc:lhab) - real :: xdia(ngs,lc:lhab,3) - real :: vx(ngs,li:lhab) - real :: alpha(ngs,lc:lhab) - real :: zx(ngs,lr:lhab) + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) real xdnmx(lc:lhab), xdnmn(lc:lhab) real :: axx(ngs,lh:lhab), bxx(ngs,lh:lhab) @@ -7815,7 +7815,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! Fixed intercept values for single moment scheme ! real cno(lc:lhab) - + real cwccn0,cwmasn,cwmasx,cwradn ! real cwc0 @@ -7824,19 +7824,19 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & parameter (kstag=1) integer igs(ngs),kgs(ngs) - + real rho0(ngs),temcg(ngs) real temg(ngs) - + real rhovt(ngs) - + real cwnc(ngs),cinc(ngs) real fadvisc(ngs),cwdia(ngs),cipmas(ngs) - + ! real cimasn,cimasx, real :: cnina(ngs),cimas(ngs) - + real :: cnostmp(ngs) ! real pii @@ -7845,16 +7845,16 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! general constants for microphysics ! -! +! ! Miscellaneous ! - + logical flag logical ldoliq - - + + real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp, tmpc, tmpz - + real vtmax real xvbarmax @@ -7863,12 +7863,12 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail integer l1, l2 - + double precision :: dpt1, dpt2 !----------------------------------------------------------------------------- -! MPI LOCAL VARIABLES +! MPI LOCAL VARIABLES integer :: ixb, jyb, kzb integer :: ixe, jye, kze @@ -7892,7 +7892,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ldoliq = ldoliq .or. ( lliq(il) .gt. 1 ) ENDDO ENDIF - + ! poo = 1.0e+05 ! cp608 = 0.608 ! cp = 1004.0 @@ -7906,20 +7906,20 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! ds = 0.42 ! pi = 4.0*atan(1.0) ! pii = piinv ! 1./pi -! pid4 = pi/4.0 +! pid4 = pi/4.0 ! qccrit = 2.0e-03 ! qscrit = 6.0e-04 ! cwc0 = pii - + ! ! ! general constants for microphysics ! - + ! ! ci constants in mks units ! -! cimasn = 6.88e-13 +! cimasn = 6.88e-13 ! cimasx = 1.0e-8 ! ! Set terminal velocities... @@ -7976,7 +7976,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! -! Reconstruct various quantities +! Reconstruct various quantities ! do mgs = 1,ngscnt @@ -8009,16 +8009,16 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ELSE vtxbar(:,:,:) = 0.0 ENDIF - + ! do mgs = 1,ngscnt -! qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0) +! qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0) ! ENDDO DO il = l1,l2 do mgs = 1,ngscnt - qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) ENDDO end do - + cnostmp(:) = cno(ls) IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN DO mgs = 1,ngscnt @@ -8032,7 +8032,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! set concentrations ! cx(:,:) = 0.0 - + if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then do mgs = 1,ngscnt cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) @@ -8099,24 +8099,24 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! Set mean particle volume ! IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN - + vx(:,:) = 0.0 - + DO il = l1,l2 - + IF ( lvol(il) .ge. 1 ) THEN - + DO mgs = 1,ngscnt vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN xdn(mgs,il) = Min( xdnmx(il), Max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) ) ENDIF ENDDO - + ENDIF - + ENDDO - + ENDIF DO il = lg,lhab @@ -8124,7 +8124,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & alpha(mgs,il) = dnu(il) ENDDO ENDDO - + IF ( imurain == 1 ) THEN alpha(:,lr) = alphar ELSEIF ( imurain == 3 ) THEN @@ -8135,12 +8135,12 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & IF ( ipconc == 5 .and. imydiagalpha > 0 ) THEN DO mgs = 1,ngscnt IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN - xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! - xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! + xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) ENDIF IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN - xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) ENDIF @@ -8148,7 +8148,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! alpha(:,lh) = 0. ! 10. IF ( lhl > 0 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN - xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.) IF ( xdia(mgs,lhl,3) < 0.008 ) THEN alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl) @@ -8165,36 +8165,36 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! Set 6th moments ! IF ( ipconc .ge. 6 .or. lzr > 1) THEN - + zx(:,:) = 0.0 - + ! DO il = lr,lhab DO il = l1,l2 - + IF ( lz(il) .ge. 1 ) THEN - + DO mgs = 1,ngscnt zx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0) ENDDO - - + + ENDIF - + ENDDO - + ENDIF - - + + ! Find shape parameter rain IF ( lz(lr) > 1 .and. (ildo == 0 .or. ildo == lr ) .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM il = lr DO mgs = 1,ngscnt - + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN ! IF ( .false. .and. zx(mgs,lr) <= zxmin ) THEN IF ( zx(mgs,lr) <= zxmin ) THEN @@ -8213,9 +8213,9 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) ENDIF ENDIF - - - + + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) @@ -8272,7 +8272,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) z = zx(mgs,il) qr = qx(mgs,il) @@ -8280,7 +8280,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) ENDIF ENDIF - + IF ( zx(mgs,lr) > 0.0 ) THEN xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr))) vr = xv(mgs,lr) @@ -8334,12 +8334,12 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & alp = Max( rnumin, Min( rnumax, alp ) ) ENDDO - + ENDIF ENDIF ! -! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the ! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) ! ! IF ( alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax ) THEN @@ -8349,40 +8349,40 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) - + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) zx(mgs,il) = z an(igs(mgs),jy,kgs(mgs),lz(il)) = z - + ENDIF ENDIF ENDIF ENDIF - + ELSE - + zx(mgs,lr) = 0.0 cx(mgs,lr) = 0.0 an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) - + ENDIF - + ENDDO ENDIF ! } - + IF ( ipconc .ge. 6 ) THEN ! Find shape parameters for graupel,hail DO il = lr,lhab - + IF ( lz(il) .gt. 1 .and. (ildo == 0 .or. ildo == il ) .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN - + DO mgs = 1,ngscnt IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN @@ -8401,7 +8401,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & 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 @@ -8437,7 +8437,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) ! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) ! an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) -! +! ! ENDIF ENDIF @@ -8475,7 +8475,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) z = zx(mgs,il) @@ -8492,7 +8492,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & z = zx(mgs,il) IF ( zx(mgs,il) .gt. 0. ) THEN - + ! rd = z*(pi/6.*1000.)**2*chw/(0.224*(dn(igs(mgs),jy,kgs(mgs))*qr)**2) rd = z*(pi/6.*xdn(mgs,il))**2*chw/((dn(igs(mgs),jy,kgs(mgs))*qr)**2) @@ -8510,15 +8510,15 @@ 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 .or. il /= lr ) THEN - xvbarmax = xvmx(il) + xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) ENDIF - + IF ( xv(mgs,il) .gt. xvbarmax ) THEN tmp = cx(mgs,il) xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) ) @@ -8554,12 +8554,12 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & alp = Max( alphamin, Min( alphamax, alp ) ) ENDDO - + ENDIF ENDIF - + ! -! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the ! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) ! IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. & @@ -8571,7 +8571,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) - + ELSEIF ( rescale_low_alpha .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) ) THEN !! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*( 0.224*qr)*qr/chw @@ -8585,18 +8585,18 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ENDIF ENDIF ENDDO ! mgs - + ENDIF ! lz(il) .gt. 1 - + ENDDO ! il -! CALL cld_cpu('Z-MOMENT-ZFAll') - +! CALL cld_cpu('Z-MOMENT-ZFAll') + ENDIF IF ( lzhl > 1 ) THEN IF ( lhl .gt. 1 ) THEN - + ENDIF ENDIF @@ -8607,7 +8607,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' ! - + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & & ipconc,ndebugzf,ngs,nz,igs,kgs,fadvisc, & @@ -8622,14 +8622,14 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! DO il = l1,l2 do mgs = 1,ngscnt - + vtmax = 150.0 - + IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN - - + + ! IF ( qx(mgs,il) > 1.e-4 .and. & ! & .not. ( il == lr .and. 1.e3*xdia(mgs,il,3) > 5.0 ) ) THEN ! write(0,*) 'infdo,mgs = ',infdo,lzr,mgs @@ -8643,16 +8643,16 @@ 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) ) - + ENDIF - + IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & & vtxbar(mgs,il,3) .gt. vtmax ) THEN - + ! IF ( ndebugzf >= 0 .and. 1.e3*qx(mgs,il) > 0.1 ) THEN ! write(0,*) 'infdo = ',infdo ! write(0,*) 'Problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs) @@ -8668,7 +8668,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) - + ! call commasmpi_abort() ENDIF @@ -8698,7 +8698,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & if ( kz .gt. nz-1 ) then go to 1200 else - nzmpb = kz + nzmpb = kz end if if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB' @@ -8743,7 +8743,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! 09.28.2002 Test alterations for dry ice following Ferrier (1994) ! for equivalent melted diameter reflectivity. ! Converted to Fortran by ERM. -! +! !Date: Tue, 21 Nov 2000 10:13:36 -0600 (CST) !From: Matthew Gilmore ! @@ -8776,17 +8776,17 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & implicit none - + character(LEN=15), parameter :: microp = 'ZVD' integer nx,ny,nz,nor,na,ngt integer nzdbz ! how many levels actually to process - + integer ng1,n10 integer iunit integer, parameter :: printyn = 0 parameter( ng1 = 1 ) - + real cnoh0t,hwdn1t integer ke_diag integer ipconc @@ -8794,7 +8794,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & integer imapz,mzdist - + integer vzflag integer, parameter :: norz = 3 real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) @@ -8803,7 +8803,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & 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 real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4) - + ! real g,rgas,eta,inveta real cr1, cr2 , hwdnsq,swdnsq real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc @@ -8837,7 +8837,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & real ghdnmx,fwdnmx,hwdnmx,hldnmx real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn real ghdnmn,fwdnmn,hwdnmn,hldnmn - + real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq real dadgl,dadgm,dadgh,dadhl,dadf @@ -8845,20 +8845,20 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & real zhldryc,zhlwetc,zfdryc,zfwetc real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw - + integer imx,jmx,kmx - + real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia - + real csw,cgl,cgm,cgh,cfw,chw,chl real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl - + real cwc0 integer izieg integer ice10 real rhos parameter ( rhos = 0.1 ) - + real qxw,qxw1 ! temp value for liquid water on ice mixing ratio real :: dnsnow real qh @@ -8868,16 +8868,16 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & real, parameter :: cwradn = 5.0e-6 ! minimum radius real cwnccn(nz) - + real :: vzsnow, vzrain, vzgraupel, vzhail real :: ksq real :: dtp -! ######################################################################### +! ######################################################################### vzflag = 0 - + izieg = 0 ice10 = 0 ! g=9.806 ! g: gravity constant @@ -8890,7 +8890,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! cvr=cv/rgas pi = 4.0*ATan(1.) cwc0 = piinv ! 1./pi ! 6.0/pi - + cnoh = cnoh0t hwdn = hwdn1t @@ -8906,13 +8906,13 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! cnow = 1.0e+08 cnoi = 1.0e+08 - cnoip = 1.0e+08 - cnoir = 1.0e+08 - cnor = 8.0e+06 - cnos = 8.0e+06 - cnogl = 4.0e+05 - cnogm = 4.0e+05 - cnogh = 4.0e+05 + cnoip = 1.0e+08 + cnoir = 1.0e+08 + cnor = 8.0e+06 + cnos = 8.0e+06 + cnogl = 4.0e+05 + cnogm = 4.0e+05 + cnogh = 4.0e+05 cnof = 4.0e+05 cnohl = 1.0e+03 @@ -8923,7 +8923,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & i = 1 - IF ( microp(1:4) .eq. 'ZIEG' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + IF ( microp(1:4) .eq. 'ZIEG' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN ! write(0,*) 'Set reflectivity for ZIEG' izieg = 1 @@ -8942,16 +8942,16 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & qhlmin = qxmin(lhl) ENDIF - ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN izieg = 1 - + swdn0 = swdn cnor = cno(lr) cnos = cno(ls) cnoh = cno(lh) - + qrmin = qxmin(lr) qsmin = qxmin(ls) qhmin = qxmin(lh) @@ -8966,7 +8966,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! cdx(lr) = 0.60 -! +! ! IF ( lh > 1 ) THEN ! cdx(lh) = 0.8 ! 1.0 ! 0.45 ! cdx(ls) = 2.00 @@ -9002,7 +9002,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 !! ! xdnmn(:) = 900.0 -! +! ! xdnmn(lr) = 1000.0 ! xdnmn(lc) = 1000.0 ! IF ( lh > 1 ) THEN @@ -9013,7 +9013,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! IF ( lhl .gt. 1 ) xdnmn(lhl) = 500.0 ! ! xdn0(:) = 900.0 -! +! ! xdn0(lc) = 1000.0 ! xdn0(lr) = 1000.0 ! IF ( lh > 1 ) THEN @@ -9028,13 +9028,13 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! ! cnow = 1.0e+08 ! cnoi = 1.0e+08 -! cnoip = 1.0e+08 -! cnoir = 1.0e+08 -! cnor = 8.0e+06 -! cnos = 8.0e+06 -! cnogl = 4.0e+05 -! cnogm = 4.0e+05 -! cnogh = 4.0e+05 +! cnoip = 1.0e+08 +! cnoir = 1.0e+08 +! cnor = 8.0e+06 +! cnos = 8.0e+06 +! cnogl = 4.0e+05 +! cnogm = 4.0e+05 +! cnogh = 4.0e+05 ! cnof = 4.0e+05 !c cnoh = 4.0e+04 ! cnohl = 1.0e+03 @@ -9066,7 +9066,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & hwdnmn = 700.0 hldnmn = 900.0 - + gldn = (0.5)*(gldnmn+gldnmx) ! 300. gmdn = (0.5)*(gmdnmn+gmdnmx) ! 500. ghdn = (0.5)*(ghdnmn+ghdnmx) ! 700. @@ -9085,7 +9085,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ghdnsq = ghdn**2 fwdnsq = fwdn**2 hldnsq = hldn**2 - + dhmin = 0.005 tfr = 273.16 tfrh = tfr - 8.0 @@ -9093,10 +9093,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & reflectmin = 0.0 kw_sq = 0.93 dbzmax = dbzmin - + ihcnt=0 - + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Dielectric Factor - Formulas implemented by Svetla Veleva ! following Battan, "Radar Meteorology" - p. 40 @@ -9110,7 +9110,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ki_sq_h = (hwdnsq/rwdnsq) * const_ki_h**2 dielf_sn = ki_sq_sn / kw_sq dielf_h = ki_sq_h / kw_sq - + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Use the next line if you want to hardwire dielf for dry hail for both dry ! snow and dry hail. @@ -9131,7 +9131,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! constants for both snow and hail would be (x=s,h)..... ! xwdnsq/rwdnsq *0.21/kw_sq ! Straka/Smith - the original ! xwdnsq/rwdnsq *0.224 ! Ferrier - for particle sizes in equiv. drop diam -! xwdnsq/rwdnsq *0.176/kw_sq ! =0.189 in Smith - for particle sizes in equiv +! xwdnsq/rwdnsq *0.176/kw_sq ! =0.189 in Smith - for particle sizes in equiv ! ice spheres ! xwdnsq/rwdnsq *0.208/kw_sq ! Smith 1984 - for particle sizes in equiv melted drop diameter !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -9152,15 +9152,15 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & DO jy=1,1 DO kz = 1,ke_diag ! nz - + DO ix=1,nx dbz(ix,jy,kz) = 0.0 - + vzsnow = 0.0 vzrain = 0.0 vzgraupel = 0.0 vzhail = 0.0 - + dtmph = 0.0 dtmps = 0.0 dtmphl = 0.0 @@ -9169,7 +9169,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & !----------------------------------------------------------------------- ! Compute Rain Radar Reflectivity !----------------------------------------------------------------------- - + dtmp(ix,kz) = 0.0 gtmp(ix,kz) = 0.0 IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN @@ -9191,7 +9191,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF dtmpr = dtmp(ix,kz) ENDIF - + !----------------------------------------------------------------------- ! Compute snow and graupel reflectivity ! @@ -9229,7 +9229,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & xcnos = cnos ! -! Temporary fix for predicted number concentration -- need a +! Temporary fix for predicted number concentration -- need a ! more appropriate reflectivity equation! ! ! IF ( an(ix,jy,kz,lns) .lt. 0.1 ) THEN @@ -9245,17 +9245,17 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! ENDIF IF ( ls .gt. 1 ) THEN ! { - + IF ( lvs .gt. 1 ) THEN IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) swdn = Min( 300., Max( 100., swdn ) ) - ELSE + ELSE swdn = swdn0 ENDIF - - ENDIF - + + ENDIF + IF ( ipconc .ge. 5 ) THEN ! { xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/ & @@ -9267,7 +9267,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & swdia = (xvs*cwc0)**(1./3.) xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia) - + ENDIF ! } ENDIF ! } @@ -9279,7 +9279,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! hwdia = ! > (an(ix,jy,kz,lh)*db(ix,jy,kz) ! > /(pi*hwdn*an(ix,jy,kz,lnh)))**(1./3.) -! +! ! xcnoh = an(ix,jy,kz,lnh)/hwdia ! ENDIF @@ -9289,13 +9289,13 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) hwdn = Min( 900., Max( hdnmn, hwdn ) ) - ELSE + ELSE hwdn = 500. ! hwdn1t ENDIF ELSE hwdn = hwdn1t - ENDIF - + ENDIF + IF ( ipconc .ge. 5 ) THEN ! { xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/ & @@ -9307,15 +9307,15 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & hwdia = (xvh*cwc0)**(1./3.) xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia) - + ENDIF ! } ipconc .ge. 5 - + ENDIF ! } dadh = 0.0 dadhl = 0.0 dads = 0.0 - IF ( xcnoh .gt. 0.0 ) THEN + IF ( xcnoh .gt. 0.0 ) THEN dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25) zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ! dielf_h*cr1*xcnoh ! SV - equiv formula as before but ! ratio of densities included in @@ -9325,7 +9325,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & dadh = 0.0 zhdryc = 0.0 ENDIF - + IF ( xcnos .gt. 0.0 ) THEN dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25) zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ! dielf_sn*cr1*xcnos ! SV - similar change as above @@ -9335,22 +9335,22 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF zhwetc = zhdryc ! cr1*xcnoh !Hail/graupel version with .95 power bug removed zswetc = zsdryc ! cr1*xcnos -! +! ! snow contribution ! IF ( ls .gt. 1 ) THEN - - gtmp(ix,kz) = 0.0 - qxw = 0.0 + + gtmp(ix,kz) = 0.0 + qxw = 0.0 qxw1 = 0.0 dtmps = 0.0 IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{ IF ( ipconc .ge. 4 ) THEN ! (Ferrier 94) !{ - if (lsw .gt. 1) THEN + if (lsw .gt. 1) THEN qxw = an(ix,jy,kz,lsw) qxw1 = 0.0 - ELSEIF ( ( iusewetsnow == 1 .or. iusewetsnow == 3) .and. temk(ix,jy,kz) .gt. tfr+1. & + ELSEIF ( ( iusewetsnow == 1 .or. iusewetsnow == 3) .and. temk(ix,jy,kz) .gt. tfr+1. & & .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) .and. an(ix,jy,kz,lr) > qsmin) THEN qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) qxw1 = qxw @@ -9358,7 +9358,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) ! gtmp(ix,kz) = 3.6e18*(0.243*rhos**2/0.93)*(snu+2.)*an(ix,jy,kz,lns)*vr**2/(snu+1.) - + ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN ! IF ( .true. ) THEN @@ -9381,16 +9381,16 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF ENDIF - + ENDIF - + ! tmp = Min(1.0,1.e3*(an(ix,jy,kz,ls))*db(ix,jy,kz)) ! gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98) dtmps = gtmp(ix,kz) dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz) ELSE ! }{ single-moment snow: gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25) - + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{ dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) IF ( temk(ix,jy,kz) .lt. tfr ) THEN @@ -9402,9 +9402,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF ENDIF !} ENDIF !} - + ENDIF !} - + ENDIF @@ -9412,7 +9412,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! ice crystal contribution (Heymsfield, 1977, JAS) ! IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN - + IF ( idbzci == 1 .and. lni > 0 ) THEN ! assume spherical ice with density of 900 for dbz calc IF ( an(ix,jy,kz,li) > qxmin(li) .and. an(ix,jy,kz,lni) > 1.0 ) THEN @@ -9425,21 +9425,21 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! ! ice crystal contribution (Heymsfield, 1977, JAS) ! - gtmp(ix,kz) = 0.0 + gtmp(ix,kz) = 0.0 IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN gtmp(ix,kz) = Min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz)) dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98 ENDIF - + ENDIF - + ENDIF - -! + +! ! graupel/hail contribution ! IF ( lh .gt. 1 ) THEN ! { - gtmp(ix,kz) = 0.0 + gtmp(ix,kz) = 0.0 dtmph = 0.0 qxw = 0.0 @@ -9450,15 +9450,15 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & 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 - + IF ( lvh .gt. 1 ) THEN - + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) hwdn = Min( 900., Max( 100., hwdn ) ) - ELSE + ELSE hwdn = 500. ! hwdn1t ENDIF @@ -9471,9 +9471,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & xvh = Min( xvhmx, Max( xvhmn,xvh ) ) chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) ENDIF - + qh = an(ix,jy,kz,lh) - + IF ( lhw .gt. 1 ) THEN IF ( iusewetgraupel .eq. 1 ) THEN qxw = an(ix,jy,kz,lhw) @@ -9493,7 +9493,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & qh = qh + qxw 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 @@ -9507,16 +9507,16 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & dtmp(ix,kz) = dtmp(ix,kz) + ze dtmph = ze ENDIF - + ENDIF - + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze ENDIF - + ELSE - + dtmph = 0.0 - + IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25) IF ( gtmp(ix,kz) .gt. 0.0 ) THEN @@ -9528,7 +9528,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! IF ( hwdn .gt. 700.0 ) THEN dtmp(ix,kz) = dtmp(ix,kz) + & & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) -! +! ! & (zhwetc*gtmp(ix,kz)**7)**0.95 ! ELSE ! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 @@ -9536,35 +9536,35 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF ENDIF ENDIF - - - + + + ENDIF - + ENDIF ! } - + ENDIF ! na .gt. 5 - + IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN hldn = 900.0 gtmp(ix,kz) = 0.0 dtmphl = 0.0 qxw = 0.0 - + IF ( lvhl .gt. 1 ) THEN IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) hldn = Min( 900., Max( 300., hldn ) ) - ELSE - hldn = 900. + ELSE + hldn = 900. ENDIF ELSE hldn = rho_qhl - ENDIF + ENDIF IF ( ipconc .ge. 5 ) THEN @@ -9595,7 +9595,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF ENDIF 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 @@ -9608,22 +9608,22 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ze = 1.e18*zx*(6./(pi*1000.))**2 ! 3/28/2016 removed extra factor of 0.224 dtmp(ix,kz) = dtmp(ix,kz) + ze dtmphl = ze - + ENDIF !} ENDIF!} ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze ENDIF - + ELSE - - + + IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN ! { dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25) gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25) IF ( gtmp(ix,kz) .gt. 0.0 ) THEN ! { - zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl + zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl dtmphl = zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) @@ -9634,45 +9634,45 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! IF ( hwdn .gt. 700.0 ) THEN dtmp(ix,kz) = dtmp(ix,kz) + & & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) -! +! ! : (zhwetc*gtmp(ix,kz)**7)**0.95 ! ELSE ! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 ! ENDIF ENDIF ENDIF ! } - + ENDIF ! } - + ENDIF ! ipconc .ge. 5 - ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 + 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)) imx = ix jmx = jy kmx = kz ENDIF - ELSE + ELSE dbz(ix,jy,kz) = dbzmin IF ( lh > 1 .and. lhl > 1) THEN IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl) write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl - + IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl) ENDIF ENDIF ENDIF -! IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. +! IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. ! & dbz(ix,jy,kz) .le. 0.0 ) THEN ! write(0,*) 'dbz = ',dbz(ix,jy,kz) ! write(0,*) 'Hail intercept: ',xcnoh,ix,kz @@ -9697,7 +9697,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .ge. 5 ) THEN write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl) - IF ( lzhl .gt. 1 ) THEN + IF ( lzhl .gt. 1 ) THEN write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl) write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.) write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx @@ -9712,20 +9712,20 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF ENDIF - + ENDDO ! ix ENDDO ! kz ENDDO ! jy - - - - + + + + ! write(0,*) 'na,lr = ',na,lr IF ( printyn .eq. 1 ) THEN ! IF ( dbzmax .gt. dbzmin ) THEN write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr) - + IF ( lh .gt. 1 ) THEN write(iunit,*) 'qi = ',an(imx,jmx,kmx,li) write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls) @@ -9733,13 +9733,13 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl) ENDIF - + ENDIF - - + + RETURN END subroutine radardd02 - + ! ############################################################################## ! ############################################################################## @@ -9755,12 +9755,12 @@ END subroutine radardd02 ! 11/30/2022: Fixed droplet evaporation heating term for CM1 eqtset=2 (was only doing eqtset=1) ! SUBROUTINE NUCOND & - & (nx,ny,nz,na,jyslab & - & ,nor,norz,dtp,nxi & - & ,dz3d & - & ,t0,t9 & - & ,an,dn,p2 & - & ,pn,w & + & (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 & @@ -9769,7 +9769,7 @@ SUBROUTINE NUCOND & implicit none -! real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3 +! real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3 integer :: nx,ny,nz,na,nxi integer :: nor,norz, jyslab ! ,nht,ngt,igsr real :: dtp ! time step @@ -9794,7 +9794,7 @@ SUBROUTINE NUCOND & ! real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) ! real t8(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) ! perturbation Pi real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) @@ -9805,24 +9805,24 @@ SUBROUTINE NUCOND & ! real qv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - + 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 - + real :: dv real :: ccnefactwo, sstmp, cn1, cnuctmp -! +! ! declarations microphysics and for gather/scatter ! real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. @@ -9832,18 +9832,18 @@ SUBROUTINE NUCOND & integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs) integer nsvcnt - + integer ix,kz,i,n, kp1, km1 integer :: jy, jgs integer ixb,ixe,jyb,jye,kzb,kze - + integer itile,jtile,ktile integer ixend,jyend,kzend,kzbeg integer nxend,nyend,nzend,nzbeg ! ! Variables for Ziegler warm rain microphysics -! +! real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs), ccnaco(ngs), ccnanu(ngs) @@ -9858,7 +9858,7 @@ SUBROUTINE NUCOND & ! =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 ) + parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold real :: ssmax(ngs) ! maximum SS experienced by a parcel real ssmx @@ -9871,7 +9871,7 @@ SUBROUTINE NUCOND & real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler real rhoinv(ngs) - + real chw, g1, rd1 real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super @@ -9891,15 +9891,15 @@ SUBROUTINE NUCOND & real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 real dqvr, dqc, dqr, dqi, dqs real qv1m,qvs1m,ss1m,ssi1m,qis1m - real cwmastmp + real cwmastmp real dcloud,dcloud2 ! ,as, bs real dcrit real cn(ngs), cnuf(ngs) real :: ccwmax - + integer ltemq - + integer il real es(ngs) ! ss(ngs), @@ -9917,13 +9917,13 @@ SUBROUTINE NUCOND & real epsi,d parameter (epsi = 0.622, d = 0.266) real r1,qevap ! ,slv - + real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc real ctmp, ccwtmp real f5, qvs0 ! Kessler condensation factor real :: t0p1, t0p3 real qvex - + ! real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) real temp(ngs),tempc(ngs) @@ -9957,7 +9957,7 @@ SUBROUTINE NUCOND & real advisc(ngs) real rwvent(ngs) - + real :: qx(ngs,lv:lhab) real :: cx(ngs,lc:lhab) @@ -9970,13 +9970,13 @@ SUBROUTINE NUCOND & logical zerocx(lc:lqmx) - + logical :: lprint integer, parameter :: iunit = 0 - + real :: frac, hwdn, tmpg, xdia1, xdia3, cwch,xvol - + real :: cvm,cpm,rmm real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure @@ -9984,9 +9984,9 @@ SUBROUTINE NUCOND & integer :: kstag - + 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) @@ -10001,7 +10001,7 @@ SUBROUTINE NUCOND & 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 ! ------------------------------------------------------------------------------- @@ -10024,14 +10024,14 @@ SUBROUTINE NUCOND & kstag = 0 pb(:) = 0.0 pinit(:) = 0.0 - + IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 ! -! Ziegler nucleation +! Ziegler nucleation ! -! ssfilt(:,:,:) = 0.0 + ssfilt(:,:,:) = 0.0 ssmx = 0 count = 0 @@ -10135,10 +10135,10 @@ SUBROUTINE NUCOND & if ( ngscnt .eq. 0 ) go to 29998 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8' - + ! write(0,*) 'NUCOND: dbg = 8, ngscnt,ssmx = ',ngscnt,ssmx - + qx(:,:) = 0.0 cx(:,:) = 0.0 zx(:,:) = 0.0 @@ -10217,7 +10217,7 @@ SUBROUTINE NUCOND & cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) rmm=rd+rw*qx(mgs,lv) - + IF ( eqtset == 2 ) THEN felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm @@ -10261,7 +10261,7 @@ SUBROUTINE NUCOND & cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) cwnccn(mgs) = cwccn*rho0(mgs)/rho00 ! background ccn count cn(mgs) = 0.0 - IF ( lss > 1 ) THEN + IF ( lss > 1 ) THEN ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) ELSE ssmax(mgs) = 0.0 @@ -10281,7 +10281,7 @@ SUBROUTINE NUCOND & IF ( lcn_co > 1 ) THEN ccnc_co(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_co) ENDIF - IF ( lccnaco > 1 ) THEN + IF ( lccnaco > 1 ) THEN ccnaco(mgs) = an(igs(mgs),jy,kgs(mgs),lccnaco) ELSE ccnaco(mgs) = 0.0 @@ -10314,7 +10314,7 @@ SUBROUTINE NUCOND & IF ( lccna > 1 ) THEN ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ! predicted count of activated ccn IF ( ac_opt == 22 ) THEN - IF ( lccnaco > 1 ) THEN + IF ( lccnaco > 1 ) THEN ccnaco(mgs) = an(igs(mgs),jy,kgs(mgs),lccnaco) ELSE ccnaco(mgs) = 0.0 @@ -10374,7 +10374,7 @@ SUBROUTINE NUCOND & ventrx(:) = ventr ventrxn(:) = ventrn - + ! Find shape parameter rain @@ -10427,7 +10427,7 @@ SUBROUTINE NUCOND & z1 = zx(mgs,il) qr = qx(mgs,il) cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) - + ENDIF ! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN @@ -10443,7 +10443,7 @@ SUBROUTINE NUCOND & chw = cx(mgs,il) qr = qx(mgs,il) zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000) - + ENDIF ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN @@ -10452,7 +10452,7 @@ SUBROUTINE NUCOND & ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - + IF ( imurain == 3 ) THEN g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) z1 = zx(mgs,il) @@ -10466,10 +10466,10 @@ SUBROUTINE NUCOND & qr = qx(mgs,il) cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z1*(pi*xdn(mgs,il))**2) an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) - + ENDIF ENDIF - + IF ( zx(mgs,lr) > 0.0 ) THEN vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) ! z1 = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) @@ -10514,12 +10514,12 @@ SUBROUTINE NUCOND & alp = Max( alphamin, Min( alphamax, alp ) ) ENDDO - + ENDIF ! ENDIF ! -! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the ! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) ! IF ( imurain == 3 ) THEN @@ -10529,16 +10529,16 @@ SUBROUTINE NUCOND & g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1*(1./(xdn(mgs,il)))**2 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) - + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN z1 = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) zx(mgs,il) = z1 ENDIF ENDIF - + ELSEIF ( imurain == 1 ) THEN - + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) @@ -10550,7 +10550,7 @@ SUBROUTINE NUCOND & IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z cx(mgs,il) = g1*rho0(mgs)**2*(qr)*qr/zx(mgs,lr)*(6./(pi*xdn(mgs,il)))**2 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) - + ELSEIF ( rescale_low_alpha .and. alp <= alphamin ) THEN ! alpha = alphamin, so reset Z to prevent growth in C z1 = g1*rho0(mgs)**2*(qr)*qr/nrx z2 = z1*(6./(pi*xdn(mgs,il)))**2 @@ -10583,7 +10583,7 @@ SUBROUTINE NUCOND & ! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.) ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) - + ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN tmp = alpha(mgs,lr) + 2.5 + br/2. @@ -10593,36 +10593,36 @@ SUBROUTINE NUCOND & ! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.) ventrxn(mgs) = x/y - - + + ENDIF - + ENDIF ENDIF - + ENDIF - + ENDDO -! CALL cld_cpu('Z-MOMENT-1r2') +! CALL cld_cpu('Z-MOMENT-1r2') ENDIF ! } ! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit ssmx = 0.0 DO mgs = 1,ngscnt - + kp1 = Min(nz, kgs(mgs)+1 ) - wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + 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)) & + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & & +w(igs(mgs),jgs,Max(1,kgs(mgs)-1))) ssat0(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) ssf(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) ! ssmx = Max( ssmx, ssf(mgs) ) - + ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) @@ -10718,14 +10718,14 @@ SUBROUTINE NUCOND & do mgs = 1,ngscnt - fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & & (temg(mgs)/296.0)**(1.5) fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) - fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & & (101325.0/(pres(mgs))) - + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) @@ -10733,7 +10733,7 @@ SUBROUTINE NUCOND & end do ! ! -! Ziegler nucleation +! Ziegler nucleation ! ! ! cloud evaporation, condensation, and nucleation @@ -10741,9 +10741,9 @@ SUBROUTINE NUCOND & DO mgs=1,ngscnt dcloud = 0.0 - ! Skip points at low temperature if SS stays less than 1.08, + ! Skip points at low temperature if SS stays less than 1.08, ! otherwise allow nucleation at low temp (will freeze at next time step) - IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxlowtempss ) THEN + IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxlowtempss ) THEN CYCLE ENDIF @@ -10940,15 +10940,15 @@ SUBROUTINE NUCOND & ! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula) vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) - - + + rwvent(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 x = 1. + alpha(mgs,lr) @@ -10957,18 +10957,18 @@ SUBROUTINE NUCOND & & *Sqrt((ar*rhovt(mgs))) & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) - + ENDIF ! iferwisventr - + ENDIF ! imurain - d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & + d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & & *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs) ELSE d1r = 0.0 ENDIF - - + + e1 = felvcp(mgs)/(pi0(mgs)) f1 = pk(mgs) ! (pres(mgs)/poo)**cap @@ -11082,7 +11082,7 @@ SUBROUTINE NUCOND & ! write(0,*) 'RK2a dqv1m = ',dqv dtemp = -e1*f1*(dqv + dqvr) - + ! ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5) ! 7.6.2016: Test full calc of ltemq @@ -11144,7 +11144,7 @@ SUBROUTINE NUCOND & ELSE g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) - + ENDIF zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(xdn(mgs,lr)))**2*( 2.*( tmp ) * dqr ) ENDIF @@ -11177,15 +11177,15 @@ SUBROUTINE NUCOND & dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) ) ELSEIF ( iqcinit == 3 ) THEN - R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & & ((temg(mgs) - cbw)**2)) - DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; ! this will put mass into qc if qv > sqsat exists - + ELSEIF ( iqcinit == 2 ) THEN ! R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ ! : (cp*(temg(mgs) - cbw)**2)) -! DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; +! DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; ! this will put mass into qc if qv > sqsat exists ssmx = ssmxinit @@ -11197,7 +11197,7 @@ SUBROUTINE NUCOND & IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. & ( 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, & + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) ELSE dcloud = 0.0 @@ -11206,7 +11206,7 @@ SUBROUTINE NUCOND & ELSE dcloud = 0.0 ENDIF - + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD @@ -11229,11 +11229,11 @@ SUBROUTINE NUCOND & !.... S. TWOMEY (1959) ! Note: get here if there is no previous cloud water and w > 0. cn(mgs) = 0.0 - + IF ( ncdebug .ge. 1 ) THEN write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs) ENDIF - + IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem ! IF ( ac_opt == 0 ) THEN @@ -11241,13 +11241,13 @@ SUBROUTINE NUCOND & ! 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 ! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 CN(mgs) = CCNE0*cnuctmp**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & - & .and. ncdebug .ge. 1 ) THEN + & .and. ncdebug .ge. 1 ) THEN write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & & wvel(mgs), dcloud*1.e3 IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ', & @@ -11272,7 +11272,7 @@ SUBROUTINE NUCOND & cn(mgs) = ccnc(mgs) ! ccnc(mgs) = 0.0 ENDIF - ELSE + ELSE cn(mgs) = Min( cn(mgs), ccnc(mgs) ) ENDIF ! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) @@ -11288,11 +11288,11 @@ SUBROUTINE NUCOND & ELSE cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn) ENDIF - + ENDIF ! }.not. flag_qndrop GOTO 613 - + END IF ! qc .gt. 0. ! ES=EES(PIB(K)*PT) @@ -11390,7 +11390,7 @@ SUBROUTINE NUCOND & ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF - ELSEIF ( irenuc == 2 ) THEN !} { + ELSEIF ( irenuc == 2 ) THEN !} { ! simple Twomey scheme ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 @@ -11401,7 +11401,7 @@ SUBROUTINE NUCOND & CN(mgs) = Min(cn(mgs), ccnc(mgs)) cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass CN(mgs) = Min( CN(mgs), Max(0.0, (cnuc(mgs) - ccna(mgs) )) ) - + IF ( .false. .and. ny <= 2 ) THEN write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn write(0,*) 'wvel, cnuc, cn = ',wvel(mgs),cnuc(mgs),cn(mgs) @@ -11409,31 +11409,31 @@ SUBROUTINE NUCOND & write(0,*) 'part1, part2 = ',CCNE0*cnuc(mgs)**(2./(2.+cck)), Max(0.0,wvel(mgs))**cnexp write(0,*) 'ccnc, dqc, dqc/cwmasn = ',ccnc(mgs), dqc, 0.5*dqc/cwmasn ENDIF - - IF ( icnuclimit > 0 ) THEN + + IF ( icnuclimit > 0 ) THEN tmp = ccnc(mgs) + cx(mgs,lc) IF ( tmp < 330.34e6 ) THEN ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 ELSE ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 ENDIF - + ! IF ( cn(mgs) > 0. ) THEN -! write(0,*) 'cn,tmp,ccwmax,cx,c-cx = ',cn(mgs),tmp,ccwmax,cx(mgs,lc),ccwmax - cx(mgs,lc) +! write(0,*) 'cn,tmp,ccwmax,cx,c-cx = ',cn(mgs),tmp,ccwmax,cx(mgs,lc),ccwmax - cx(mgs,lc) ! ENDIF - + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) - + ENDIF - + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - + IF ( lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - ELSEIF ( irenuc == 3 ) THEN !} { + ELSEIF ( irenuc == 3 ) THEN !} { ! Phillips Donner Garner 2007 ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) -! CN(mgs) = cwccn*Min(ssf(mgs),ssfcut)**cck +! CN(mgs) = cwccn*Min(ssf(mgs),ssfcut)**cck ! Need to calculate new ssf since condensation has happened: temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) @@ -11446,21 +11446,21 @@ SUBROUTINE NUCOND & IF ( c1 > 0. ) THEN ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values ENDIF - CN(mgs) = cnuc(mgs)*Min(1.0, (ssf(mgs))**cck ) ! + CN(mgs) = cnuc(mgs)*Min(1.0, (ssf(mgs))**cck ) ! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from ! Philips, Donner et al. 2007, but results in too much limitation of ! nucleation CN(mgs) = Min(cn(mgs), ccnc(mgs)) cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass - + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - - ELSEIF ( irenuc == 4 ) THEN !} { + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 4 ) THEN !} { ! modification of Phillips Donner Garner 2007 ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) ! CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp @@ -11483,13 +11483,13 @@ 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 ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + dcrit = 2.0*2.5e-7 - + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) @@ -11498,10 +11498,10 @@ SUBROUTINE NUCOND & ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - - ELSEIF ( irenuc == 6 ) THEN !} { + + ELSEIF ( irenuc == 6 ) THEN !} { ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) @@ -11513,7 +11513,7 @@ SUBROUTINE NUCOND & ! prevent this branch from activating more than 70% of CCN CN(mgs) = Min( CN(mgs), Max(0.0, (0.7*cnuc(mgs) - ccna(mgs) )) ) ! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) - + ELSE ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. @@ -11530,9 +11530,9 @@ SUBROUTINE NUCOND & ssf(mgs) = 0.0 ENDIF -! CN(mgs) = cnuc(mgs)*Min(0.99, Min(ssf(mgs),ssfcut)**cck ) ! - CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,ssf(mgs))**cck ) ! -! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck ! +! CN(mgs) = cnuc(mgs)*Min(0.99, Min(ssf(mgs),ssfcut)**cck ) ! + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,ssf(mgs))**cck ) ! +! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck ! CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from @@ -11544,28 +11544,28 @@ 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 ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid - + dcrit = 2.0*2.5e-7 - + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF - ELSEIF ( irenuc == 5 ) THEN !} { + ELSEIF ( irenuc == 5 ) THEN !} { ! 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 ( 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 ) @@ -11581,7 +11581,7 @@ SUBROUTINE NUCOND & ELSE ssf(mgs) = 0.0 ENDIF - + CN(mgs) = Max( cn(mgs), cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ) ! this allows cn(mgs) > cnuc(mgs) @@ -11589,7 +11589,7 @@ SUBROUTINE NUCOND & ! IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from - + ELSE CN(mgs) = Min( cn(mgs), cnuc(mgs) - ccna(mgs) ) ! no more than remaining "base" CCN ENDIF @@ -11605,12 +11605,12 @@ SUBROUTINE NUCOND & tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) cn(mgs) = Min(tmp, cn(mgs) ) - + 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) qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) @@ -11619,7 +11619,7 @@ SUBROUTINE NUCOND & ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - ELSEIF ( irenuc == 7 .or. irenuc == 17 ) THEN !} { + ELSEIF ( irenuc == 7 .or. irenuc == 17 ) THEN !} { ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) @@ -11643,7 +11643,7 @@ SUBROUTINE NUCOND & ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) '1: cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) ! ENDIF - + ELSE ! }{ ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. @@ -11666,9 +11666,9 @@ SUBROUTINE NUCOND & ! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN IF ( ssf(mgs) <= 1.0 ) THEN - CN(mgs) = cnuc(mgs)*Min(1.0, Max(0.0,ssf(mgs))**cck ) ! + CN(mgs) = cnuc(mgs)*Min(1.0, Max(0.0,ssf(mgs))**cck ) ! ELSE - CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) ! + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) ! ! write(0,*) 'iren7: ssf,ssmx = ',ssf(mgs),ssmax(mgs),cn(mgs),ccna(mgs),cnuc(mgs) ! write(0,*) 'c1,qv = ',c1,qx(mgs,lv),temp1,ltemq ENDIF @@ -11680,11 +11680,11 @@ SUBROUTINE NUCOND & CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) ENDIF - + ! 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 - + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from ENDIF ! } @@ -11694,7 +11694,7 @@ SUBROUTINE NUCOND & ! nucleation ! CN(mgs) = Min(cn(mgs), ccnc(mgs)) ! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass - + IF ( icnuclimit > 0 ) THEN ! max droplet conc. based on Chandrakar et al. (2016) and Konwar et al. (2012) @@ -11704,9 +11704,9 @@ SUBROUTINE NUCOND & ELSE ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 ENDIF - + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) - + ENDIF IF ( cn(mgs) + cnuf(mgs) > 0.0 ) THEN @@ -11720,11 +11720,11 @@ SUBROUTINE NUCOND & cn(mgs) = Min(tmp, cn(mgs) ) cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + cnuf(mgs) - - + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid - - + + dcrit = 2.0*2.5e-7 dcloud = 1000.*dcrit**3*Pi/6.*(cn(mgs) + cnuf(mgs) ) qx(mgs,lc) = qx(mgs,lc) + DCLOUD @@ -11734,12 +11734,12 @@ SUBROUTINE NUCOND & ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) ENDIF - ELSEIF ( irenuc == 8 ) THEN !} { + ELSEIF ( irenuc == 8 ) THEN !} { ! simple Twomey scheme ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) - + cn(mgs) = 0.0 - + IF ( ccnc(mgs) > 0. ) THEN CN(mgs) = CCNE0*ccnc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 ! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) @@ -11747,7 +11747,7 @@ SUBROUTINE NUCOND & ! Philips, Donner et al. 2007, but results in too much limitation of ! nucleation CN(mgs) = Min(cn(mgs), ccnc(mgs)) - + ELSEIF ( cx(mgs,lc) < 0.01e9 ) THEN ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. @@ -11773,28 +11773,28 @@ SUBROUTINE NUCOND & IF ( ssf(mgs) <= 1.0 ) THEN CN(mgs) = 0.0 ELSE -! CN(mgs) = 0.01e9*rho0(mgs)/rho00*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! - CN(mgs) = 0.01e9*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! +! CN(mgs) = 0.01e9*rho0(mgs)/rho00*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + CN(mgs) = 0.01e9*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! ENDIF - + ENDIF IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid - + dcrit = 2.0*2.5e-7 - + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF - + ELSEIF ( irenuc == 9 .or. irenuc == 10 ) THEN ! } { @@ -11805,7 +11805,7 @@ SUBROUTINE NUCOND & write(0,*) 'irenuc=11 requires nuwrfmods=1' ENDIF ! } - + ccna(mgs) = ccna(mgs) + cn(mgs) @@ -11827,17 +11827,17 @@ SUBROUTINE NUCOND & ssmx = maxsupersat qv1 = qv0(mgs) + qwvp(mgs) qvs1 = qvs(mgs) - + ! IF ( flag_qndrop .and. do_satadj_for_wrfchem ) ssmx = 1.04 ! set lower threshold for progn=1 when using WRF-CHEM IF ( qv1 .gt. (ssmx*qvs1) ) THEN ! use line below to disable saturation adjustment when flag_qndrop is true ! IF ( qv1 .gt. (ssmx*qvs1) .and. .not. flag_qndrop ) THEN - + ss1 = qv1/qvs1 ssmx = 100.*(ssmx - 1.0) - + qvex = 0.0 CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & @@ -11883,15 +11883,15 @@ SUBROUTINE NUCOND & ! ! Calculate droplet volume and check if it is within bounds. ! Adjust if necessary -! -! if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: check droplet volume" +! +! if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: check droplet volume" ! cx(mgs,lc) = Min( cwnccn(mgs), cx(mgs,lc) ) IF( cx(mgs,lc) > cxmin .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN ! SVC(mgs) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)*xdn(mgs,lc)) xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)) - + IF ( xmas(mgs,lc) < cwmasn .or. xmas(mgs,lc) > cwmasx ) THEN tmp = cx(mgs,lc) xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) @@ -11920,14 +11920,14 @@ SUBROUTINE NUCOND & ! IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN ! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc)) ! ENDIF -! +! ! ! 681 CONTINUE - + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN - + IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr)) & & xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr) @@ -11982,7 +11982,7 @@ SUBROUTINE NUCOND & ! IF ( ac_opt > 10 .and. (cx(mgs,lc) > 0. .or. ccna(mgs) > 0. ) ) THEN ! write(0,*) 'i,k final cx/cna = ',igs(mgs),kgs(mgs),cx(mgs,lc),ccna(mgs) ! ENDIF - + IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) IF ( ac_opt == 0 ) THEN IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN @@ -12047,10 +12047,10 @@ SUBROUTINE NUCOND & ! moved to separate subroutine (below) ! - - + + 9999 RETURN - + END SUBROUTINE NUCOND @@ -12062,10 +12062,10 @@ END SUBROUTINE NUCOND ! Redistribution everywhere in the domain... ! subroutine smallvalues & - & (nx,ny,nz,na,jyslab & - & ,nor,norz,dtp,nxi & - & ,t0 & - & ,an,dn, w & + & (nx,ny,nz,na,jyslab & + & ,nor,norz,dtp,nxi & + & ,t0 & + & ,an,dn, w & & ,t77,flag_qndrop & & ) @@ -12088,7 +12088,7 @@ subroutine smallvalues & ! local - + logical zerocx(lc:lqmx) real :: frac, hwdn, tmpg, xdia1, xdia3, cwch,xvol @@ -12097,7 +12097,7 @@ subroutine smallvalues & integer :: il integer :: jy, jgs real :: chw, g1, z1, tmp, tmp2, fw, tmpmx, qr - + ! Redistribute inappreciable cloud particles and charge ! @@ -12116,9 +12116,9 @@ subroutine smallvalues & do kz = 1,nz ! do jy = 1,1 do ix = 1,nxi - + t0(ix,jy,kz) = an(ix,jy,kz,lt)*t77(ix,jy,kz) - + zerocx(:) = .false. DO il = lc,lhab IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN @@ -12136,13 +12136,13 @@ subroutine smallvalues & 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,lnhl) .gt. 0.0 ) THEN IF ( lvhl .gt. 1 ) THEN @@ -12164,16 +12164,16 @@ subroutine smallvalues & ELSE z1 = 0.0 ENDIF - + an(ix,jy,kz,lzhl) = Min( z1, an(ix,jy,kz,lzhl) ) - + IF ( an(ix,jy,kz,lnhl) .lt. 1.e-5 ) THEN ! an(ix,jy,kz,lzhl) = 0.9*an(ix,jy,kz,lzhl) ENDIF ENDIF - + ENDIF !lzhl - + if ( (an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl)) .or. zerocx(lhl) ) then ! IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN @@ -12196,7 +12196,7 @@ subroutine smallvalues & IF ( lnhlf .gt. 1 ) THEN an(ix,jy,kz,lnhlf) = 0.0 ENDIF - + IF ( lzhl .gt. 1 ) THEN an(ix,jy,kz,lzhl) = 0.0 ENDIF @@ -12224,7 +12224,7 @@ subroutine smallvalues & ! it is not exactly linear, but approx. is close enough for this ! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx - tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) )) + tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) )) IF ( tmp .gt. tmpmx ) THEN an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmpmx @@ -12245,9 +12245,9 @@ subroutine smallvalues & an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp ENDIF ENDIF - + 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) @@ -12270,10 +12270,10 @@ subroutine smallvalues & 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 - + IF ( lvhl .gt. 1 ) THEN hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) ELSE @@ -12285,7 +12285,7 @@ subroutine smallvalues & tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*pi)**(1./3.) an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) ENDIF - + ENDIF ! ELSE ! check mean size here? @@ -12298,9 +12298,9 @@ subroutine smallvalues & IF ( lzh .gt. 1 ) THEN an(ix,jy,kz,lzh) = Max(0.0, an(ix,jy,kz,lzh) ) - + IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. rescale_low_alpha ) THEN - + IF ( an(ix,jy,kz,lnh) .gt. 0.0 ) THEN IF ( lvh .gt. 1 ) THEN @@ -12322,14 +12322,14 @@ subroutine smallvalues & ELSE z1 = 0.0 ENDIF - + an(ix,jy,kz,lzh) = Min( z1, an(ix,jy,kz,lzh) ) - + IF ( an(ix,jy,kz,lnh) .lt. 1.e-5 ) THEN ! an(ix,jy,kz,lzh) = 0.9*an(ix,jy,kz,lzh) ENDIF ENDIF - + ENDIF if ( (an(ix,jy,kz,lh) .lt. frac*qxmin(lh)) .or. zerocx(lh) ) then @@ -12346,7 +12346,7 @@ subroutine smallvalues & IF ( lvh .gt. 1 ) THEN an(ix,jy,kz,lvh) = 0.0 ENDIF - + IF ( lhw .gt. 1 ) THEN an(ix,jy,kz,lhw) = 0.0 ENDIF @@ -12354,7 +12354,7 @@ subroutine smallvalues & IF ( lnhf .gt. 1 ) THEN an(ix,jy,kz,lnhf) = 0.0 ENDIF - + IF ( lzh .gt. 1 ) THEN an(ix,jy,kz,lzh) = 0.0 ENDIF @@ -12381,7 +12381,7 @@ subroutine smallvalues & ! tmpmx = xdnmx(lh) + fw*(xdnmx(lr) - xdnmx(lh)) ! maximum possible average density ! it is not exactly linear, but approx. is close enough for this ! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx - tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) )) + tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) )) IF ( tmp .gt. tmpmx ) THEN an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmpmx @@ -12403,7 +12403,7 @@ subroutine smallvalues & an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp ENDIF ENDIF - + ENDIF IF ( lvh .gt. 1 ) THEN @@ -12431,7 +12431,7 @@ subroutine smallvalues & ! 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*pi)**(1./3.) IF ( tmpg .lt. cnohmn ) THEN @@ -12440,7 +12440,7 @@ subroutine smallvalues & 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 @@ -12454,9 +12454,9 @@ subroutine smallvalues & an(ix,jy,kz,lnh) = chw xdia3 = (xvol*6.*piinv)**(1./3.) ENDIF - + ENDIF - + end if @@ -12466,12 +12466,12 @@ subroutine smallvalues & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) an(ix,jy,kz,ls) = 0.0 ! ENDIF - - IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! ! an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lns) an(ix,jy,kz,lns) = 0.0 ENDIF - + IF ( lvs .gt. 1 ) THEN an(ix,jy,kz,lvs) = 0.0 ENDIF @@ -12494,13 +12494,13 @@ subroutine smallvalues & an(ix,jy,kz,lsw) = 0.0 ENDIF - IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! ! an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns) an(ix,jy,kz,lns) = 0.0 ENDIF ENDIF - + ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN @@ -12528,7 +12528,7 @@ subroutine smallvalues & ! an(ix,jy,kz,lnc) = an(ix,jy,kz,lnc) + an(ix,jy,kz,lnr) an(ix,jy,kz,lnr) = 0.0 ENDIF - + IF ( lzr > 1 ) THEN an(ix,jy,kz,lzr) = 0.0 ENDIF @@ -12578,11 +12578,11 @@ subroutine smallvalues & 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 ) 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) + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) 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) @@ -12591,7 +12591,7 @@ subroutine smallvalues & ENDIF ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN ! in this case, we are treating the ccn field as ccna - tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) + 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) @@ -12604,7 +12604,7 @@ subroutine smallvalues & 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 - + ENDIF ENDIF @@ -12614,8 +12614,8 @@ subroutine smallvalues & end do ! end do end do - - + + end subroutine smallvalues !>\ingroup mod_nsslmp !! Main microphysical processes routine @@ -12652,11 +12652,11 @@ subroutine nssl_2mom_gs & ! !-------------------------------------------------------------------------- -! +! ! Ziegler 1985 parameterized microphysics (also Zrnic et al. 1993) ! 1) cloud water ! 2) rain -! 3) column ice +! 3) column ice ! 6) snow ! 11) graupel/hail ! @@ -12707,7 +12707,7 @@ subroutine nssl_2mom_gs & implicit none ! -! integer icond +! integer icond ! parameter ( icond = 2 ) integer, parameter :: ng1 = 1 @@ -12732,7 +12732,7 @@ 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 @@ -12743,7 +12743,7 @@ subroutine nssl_2mom_gs & real :: galpharaut real :: xvbarmax - + integer jyslab,its,ids,ide,jds,jde ! domain boundaries integer, intent(in) :: iunit !,iunit0 real qvex @@ -12757,14 +12757,14 @@ subroutine nssl_2mom_gs & real cpqc,cpci ! ,cpip,cpir real cpqc0,cpci0 ! ,cpip0,cpir0 real scfac ! ,cpip1 - + double precision dp1 - + double precision frac, frach, xvfrz, xvbiggsnow - + double precision :: timevtcalc double precision :: dpt1,dpt2 - + logical, parameter :: gammacheck = .false. integer :: luindex double precision :: tmpgam @@ -12777,19 +12777,19 @@ subroutine nssl_2mom_gs & ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg -! a few vars for time-split fallout +! a few vars for time-split fallout real vtmax integer n,ndfall - + double precision chgneg,chgpos,sctot - + real temgtmp 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 @@ -12816,7 +12816,7 @@ subroutine nssl_2mom_gs & ! real temele real trev - + logical ldovol, ishail, ltest, wtest logical , parameter :: alp0flag = .false. ! @@ -12878,7 +12878,7 @@ subroutine nssl_2mom_gs & real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) -! +! ! declarations microphyscs and for gather/scatter ! integer nxmpb,nzmpb,nxz @@ -12888,7 +12888,7 @@ subroutine nssl_2mom_gs & parameter (ntt=300) real dvmgs(ngs) - + integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs),kgsm2(ngs) integer ncuse @@ -12906,7 +12906,7 @@ subroutine nssl_2mom_gs & ! ! ! Variables for Ziegler warm rain microphysics -! +! real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) @@ -12920,7 +12920,7 @@ subroutine nssl_2mom_gs & ! =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 ) + 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 @@ -12937,14 +12937,14 @@ subroutine nssl_2mom_gs & double precision xl2p(ngs),rb(ngs) real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler ! snow parameters: - real, parameter :: cexs = 0.1, cecs = 0.5 + real, parameter :: cexs = 0.1, cecs = 0.5 real, parameter :: rvt = 0.104 ! ratio of collection kernels (Zrnic et al, 1993) real, parameter :: kfrag = 1.0e-6 ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) 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) real :: ec0(ngs) - + real ac1,bc, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super real :: flim, xmass real dw,dwr @@ -12988,16 +12988,16 @@ subroutine nssl_2mom_gs & real vgra,vfrz parameter ( vgra = 0.523599*(1.0e-3)**3 ) - + ! real, parameter :: epsi = 0.622 ! real, parameter :: d = 0.266 real :: d, dold, denom,denominv,vth double precision :: h1, h2, h3, h4,denomdp, denominvdp real r1,qevap ! ,slv - + real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas real :: snowmeltmass = 0 - + ! real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain real, parameter :: rimedens = 500. ! default rime density @@ -13009,12 +13009,12 @@ subroutine nssl_2mom_gs & parameter ( raero = 3.e-7, kaero = 5.39e-3 ) real kb ! Boltzman constant J K-1 parameter (kb = 1.3807e-23) - + real knud(ngs),knuda(ngs) !knudsen number and correction factor real gtp(ngs) !G(T,p) = 1/(a' + b') Cotton 72b real dfar(ngs) !aerosol diffusivity real fn1(ngs),fn2(ngs),fnft(ngs) - + real ccia(ngs) real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs) ! @@ -13023,13 +13023,13 @@ subroutine nssl_2mom_gs & real ni,nis,nr,d0 real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs),dqcitmp(ngs),dqwvtmp(ngs) real tempc(ngs) - real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) real temgkm1(ngs), temgkm2(ngs) real temgx(ngs),temcgx(ngs) real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) real elv(ngs),elf(ngs),els(ngs) real tsqr(ngs),ssi(ngs),ssw(ngs),ssi0(ngs) - real qcwtmp(ngs),qtmp,qtot(ngs) + real qcwtmp(ngs),qtmp,qtot(ngs) real qcond(ngs) real ctmp, sctmp real cimasn,cimasx,ccimx @@ -13044,15 +13044,15 @@ subroutine nssl_2mom_gs & real dh0 real dg0(ngs),df0(ngs) real dhwet(ngs),dhlwet(ngs),dfwet(ngs) - + real clionpmx,clionnmx parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 ! ! other arrays - real fwet1(ngs),fwet2(ngs) + real fwet1(ngs),fwet2(ngs) real fmlt1(ngs),fmlt2(ngs),fmlt1e(ngs) - real fvds(ngs),fvce(ngs),fiinit(ngs) + real fvds(ngs),fvce(ngs),fiinit(ngs) real fvent(ngs),fraci(ngs),fracl(ngs) ! real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs) @@ -13065,8 +13065,8 @@ subroutine nssl_2mom_gs & real fci(ngs),fcw(ngs) ! heat capacities of ice and liquid real fschm(ngs),fpndl(ngs) real fgamw(ngs),fgams(ngs) - real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) - + real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) + real cvm,cpm,rmm real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure @@ -13082,7 +13082,7 @@ subroutine nssl_2mom_gs & logical :: wetgrowth(ngs), wetgrowthhl(ngs), wetgrowthf(ngs) real qitmp(ngs),qistmp(ngs) - + real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs), rzxhlf(ngs) real rzxs(ngs), rzxf(ngs) ! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) @@ -13091,7 +13091,7 @@ subroutine nssl_2mom_gs & real vt2ave(ngs) real :: qcwresv(ngs), ccwresv(ngs) ! "reserved" droplet mass and number that are too small for accretion - + real :: lfsave(ngs,6) real :: qx(ngs,lv:lhab) real :: qxw(ngs,ls:lhab) @@ -13128,16 +13128,16 @@ subroutine nssl_2mom_gs & real :: felvcptmp,felscptmp,qsstmp real :: thetatmp, thetaptmp, temcgtmp,qvaptmp real :: qvstmp, qisstmp, qvptmp, qitmp1, qctmp1 - + real :: galphrout - + real ventrx(ngs) real ventrxn(ngs) real g1shr, alphashr real g1mlr, alphamlr real g1smlr, alphasmlr real massfacshr, massfacmlr - + real :: qhgt8mm ! ice mass greater than 8mm real :: qhwgt8mm ! ice + max water mass greater than 8mm real :: qhgt10mm ! mass greater than 10mm @@ -13145,7 +13145,7 @@ subroutine nssl_2mom_gs & real :: fwmhtmp ! 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, 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) @@ -13167,11 +13167,11 @@ subroutine nssl_2mom_gs & real qxd1, cxd1, zxd1 ! mass and number up to mltdiam1 real qxd05, cxd05 ! mass and number up to mltdiam1/2 real :: qrbreak, crbreaksmall, crbreak, zrbreak, breakbin - + real :: qxd(ndiam+4), cxd(ndiam+4), qhml(ndiam+4), qhml0(ndiam+4) real :: dqxd(ndiam+4), dcxd(ndiam+4), dqhml(ndiam+4) - - + + real civent(ngs) real isvent(ngs) ! @@ -13203,7 +13203,7 @@ subroutine nssl_2mom_gs & ! Hallett-Mossop arrays real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs) real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs) - + ! splinters from drop freezing real csplinter(ngs),qsplinter(ngs) real csplinter2(ngs),qsplinter2(ngs) @@ -13220,19 +13220,19 @@ subroutine nssl_2mom_gs & real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) real cicint(ngs) real cipint(ngs) - real ciacw(ngs), cwacii(ngs) + real ciacw(ngs), cwacii(ngs) real ciacr(ngs), craci(ngs) real csacw(ngs) real csacr(ngs) real csaci(ngs), csacs(ngs) - real cracw(ngs) + real cracw(ngs) real chacw(ngs), chacr(ngs) - real :: chlacw(ngs) + real :: chlacw(ngs) real chaci(ngs), chacs(ngs) ! real :: chlacr(ngs) real :: chlaci(ngs), chlacs(ngs) - real crcnw(ngs) + real crcnw(ngs) real cidpv(ngs),cisbv(ngs) real cisdpv(ngs),cissbv(ngs) real cimlr(ngs),cismlr(ngs) @@ -13279,13 +13279,13 @@ subroutine nssl_2mom_gs & real qsacws(ngs) ! -! arrays for x-ac-r and r-ac-x; +! arrays for x-ac-r and r-ac-x; ! real qsacr(ngs),qracs(ngs) real qhacr(ngs),qhacrmlr(ngs),qhacwmlr(ngs) ! ,qrach(ngs) real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) real qiacr(ngs),qraci(ngs) - + real ziacr(ngs) real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) @@ -13301,8 +13301,8 @@ subroutine nssl_2mom_gs & real qhaci(ngs) real qhacs(ngs) - real :: qhacis(ngs) - real :: chacis(ngs) + real :: qhacis(ngs) + real :: chacis(ngs) real :: chacis0(ngs) real :: csaci0(ngs) ! collision rate only @@ -13312,18 +13312,18 @@ subroutine nssl_2mom_gs & real :: chlaci0(ngs) real :: chlacis(ngs) real :: chlacis0(ngs) - real :: chlacs0(ngs) + real :: chlacs0(ngs) real :: qsaci0(ngs) ! collision rate only real :: qsacis0(ngs) ! collision rate only real :: qhaci0(ngs) ! collision rate only real :: qhacis0(ngs) ! collision rate only real :: qhacs0(ngs) ! collision rate only - real :: qhlaci0(ngs) + real :: qhlaci0(ngs) real :: qhlacis0(ngs) - real :: qhlacs0(ngs) + real :: qhlacs0(ngs) - real :: qhlaci(ngs) + real :: qhlaci(ngs) real :: qhlacis(ngs) real :: qhlacs(ngs) ! @@ -13347,7 +13347,7 @@ subroutine nssl_2mom_gs & real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs) - + real vrfrzf(ngs), viacrf(ngs) real qrfrzs(ngs), qrfrzf(ngs) real qwfrz(ngs), qwctfz(ngs) @@ -13395,7 +13395,7 @@ subroutine nssl_2mom_gs & real qhfzh(ngs) !water that freezes on mixed-phase graupel real qffzf(ngs) !water that freezes on mixed-phase FD real qhlfzhl(ngs) !water that freezes on mixed-phase hail - + real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters real qhfzhlg(ngs) !water that freezes on mixed-phase graupel (large sizes) real qhlfzhllg(ngs) !water that freezes on mixed-phase hail (large sizes) @@ -13411,7 +13411,7 @@ subroutine nssl_2mom_gs & real vhlmlr(ngs) !melt water that leaves hail (single phase) real vhsoak(ngs) ! aquired water that seeps into graupel. real vhlsoak(ngs) ! aquired water that seeps into hail. - + ! real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs), real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) @@ -13436,7 +13436,7 @@ subroutine nssl_2mom_gs & real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs) real qgmshrp(ngs) real qghdpv(ngs),qghsbv(ngs) - real qghmlr(ngs),qghdsv(ngs) + real qghmlr(ngs),qghdsv(ngs) real qghwet(ngs),qghdry(ngs),qghshr(ngs) real qghshrp(ngs) ! @@ -13446,22 +13446,22 @@ subroutine nssl_2mom_gs & real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions real ffwmax(ngs) - real qhcnf(ngs) + real qhcnf(ngs) real :: qhlcnh(ngs) real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) - + real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs),eisw(ngs) real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs) 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 ehxr(ngs),ehlr(ngs),egmr(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) - real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) + real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs) @@ -13472,7 +13472,7 @@ subroutine nssl_2mom_gs & real :: efs_collsn = 0.5, efi_collsn = 1.0 real :: ehls_collsn = 1.0, ehli_collsn = 1.0 real :: esi_collsn = 1.0 - + real ew(8,6) real cwr(8,2) ! radius and inverse of interval data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius @@ -13498,7 +13498,7 @@ subroutine nssl_2mom_gs & real da0lhl(ngs) real da0lf(ngs) real :: da0lx(ngs,lr:lhab) - + real va0 (lc:lqmx) ! collection coefficients from Seifert 2005 real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 real vab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 @@ -13519,12 +13519,12 @@ subroutine nssl_2mom_gs & real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs),pqlwfi(ngs) - + real pqlwlghi(ngs),pqlwlghli(ngs) real pqlwlghd(ngs),pqlwlghld(ngs) - - - + + + real pvhwi(ngs), pvhwd(ngs) real pvfwi(ngs), pvfwd(ngs) @@ -13578,7 +13578,7 @@ subroutine nssl_2mom_gs & real thsave(ngs) real ptwfzi(ngs),ptimlw(ngs) real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs),ptem2(ngs) - + real cnostmp(ngs) ! for diagnosed snow intercept ! ! iholef = 1 to do hole filling technique version 1 @@ -13627,14 +13627,14 @@ subroutine nssl_2mom_gs & real cglfac real cghfac real chfac - + real ssifac, qvapor ! ! Miscellaneous variables ! real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. - integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh + integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh integer lqrw real vt real arg ! gamma is a function @@ -13644,10 +13644,10 @@ subroutine nssl_2mom_gs & real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds real gf1palp(ngs) ! for storing Gamma[1.0 + alphar] - + real xdn0(lc:lhab) real xdn_new,drhodt - + integer l ,ltemq,inumgs, idelq real brz,arz,temq @@ -13667,7 +13667,7 @@ subroutine nssl_2mom_gs & real hwventc, hlventa, hlventb, hlventc real glventa, glventb, glventc real gmventa, gmventb, gmventc, ghventa, ghventb, ghventc - real dzfacp, dzfacm, cmassin, cwdiar + real dzfacp, dzfacm, cmassin, cwdiar real rimmas, rhobar real argtim, argqcw, argqxw, argtem real frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1 @@ -13694,20 +13694,20 @@ subroutine nssl_2mom_gs & real cgmfac, chlfac, cirfac integer igmhla, igmhlb, igmgla, igmglb, igmgma, igmgmb integer igmgha, igmghb - integer idqis, item, itim0 - integer iqgl, iqgm, iqgh, iqrw, iqsw + integer idqis, item, itim0 + integer iqgl, iqgm, iqgh, iqrw, iqsw integer itertd, ia - + integer :: infdo - + real tau, ewtmp - + integer cntnic_noliq real q_noliqmn, q_noliqmx real scsacimn, scsacimx - + real :: dtpinv - + ! arrays for temporary bin space real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt @@ -13794,7 +13794,7 @@ subroutine nssl_2mom_gs & ! DO il = lc,lhab ! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) ! ENDDO - + ! ! density maximums and minimums ! @@ -13837,7 +13837,7 @@ subroutine nssl_2mom_gs & cs = 12.42 ds = 0.42 pii = piinv ! 1./pi - pid4 = pi/4.0 + pid4 = pi/4.0 ! qscrit = 6.0e-04 gf1 = 1.0 ! gamma(1.0) gf1p5 = 0.8862269255 ! gamma(1.5) @@ -13858,10 +13858,10 @@ subroutine nssl_2mom_gs & gf53rds = 0.9027452930 ! gamma(5./3.) gf73rds = 1.190639349 ! gamma(7./3.) gf83rds = 1.504575488 ! gamma(8./3.) - + gamice73fac = (Gamma_sp(7./3. + cinu))**3/ (Gamma_sp(1. + cinu)**3 * (1. + cinu)**4) gamsnow73fac = (Gamma_sp(7./3. + snu))**3/ (Gamma_sp(1. + snu)**3 * (1. + snu)**4) - + ! gcnup1 = Gamma_sp(cnu + 1.) ! gcnup2 = Gamma_sp(cnu + 2.) ! @@ -13872,14 +13872,14 @@ subroutine nssl_2mom_gs & ! brz = 100.0 arz = 0.66 - + bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/ & & ((1. + alphar)*(2. + alphar)*(3. + alphar)) galpharaut = (6.+alpharaut)*(5.+alpharaut)*(4.+alpharaut)/ & & ((3.+alpharaut)*(2.+alpharaut)*(1.+alpharaut)) - - vfrz = 0.523599*(dfrz)**3 + + vfrz = 0.523599*(dfrz)**3 vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) @@ -13890,7 +13890,7 @@ subroutine nssl_2mom_gs & tdtol = 1.0e-05 tfrcbw = tfr - cbw tfrcbi = tfr - cbi - + IF ( mixedphase ) THEN ibinhmlr = 0 ibinhlmlr = 0 @@ -13914,10 +13914,10 @@ subroutine nssl_2mom_gs & mltmass1inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize1)**3) ) ! for drops melting from ice with diameter > 1.9cm; 0.01 converts cm to m, 0.5 conv. diam to radius mltmass2inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize2)**3) ) ! for drops melting from ice with 0.9cm < d < 1.9cm (or 1.6cm to 1.9cm) mltmass3inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize3)**3) ) ! for drops melting from ice with 0.9cm < d < 1.6cm - mltmass1cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3) - mltmass2cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3) - mltmass3cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize3)**3) - + mltmass1cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3) + mltmass2cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3) + mltmass3cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize3)**3) + ! real, parameter :: mltdiam1 = 9.0e-3, mltdiam2 = 19.0e-3, mltdiam05 = 4.5e-3 IF ( ibinnum == 1 ) THEN @@ -13932,7 +13932,7 @@ subroutine nssl_2mom_gs & DO k = 1,numdiam mltdiam(k) = (k - 0.5)*mltdiam1/float(numdiam) ENDDO - + ELSE numdiam = 5 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) mltdiam(1) = 0.5e-3 @@ -14008,8 +14008,8 @@ subroutine nssl_2mom_gs & ! VERY IMPORTANT: SET jy = jgs ! jy = jgs - - + + ! t1(:,:,:) = 0 ! t2(:,:,:) = 0 ! t3(:,:,:) = 0 @@ -14017,7 +14017,7 @@ subroutine nssl_2mom_gs & ! t5(:,:,:) = 0 ! t6(:,:,:) = 0 ! t8(:,:,:) = 0 - + IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing DO kz = 1,kze DO ix = 1,itile @@ -14025,14 +14025,14 @@ subroutine nssl_2mom_gs & ENDDO ENDDO ENDIF - + ! -!..Gather microphysics +!..Gather microphysics ! if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE' - + nxmpb = 1 nzmpb = 1 nxz = itile*nz @@ -14041,7 +14041,7 @@ subroutine nssl_2mom_gs & do 1000 inumgs = 1,numgs ngscnt = 0 - + do kz = nzmpb,kze do ix = nxmpb,itile @@ -14079,7 +14079,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. & & an(ix,jy,kz,li) .gt. qxmin(li) .or. & @@ -14099,10 +14099,10 @@ subroutine nssl_2mom_gs & if ( ngscnt .eq. 0 ) go to 9998 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 @@ -14169,7 +14169,7 @@ subroutine nssl_2mom_gs & il5(mgs) = 1 end if enddo !mgs - + IF ( ipconc < 1 .and. lwsm6 ) THEN DO mgs = 1,ngscnt tmp = Min( 0.0, temcg(mgs) ) @@ -14182,14 +14182,14 @@ subroutine nssl_2mom_gs & ! zero arrays that are used but not otherwise set (tm) ! do mgs = 1,ngscnt - qhshr(mgs) = 0.0 + qhshr(mgs) = 0.0 end do ! ! set temporaries for microphysics variables ! DO il = lv,lhab do mgs = 1,ngscnt - qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) ENDDO end do @@ -14203,10 +14203,10 @@ 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 cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) @@ -14290,7 +14290,7 @@ subroutine nssl_2mom_gs & IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN ! cx(mgs,lh) = 0.0 ELSEIF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) qx(mgs,lh) = 0.0 ELSE cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) ) @@ -14317,7 +14317,7 @@ subroutine nssl_2mom_gs & 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,lv) = qx(mgs,lv) + qx(mgs,lhl) + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) qx(mgs,lhl) = 0.0 ELSE cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) ) @@ -14339,13 +14339,13 @@ subroutine nssl_2mom_gs & ! Set mean particle volume ! IF ( ldovol ) THEN - + vx(:,:) = 0.0 - + DO il = li,lhab - + IF ( lvol(il) .ge. 1 ) THEN - + DO mgs = 1,ngscnt vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) ENDDO @@ -14394,10 +14394,10 @@ subroutine nssl_2mom_gs & g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) - + DO mgs = 1,ngscnt IF ( cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN - + vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) IF ( lzr < 1 ) THEN IF ( imurain == 3 ) THEN @@ -14406,11 +14406,11 @@ subroutine nssl_2mom_gs & zx(mgs,lr) = 3.6476*g1x(mgs,lr)*cx(mgs,lr)*vr**2 ENDIF ENDIF - + ENDIF ENDDO ENDIF - + ENDIF @@ -14436,7 +14436,7 @@ subroutine nssl_2mom_gs & ELSEIF ( imurain == 3 ) THEN alpha(:,lr) = xnu(lr) ENDIF - + alpha(:,li) = xnu(li) alpha(:,lc) = xnu(lc) @@ -14447,7 +14447,7 @@ subroutine nssl_2mom_gs & ENDIF if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set dab' - + DO il = lr,lhab do mgs = 1,ngscnt IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) @@ -14460,7 +14460,7 @@ subroutine nssl_2mom_gs & end do ENDDO - + ! DO mgs = 1,ngscnt DO il = lr,lhab da0lx(:,il) = da0(il) @@ -14485,20 +14485,20 @@ subroutine nssl_2mom_gs & rzxh(:) = rz rzxhl(:) = rzhl ENDIF - + IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN rzxs(:) = rzs ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN rzxs(:) = 1. ENDIF ! ENDDO - + IF ( lhl .gt. 1 ) THEN DO mgs = 1,ngscnt da0lhl(mgs) = da0(lhl) ENDDO ENDIF - + ventrx(:) = ventr ventrxn(:) = ventrn gf1palp(:) = gamma_sp(1.0 + alphar) @@ -14528,16 +14528,16 @@ subroutine nssl_2mom_gs & ! felvs(mgs) = felv(mgs)*felv(mgs) felss(mgs) = fels(mgs)*fels(mgs) - + IF ( eqtset <= 1 ) THEN felvcp(mgs) = felv(mgs)*cpi felscp(mgs) = fels(mgs)*cpi felfcp(mgs) = felf(mgs)*cpi ELSE - + ! equations from appendix in Bryan and Morrison (2012, MWR) ! note that rw is Rv in the paper, and rd is R. - + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & @@ -14547,22 +14547,22 @@ subroutine nssl_2mom_gs & felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm felfcp(mgs) = felf(mgs)/cvm - + ELSE ! equivalent version that applies separate updates of latent heating to theta and pi, when both are returned. cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) rmm=rd+rw*qx(mgs,lv) - + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm felscp(mgs) = (fels(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm felfcp(mgs) = felf(mgs)*cv/(cp*cvm) felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm - felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm felfpi(mgs) = pi0(mgs)*rovcp*(felf(mgs)/(cvm*temg(mgs))) - + ENDIF ENDIF @@ -14650,11 +14650,11 @@ subroutine nssl_2mom_gs & ENDIF xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) ) vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) - + ELSEIF ( vx(mgs,lh) == 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN ! if volume is zero, need to initialize the default value vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) - + ENDIF ENDIF @@ -14675,11 +14675,11 @@ subroutine nssl_2mom_gs & xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) xdntmp(mgs,lhl) = xdn(mgs,lhl) - + ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) - + ENDIF ENDIF @@ -14691,12 +14691,12 @@ subroutine nssl_2mom_gs & IF ( ipconc == 5 .and. imydiagalpha == 2 ) THEN cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) - + DO mgs = 1,ngscnt !IF ( igs(mgs) == 19 ) write(0,*) 'k,qr,qh,cr,ch = ',kgs(mgs),qx(mgs,lr),cx(mgs,lr),qx(mgs,lh),cx(mgs,lh) IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN - xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! - xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! + xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) ! alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000. @@ -14717,7 +14717,7 @@ subroutine nssl_2mom_gs & ENDIF IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN ! MY 2005: - xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) ! alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) @@ -14736,7 +14736,7 @@ subroutine nssl_2mom_gs & alpha(mgs,lh) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.) ! alphan(mgs,lh) = alpha(mgs,lh) - + ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alph,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lh),xdia(mgs,lh,3)*1000. il = lh DO ic = lc,lh-1 ! lhab @@ -14748,7 +14748,7 @@ subroutine nssl_2mom_gs & alp = alpha(mgs,ic) j = Nint( alpha(mgs,ic)*dqiacralphainv ) ENDIF - + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) @@ -14759,7 +14759,7 @@ subroutine nssl_2mom_gs & ! alpha(:,lh) = 0. ! 10. IF ( lhl > 0 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN - xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.) IF ( xdia(mgs,lhl,3) < 0.008 ) THEN alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl) @@ -14777,7 +14777,7 @@ subroutine nssl_2mom_gs & alp = alpha(mgs,ic) j = Nint( alpha(mgs,ic)*dqiacralphainv ) ENDIF - + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) @@ -14791,7 +14791,7 @@ subroutine nssl_2mom_gs & ENDDO ENDIF - + IF ( imurain == 3 ) THEN IF ( lzr > 1 ) THEN @@ -14822,17 +14822,17 @@ subroutine nssl_2mom_gs & massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) ENDIF - + ! Find shape parameter rain g1shr = 1.0 g1mlr = 1.0 g1smlr = 1.0 - -! CALL cld_cpu('Z-MOMENT-1') - + +! CALL cld_cpu('Z-MOMENT-1') + IF ( ipconc >= 6 ) THEN - + ! set base g1x in case rain is not 3-moment IF ( ipconc >= 6 .and. imurain == 3 ) THEN il = lr @@ -14862,12 +14862,12 @@ subroutine nssl_2mom_gs & ENDIF IF ( lzr > 1 .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM - - -! CALL cld_cpu('Z-MOMENT-1r') + + +! CALL cld_cpu('Z-MOMENT-1r') il = lr DO mgs = 1,ngscnt - + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) THEN IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN @@ -14886,9 +14886,9 @@ subroutine nssl_2mom_gs & an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN - + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) zx(mgs,lr) = 0.0 qx(mgs,lr) = 0.0 @@ -14908,7 +14908,7 @@ subroutine nssl_2mom_gs & an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) ENDIF - + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) @@ -14941,14 +14941,14 @@ subroutine nssl_2mom_gs & ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) z = zx(mgs,il) qr = qx(mgs,il) cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) ENDIF - + IF ( zx(mgs,lr) > 0.0 ) THEN xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) vr = xv(mgs,lr) @@ -14980,7 +14980,7 @@ subroutine nssl_2mom_gs & x3 = x2**3 cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) - ELSE ! simple cutoff + ELSE ! simple cutoff xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) @@ -15009,12 +15009,12 @@ subroutine nssl_2mom_gs & alp = Max( rnumin, Min( rnumax, alp ) ) ENDDO - + ENDIF ENDIF ! -! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the ! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) ! g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) @@ -15023,15 +15023,15 @@ subroutine nssl_2mom_gs & IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) - + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) zx(mgs,il) = z an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) ENDIF ENDIF - - ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then + + ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates ! stay consistent with dN/dt and dq/dt. @@ -15042,7 +15042,7 @@ subroutine nssl_2mom_gs & ELSE g1x(mgs,il) = g1 ENDIF - + tmp = alpha(mgs,lr) + 4./3. i = Int(dgami*(tmp)) del = tmp - dgam*i @@ -15052,7 +15052,7 @@ subroutine nssl_2mom_gs & i = Int(dgami*(tmp)) del = tmp - dgam*i y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - + gf1palp(mgs) = y ! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.) @@ -15067,7 +15067,7 @@ subroutine nssl_2mom_gs & ! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) - + ! This whole section is imurain == 3, so this branch never runs ! ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN ! @@ -15078,26 +15078,26 @@ subroutine nssl_2mom_gs & ! !! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) ! ventrxn(mgs) = x/y - - + + ENDIF - + ENDIF ENDIF - + ENDIF - + ENDDO -! CALL cld_cpu('Z-MOMENT-1r') +! CALL cld_cpu('Z-MOMENT-1r') ENDIF ! } - + ENDIF ! ipconc >= 6 ! Find shape parameters for graupel and hail IF ( ipconc .ge. 6 ) THEN - + DO il = lr,lhab - + ! set base values of g1x IF ( (.not. ( il == lr .and. imurain == 3 )) .and. ( il == lr .or. il == lh .or. il == lhl .or. il == lf ) ) THEN DO mgs = 1,ngscnt @@ -15105,9 +15105,9 @@ subroutine nssl_2mom_gs & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) ENDDO ENDIF - + IF ( lz(il) .gt. 1 .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN - + DO mgs = 1,ngscnt @@ -15130,7 +15130,7 @@ subroutine nssl_2mom_gs & an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) zx(mgs,il) = 0.0 @@ -15153,7 +15153,7 @@ subroutine nssl_2mom_gs & an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) ENDIF - + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) @@ -15193,7 +15193,7 @@ subroutine nssl_2mom_gs & ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) z = zx(mgs,il) @@ -15202,13 +15202,13 @@ subroutine nssl_2mom_gs & cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) ELSE - + chw = cx(mgs,il) qr = qx(mgs,il) z = zx(mgs,il) IF ( zx(mgs,il) .gt. 0. ) THEN - + ! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) @@ -15218,7 +15218,7 @@ subroutine nssl_2mom_gs & & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 ! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv alp = Max( alphamin, Min( alphamax, alp ) ) - + IF ( newton ) THEN DO i = 1,10 IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT @@ -15226,7 +15226,7 @@ subroutine nssl_2mom_gs & alp = alp + ( galpha(alp) - rdi )/dgalpha(alp) alp = Max( alphamin, Min( alphamax, alp ) ) ENDDO - + ELSE DO i = 1,10 ! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT @@ -15244,13 +15244,13 @@ subroutine nssl_2mom_gs & ! check for artificial breakup (graupel/hail larger than allowed max size) IF ( imaxdiaopt == 1 .or. il /= lr ) THEN - xvbarmax = xvmx(il) + xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) ELSE - xvbarmax = xvmx(il) + xvbarmax = xvmx(il) ENDIF IF ( xv(mgs,il) .gt. xvbarmax .or. (il == lr .and. ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.)) THEN @@ -15297,17 +15297,17 @@ subroutine nssl_2mom_gs & alp = Max( alphamin, Min( alphamax, alp ) ) ENDDO - + ENDIF ENDIF ! -! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the ! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) ! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) - + IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. & & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN @@ -15316,29 +15316,29 @@ subroutine nssl_2mom_gs & IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) - + ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. & .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C wtest = .false. IF ( irescalerainopt == 0 ) THEN wtest = .false. ELSEIF ( irescalerainopt == 1 ) THEN - wtest = qx(mgs,lc) > qxmin(lc) + wtest = qx(mgs,lc) > qxmin(lc) ELSEIF ( irescalerainopt == 2 ) THEN wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh ELSEIF ( irescalerainopt == 3 ) THEN wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh ENDIF - + IF ( il == lr .and. ( wtest ) ) THEN ! IF ( temcg(mgs) > 0.0 .and. il == lr .and. qx(mgs,lc) > qxmin(lc) ) THEN - ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted + ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted ! drops (i.e., favor preserving Z when alpha tries to go negative) chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1 cx(mgs,il) = chw an(igs(mgs),jy,kgs(mgs),ln(il)) = chw ELSE - + ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw z = z1*(6./(pi*xdn(mgs,il)))**2 @@ -15347,9 +15347,9 @@ subroutine nssl_2mom_gs & ENDIF ENDIF ENDIF - - - ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then + + + ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates ! stay consistent with dN/dt and dq/dt. @@ -15362,20 +15362,20 @@ subroutine nssl_2mom_gs & ELSE g1x(mgs,il) = g1 ENDIF - + ENDIF - + ! IF ( ny .eq. 2 ) THEN ! IF ( qr .gt. 1.e-3 ) THEN ! write(0,*) 'alphah at nstep,i,k = ',dtp*(nstep-1),igs(mgs),kgs(mgs),alpha(mgs,il),qr*1000. ! ENDIF ! ENDIF - - + + ENDIF ! .true. IF ( il == lr ) THEN - + ! tmp = alpha(mgs,lr) + 4./3. ! i = Int(dgami*(tmp)) ! del = tmp - dgam*i @@ -15406,12 +15406,12 @@ subroutine nssl_2mom_gs & ventrxn(mgs) = x/y - + ENDIF - + ENDIF ! il==lr - - + + ELSE ! below mass threshold ! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ ! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) @@ -15421,25 +15421,25 @@ subroutine nssl_2mom_gs & ! zx(mgs,il) = z ! an(igs(mgs),jy,kgs(mgs),lz(il)) = z ENDIF ! ( qx(mgs,il) .gt. qxmin(il) ) - - - + + + ! ENDIF ENDDO ! mgs -! CALL cld_cpu('Z-DELABK') - +! CALL cld_cpu('Z-DELABK') + ! IF ( il == lr ) THEN ! xnutmp = (alpha(mgs,il) - 2.)/3. ! da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) ! ENDIF - + IF ( .not. ( il == lr .and. imurain == 3 ) ) THEN -! CALL cld_cpu('Z-DELABK') +! CALL cld_cpu('Z-DELABK') DO mgs = 1,ngscnt IF ( qx(mgs,il) > qxmin(il) ) THEN xnutmp = (alpha(mgs,il) - 2.)/3. - + ! IF ( .true. ) THEN DO ic = lc,lh-1 ! lhab IF ( il .ne. ic .and. qx(mgs,ic) .gt. qxmin(ic)) THEN @@ -15467,7 +15467,7 @@ subroutine nssl_2mom_gs & alp = alpha(mgs,ic) j = Nint( alpha(mgs,ic)*dqiacralphainv ) ENDIF - + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) @@ -15481,7 +15481,7 @@ subroutine nssl_2mom_gs & ! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 1) !dab1(il,ic) ! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic) ! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic) - + IF ( .false. .and. ny <= 2 ) THEN write(0,*) write(0,*) 'bb: ', bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic) @@ -15490,16 +15490,16 @@ subroutine nssl_2mom_gs & write(0,*) 'dab1lh,tmp2 = ',dab1lh(mgs,ic,il),tmp2 write(0,*) 'dab0lh,tmp3 = ',dab0lh(mgs,il,ic),tmp3,tmp5 write(0,*) 'dab1lh,tmp4 = ',dab1lh(mgs,il,ic),tmp4,tmp6 - + ENDIF - + ENDIF - + ENDIF ENDDO ! ENDIF - + da0lx(mgs,il) = delbk(bb(il), xnutmp, xmu(il), 0) IF ( il .eq. lh ) THEN da0lh(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) @@ -15509,7 +15509,7 @@ subroutine nssl_2mom_gs & rzxh(mgs) = ((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))) ENDIF - + IF ( lzhl < 1 ) THEN rzxhlh(mgs) = rzxhl(mgs)/(((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))) @@ -15527,21 +15527,21 @@ subroutine nssl_2mom_gs & da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) da1lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 1) ENDIF - + ENDIF ! ( qx(mgs,il) > qxmin(il) ) ENDDO ! mgs -! CALL cld_cpu('Z-DELABK') +! CALL cld_cpu('Z-DELABK') ENDIF ! il /= lr -! CALL cld_cpu('Z-DELABK') - +! CALL cld_cpu('Z-DELABK') + ENDIF ! lz(il) .gt. 1 - + ENDDO ! il - + ENDIF ! ipconc .ge. 6 -! CALL cld_cpu('Z-MOMENT-1') +! CALL cld_cpu('Z-MOMENT-1') ! ! set some values for ice nucleation @@ -15551,7 +15551,7 @@ 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)) @@ -15632,17 +15632,17 @@ subroutine nssl_2mom_gs & if ( qx(mgs,lh) .gt. qxmin(lh) ) then ! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) ! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) -! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) +! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) end if ENDIF ! ( ipconc .lt. 5 ) end do 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.) xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) @@ -15659,10 +15659,10 @@ subroutine nssl_2mom_gs & ENDIF ENDDO ENDIF - + +! ! ! -! ! ! maximum depletion tendency by any one source ! @@ -15672,9 +15672,9 @@ subroutine nssl_2mom_gs & endif do mgs = 1,ngscnt qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))*dtpinv ! depletion by all vap. dep to ice. - + IF ( qx(mgs,lc) < qxmin(lc) ) qvimxd(mgs) = 0.99*(qx(mgs,lv)-qis(mgs))*dtpinv ! this makes virtually no difference whatsoever, but what the heck - + qvimxd(mgs) = max(qvimxd(mgs), 0.0) frac = 0.1d0 @@ -15767,7 +15767,7 @@ subroutine nssl_2mom_gs & maxmassfac(ls) = (3.0 + alphas)**3/ & & ((3.+alphas)*(2.+alphas)*(1. + alphas) ) ENDIF - + maxmassfac(lh) = (3.0 + alphah)**3/ & & ((3.+alphah)*(2.+alphah)*(1. + alphah) ) @@ -15775,16 +15775,16 @@ subroutine nssl_2mom_gs & maxmassfac(lhl) = (3.0 + alphahl)**3/ & & ((3.+alphahl)*(2.+alphahl)*(1. + alphahl) ) ENDIF - + DO mgs = 1,ngscnt DO il = lh,lhab ! graupel and hail only (and frozen drops) - + vshdgs(mgs,il) = vshd ! base value - + IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) THEN - + ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. ! tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 tmpdiam = (shedalp+0.0)*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 @@ -15803,7 +15803,7 @@ subroutine nssl_2mom_gs & ! ! -! microphysics source terms (1/s) for mixing ratios +! microphysics source terms (1/s) for mixing ratios ! ! ! @@ -15817,7 +15817,7 @@ subroutine nssl_2mom_gs & ! qcwresv(mgs) = 0.0 ccwresv(mgs) = 0.0 - + erw(mgs) = 0.0 esw(mgs) = 0.0 ehw(mgs) = 0.0 @@ -15862,17 +15862,17 @@ subroutine nssl_2mom_gs & IF ( exwmindiam > 0 .and. qx(mgs,lc) > qxmin(lc) ) THEN tmp = cx(mgs,lc)*Exp(- (exwmindiam/xdia(mgs,lc,1))**3 ) ccwresv(mgs) = Min( cx(mgs,lc), Max( 2.e6, cx(mgs,lc) - tmp ) ) - + tmp = cx(mgs,lc) - ccwresv(mgs) volt = pi/6.*(exwmindiam)**3 qcwresv(mgs) = qx(mgs,lc) - tmp*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) - - + + IF ( .false. .and. qx(mgs,lc) > 0.1e-3 ) THEN - + write(0,*) 'cx,qx,crsv,qrsv = ',cx(mgs,lc),qx(mgs,lc),ccwresv(mgs),qcwresv(mgs) - + ENDIF ENDIF @@ -15929,7 +15929,7 @@ subroutine nssl_2mom_gs & ! if ( temg(mgs) .lt. 243.15 .and. qx(mgs,lc) .gt. 1.e-6 ) then ! eii(mgs)=0.1 ! end if -! +! ! ELSE eii(mgs) = exp(0.025*Min(temcg(mgs),0.0)) ! alpha1 from LFO83 (21) ! ENDIF @@ -15943,8 +15943,8 @@ subroutine nssl_2mom_gs & ! eiw(mgs) = 0.0 if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then - - + + if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then ! erm 5/10/2007 test following change: ! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then @@ -15981,7 +15981,7 @@ subroutine nssl_2mom_gs & irp1 = Min( 6, ir+1 ) cwrad = 0.5*xdia(mgs,lc,3) rwrad = 0.5*xdia(mgs,lr,3) - + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) @@ -16053,21 +16053,21 @@ subroutine nssl_2mom_gs & esr(mgs)=Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,ls,1)) IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1 end if - + IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN il3(mgs) = 1 ENDIF ! ! if ( qx(mgs,ls).gt.qxmin(ls) ) then if ( temcg(mgs) < 0.0 ) then - + IF ( ipconc .lt. 4 .or. temcg(mgs) < esstem1 ) THEN ess(mgs) = 0.0 ! ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) ! ess(mgs)=min(0.1,ess(mgs)) - + ELSE - + fac = Abs(ess0) IF ( iessopt == 2 ) THEN ! experimental code ! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN @@ -16094,13 +16094,13 @@ subroutine nssl_2mom_gs & ehsfac(mgs) = Max(0.1, (ssi(mgs) - 1.0)/0.005) ENDIF ENDIF - + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > esstem1 ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2 ELSEIF ( temcg(mgs) >= esstem2 ) THEN ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) ENDIF - + ENDIF end if ! @@ -16141,7 +16141,7 @@ subroutine nssl_2mom_gs & ehw(mgs) = Min( ehw0, & & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & & (cradcw + cwrad*(dradcw)))), 1.0) ) - + ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN ic = icwr(mgs) icp1 = Min( 8, ic+1 ) @@ -16149,17 +16149,17 @@ subroutine nssl_2mom_gs & irp1 = Min( 6, ir+1 ) cwrad = 0.5*xdia(mgs,lc,1) rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter - + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) - + ! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) - + slope1 = (x2 - x1)*grad(ir,2) - + tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) ) ehw(mgs) = Min( ehw(mgs), tmp ) @@ -16185,10 +16185,10 @@ subroutine nssl_2mom_gs & if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0 ehw(mgs) = Min( ehw0, ehw(mgs) ) - + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN ehw(mgs) = 0.0 - ENDIF + ENDIF end if !} ! @@ -16207,7 +16207,7 @@ subroutine nssl_2mom_gs & ELSE ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) ENDIF - + IF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) THEN ! ehsclsn(mgs) = ehs_collsn ! ehs(mgs) = ehscnv(mgs)*ehsfac(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) @@ -16243,7 +16243,7 @@ subroutine nssl_2mom_gs & end if ENDIF - + ! ! ! Hail: Collection (cxc) efficiencies @@ -16262,7 +16262,7 @@ subroutine nssl_2mom_gs & ehlw(mgs) = Min( ehlw0, & & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & & (cradcw + cwrad*(dradcw)))), 1.0) ) - + ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN ic = icwr(mgs) icp1 = Min( 8, ic+1 ) @@ -16270,15 +16270,15 @@ subroutine nssl_2mom_gs & irp1 = Min( 6, ir+1 ) cwrad = 0.5*xdia(mgs,lc,1) rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter - + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) - + x1 = ew(ic, ir) + slope1*(cwrad - cwr(ic,1)) x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1)) - + slope1 = (x2 - x1)*grad(ir,2) - + tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) ) ehlw(mgs) = Min( ehlw(mgs), tmp ) ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) @@ -16300,9 +16300,9 @@ subroutine nssl_2mom_gs & if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0 ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) - IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN ehlw(mgs) = 0.0 - ENDIF + ENDIF end if ! @@ -16374,8 +16374,8 @@ subroutine nssl_2mom_gs & ! end if ! end do - - + + ! ! @@ -16406,7 +16406,7 @@ subroutine nssl_2mom_gs & ENDIF ELSE - IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN rwrad = 0.5*xdia(mgs,lr,3) IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN IF ( rwrad .gt. rwradmn ) THEN @@ -16427,17 +16427,17 @@ subroutine nssl_2mom_gs & ! save multiplies by converting cx*xdn*xv/rho0 to qx qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & - & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) - + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + ELSE ! imurain == 1 qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & - & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) - + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) + ENDIF - + ENDIF ENDIF ENDIF @@ -16604,7 +16604,7 @@ subroutine nssl_2mom_gs & ! > + gf1*xdia(mgs,li,2) ) ! < , qimxd(mgs)) ENDIF - ELSE ! + ELSE ! IF ( esi(mgs) .gt. 0.0 ) THEN qsaci(mgs) = & & min( & @@ -16626,12 +16626,12 @@ subroutine nssl_2mom_gs & csacr(mgs) = 0.0 IF ( esr(mgs) .gt. 0.0 ) THEN IF ( ipconc .ge. 3 ) THEN -! vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 + +! vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 + ! : 0.04*vtxbar(mgs,ls,1)*vtxbar(mgs,lr,1) ) ! qsacr(mgs) = esr(mgs)*cx(mgs,ls)*vt* ! : qx(mgs,lr)*0.25*pi* -! : (3.02787*xdia(mgs,lr,2) + -! : 3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) + +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) + ! : 2.*xdia(mgs,ls,2)) ! qsacr(mgs) = Min( qsacr(mgs), qrmxd(mgs) ) ! csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr) @@ -16642,7 +16642,7 @@ subroutine nssl_2mom_gs & ELSE vt = vtxbar(mgs,ls,1) ENDIF - + qsacr(mgs) = & & min( & & ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls) & @@ -16667,7 +16667,7 @@ subroutine nssl_2mom_gs & vhacw(mgs) = 0.0 vhsoak(mgs) = 0.0 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)) @@ -16678,27 +16678,27 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 2 ) THEN - IF ( .false. ) THEN + IF ( .false. ) THEN qhacw(mgs) = (ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh)*pi* & & abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* & & (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + & & xdia(mgs,lc,1)*gf73rds) + & - & xdia(mgs,lc,2)*gf83rds))/4. - + & xdia(mgs,lc,2)*gf83rds))/4. + ELSE ! using Seifert coefficients - vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & - & da1lc(mgs)*xdia(mgs,lc,3)**2 ) - + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + ENDIF qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) - + IF ( lzh .gt. 1 ) THEN tmp = qx(mgs,lh)/cx(mgs,lh) - + !! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ !! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) ! alp = Max( 1.0, alpha(mgs,lh)+1. ) @@ -16706,7 +16706,7 @@ subroutine nssl_2mom_gs & ! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) ! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) ENDIF - + ELSE qhacw(mgs) = & & min( & @@ -16718,28 +16718,28 @@ subroutine nssl_2mom_gs & & , 0.5*(qx(mgs,lc)-qcwresv(mgs))*dtpinv) ! < , qxmxd(mgs,lc)) ! < , qcmxd(mgs)) - - + + IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and. qhacw(mgs) > 0.0) THEN qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh)) ! qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) ) qsacw(mgs) = qaacw qhacw(mgs) = qaacw ENDIF - + ENDIF qhacwmlr(mgs) = qhacw(mgs) IF ( temg(mgs) > tfr .and. iqhacwshr == 0 ) THEN qhacw(mgs) = 0.0 ENDIF - + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail - + IF ( temg(mgs) .lt. 273.15) THEN IF ( irimdenopt == 1 ) THEN ! Heymsfield and Pflaum (1985) vt = ( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) - + rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*vt ) & & /(temg(mgs)-273.15))**(rimc2) @@ -16760,7 +16760,7 @@ subroutine nssl_2mom_gs & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & & /(temg(mgs)-273.15)) tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) ! have to limit range of "R" because quadratic function starts to decrease (unphysically) at higher values - + rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001 @@ -16769,29 +16769,29 @@ subroutine nssl_2mom_gs & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & & /(temg(mgs)-273.15)) ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - + IF ( irimdenopt == 3 ) THEN rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini rimdn(mgs,lh) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) ENDIF - + ENDIF ELSE rimdn(mgs,lh) = 1000. ENDIF - + IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh) ENDIF - + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .ge. 1 ) THEN rarx(mgs,lh) = & & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh)) ENDIF - - ENDIF - end do + + ENDIF + end do ! ! do mgs = 1,ngscnt @@ -16806,7 +16806,7 @@ subroutine nssl_2mom_gs & qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & - & da1(li)*xdia(mgs,li,3)**2 ) + & da1(li)*xdia(mgs,li,3)**2 ) qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) ) ELSE qhaci(mgs) = & @@ -16819,7 +16819,7 @@ subroutine nssl_2mom_gs & & , qimxd(mgs)) ENDIF ENDIF - end do + end do ! @@ -16836,8 +16836,8 @@ subroutine nssl_2mom_gs & qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & - & da1(ls)*xdia(mgs,ls,3)**2 ) - + & da1(ls)*xdia(mgs,ls,3)**2 ) + qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) ) ELSE @@ -16851,7 +16851,7 @@ subroutine nssl_2mom_gs & & , qsmxd(mgs)) ENDIF ENDIF - end do + end do ! do mgs = 1,ngscnt qhacr(mgs) = 0.0 @@ -16867,10 +16867,10 @@ subroutine nssl_2mom_gs & & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) ! qhacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* ! : qx(mgs,lr)*0.25*pi* -! : (3.02787*xdia(mgs,lr,2) + -! : 3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) + ! : 2.*xdia(mgs,lh,2)) - + qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & @@ -16884,7 +16884,7 @@ subroutine nssl_2mom_gs & qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) ) qhacrmlr(mgs) = qhacr(mgs) - + IF ( temg(mgs) > tfr .and. iehr0c == 0 ) THEN qhacr(mgs) = 0.0 @@ -16923,7 +16923,7 @@ subroutine nssl_2mom_gs & ! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacr(mgs) ) ENDIF ENDIF ! temg > tfr - + ELSE IF ( lwsm6 .and. ipconc == 0 ) THEN vt = vt2ave(mgs) @@ -16939,15 +16939,15 @@ subroutine nssl_2mom_gs & & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1) & & + gf4*gf3*xdia(mgs,lh,2) ) & & , qrmxd(mgs)) - + IF ( temg(mgs) > tfr ) THEN IF ( iqhacrmlr >= 1 ) qhacrmlr(mgs) = qhacr(mgs) qhacr(mgs) = 0.0 ENDIF - + ENDIF IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail - + IF ( temg(mgs) .lt. 273.15) THEN raindn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lr,3)) & & *((0.60)*vt) & @@ -16957,7 +16957,7 @@ subroutine nssl_2mom_gs & ELSE raindn(mgs,lh) = 1000. ENDIF - + IF ( lvol(lh) > 1 ) vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh) ENDIF ENDIF @@ -17012,27 +17012,27 @@ subroutine nssl_2mom_gs & & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) & & /(temg(mgs)-273.15))**(rimc2) rimdn(mgs,lhl) = Min( Max( hldnmn, rimc3, rimdn(mgs,lhl) ), rimc4 ) - + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & & /(temg(mgs)-273.15) tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - + rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) - + ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001 tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & & /(temg(mgs)-273.15) ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - + IF ( irimdenopt == 3 ) THEN rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini rimdn(mgs,lhl) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) ENDIF - + ENDIF ELSE rimdn(mgs,lhl) = 1000. @@ -17121,9 +17121,9 @@ subroutine nssl_2mom_gs & qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) ) - + IF ( iqhlacrmlr >= 1 ) qhlacrmlr(mgs) = qhlacr(mgs) - + IF ( temg(mgs) > tfr .and. iehlr0c == 0) THEN qhlacr(mgs) = 0.0 IF ( iqhlacrmlr == 0 ) THEN @@ -17217,19 +17217,19 @@ subroutine nssl_2mom_gs & ! interpolate along x, i.e., ratio tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) - + ! interpolate along alpha - + nr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr) - - ! interpolate along x, i.e., ratio; + + ! interpolate along x, i.e., ratio; tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) - - ! interpolate along alpha; - + + ! interpolate along alpha; + qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) - + ELSE ! iacrsize == 4 : use all nr = cx(mgs,lr) qr = qx(mgs,lr) @@ -17241,7 +17241,7 @@ subroutine nssl_2mom_gs & qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & & ( 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 ) + & da1(lr)*xdia(mgs,lr,3)**2 ) qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) @@ -17249,10 +17249,10 @@ subroutine nssl_2mom_gs & ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & & dab0lh(mgs,li,lr)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & - & da0(lr)*xdia(mgs,lr,3)**2 ) + & da0(lr)*xdia(mgs,lr,3)**2 ) ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) - + ! write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs) ! write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1) ! write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j) @@ -17306,11 +17306,11 @@ subroutine nssl_2mom_gs & ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ! *rzxh(mgs) ELSEIF ( iacr .eq. 5 ) THEN ciacrf(mgs) = ciacr(mgs)*rzxh(mgs) - ENDIF + ENDIF ! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) ENDIF - - + + ELSE ! single-moment rain qiacr(mgs) = & & min( & @@ -17347,7 +17347,7 @@ subroutine nssl_2mom_gs & ENDIF qsplinter(mgs) = Min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel ENDIF - + frach = 1.0 IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN IF ( ciacr(mgs) > qxmin(lh) ) THEN @@ -17356,7 +17356,7 @@ subroutine nssl_2mom_gs & qiacrs(mgs) = (1.-frach)*qiacr(mgs) ciacrs(mgs) = (1.-frach)*ciacrf(mgs) ! *rzxh(mgs) - + ENDIF ENDIF @@ -17366,7 +17366,7 @@ subroutine nssl_2mom_gs & IF ( lvol(lh) > 1 ) THEN viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz ENDIF - + end do ! ! @@ -17392,8 +17392,8 @@ subroutine nssl_2mom_gs & ENDIF ENDIF - csacs(mgs) = ec0(mgs)*rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*essrmax**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density -! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density + csacs(mgs) = ec0(mgs)*rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*essrmax**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density csacs(mgs) = Min(csacs(mgs),csmxd(mgs)) ENDIF end do @@ -17433,9 +17433,9 @@ subroutine nssl_2mom_gs & ENDIF 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 ( 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 - IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 + IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 ! DM0CCC=A2*XNC*XNR*(XVC+XVR) ! (A11) ! NOTE: murain drops out, so same result for imurain = 1 and 3 cracw(mgs) = aa2*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*(xv(mgs,lc) + xv(mgs,lr)) @@ -17456,26 +17456,26 @@ subroutine nssl_2mom_gs & ENDIF ! } dmrauto ENDIF ! ipconc ENDIF ! qc > qcmin & qr > qrmin - + ! Rain self collection (cracr) and break-up (factor of ec0) ! -! +! ec0(mgs) = 1.0 ! 2.e9 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN rwrad = 0.5*xdia(mgs,lr,3) - - + + ! check median volume diameter IF ( icracrthresh > 1 ) THEN IF ( imurain == 1 ) THEN tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of mm (Ulbrich 1983, JCAM) - ELSE ! imurain == 3, + 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 - + ! 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) @@ -17488,15 +17488,15 @@ subroutine nssl_2mom_gs & & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) ENDIF ELSE - IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN - + 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 ec0(mgs) = 1.0 ELSE ec0(mgs) = Exp( -2500.0*(xdia(mgs,lr,3) - 6.0e-4) ) ENDIF - - + + IF ( rwrad .ge. 50.e-6 ) THEN tmp1 = aa2*cx(mgs,lr)**2*xv(mgs,lr) @@ -17521,7 +17521,7 @@ subroutine nssl_2mom_gs & ! 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 @@ -17529,7 +17529,7 @@ subroutine nssl_2mom_gs & ENDIF cracr(mgs) = 5.78*ec0(mgs)*cx(mgs,lr)*qx(mgs,lr) ENDIF - + ENDIF ! ( qx(mgs,lr) .gt. qxmin(lr) ) ! active breakup option @@ -17543,9 +17543,9 @@ subroutine nssl_2mom_gs & ! 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) - + ratio = Min( maxratiolu, draintail/xdia(mgs,lr,1) ) ! mass tmp2 = gaminterp(ratio,alpha(mgs,lr),4,1) @@ -17554,7 +17554,7 @@ subroutine nssl_2mom_gs & crbreaksmall = rho0(mgs)*qrbreak/(xdn(mgs,lr)*pi/6.*drsmall**3) IF ( ( qxd1 > qxmin(lr)) ) THEN - + ! number tmp = gaminterp(ratio,alpha(mgs,lr),1,1) IF ( ipconc == 5 ) THEN @@ -17567,7 +17567,7 @@ subroutine nssl_2mom_gs & flim = (rho0(mgs)*qx(mgs,lr) - qrbrthresh1)/(qrbrthresh2 - qrbrthresh1) ENDIF crbreak = flim*(crbreaksmall - dtpinv*cxd1) - + ! IF ( kgs(mgs) == 1 .and. qx(mgs,lr) > 0.1e-3 ) THEN ! write(0,*) 'crbreak: ',crbreak,crbreaksmall,dtpinv*cxd1,cx(mgs,lr),cracr(mgs) - crbreak ! ENDIF @@ -17588,7 +17588,7 @@ subroutine nssl_2mom_gs & ENDIF ENDIF -! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) +! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) end do end if @@ -17814,20 +17814,20 @@ subroutine nssl_2mom_gs & ! IF ( ipconc .ge. 2 ) THEN 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 ENDDO - + IF ( dmrauto >= -1 ) THEN !{ DO mgs = 1,ngscnt ! qracw(mgs) = 0.0 ! cracw(mgs) = 0.0 IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN - !( .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing + !( .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.) cautn(mgs) = Min(ccmxd(mgs), & & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) @@ -17837,15 +17837,15 @@ subroutine nssl_2mom_gs & ! cautn(mgs) = 0.0 ELSE ! XL2P=2.7E-2*XNC*XVC*((1.E12*RB**3*RC)-0.4) - -! T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC) + +! T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC) ! t2s = 3.72E-3/(((1.e6*rb)-7.5)*cx(mgs,lc)*xv(mgs,lc)) ! t2s = 3.72/(((1.e6*rb(mgs))-7.5)*rho0(mgs)*qx(mgs,lc)) 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 IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19) crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs) @@ -17894,7 +17894,7 @@ subroutine nssl_2mom_gs & tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) ) crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3) ENDIF - + IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 IF ( ipconc >= 6 ) THEN @@ -17936,7 +17936,7 @@ subroutine nssl_2mom_gs & ENDIF endif ! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) - ENDIF + ENDIF ENDIF ! ipconc >= 6 ! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) ! : THEN @@ -17967,7 +17967,7 @@ subroutine nssl_2mom_gs & ENDIF ENDDO - + ENDIF !} dmrauto >= 0 @@ -18074,10 +18074,10 @@ subroutine nssl_2mom_gs & zrfrzs(:) = 0.0 zrfrzf(:) = 0.0 qwcnr(:) = 0.0 - + IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN - - do mgs = 1,ngscnt + + do mgs = 1,ngscnt if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. .and. ibiggopt > 0 ) then ! brz = 100.0 ! arz = 0.66 @@ -18096,21 +18096,21 @@ subroutine nssl_2mom_gs & ! crfrz(mgs) = xv(mgs,lr)*tmp frach = 1.0d0 - + ! IF ( ibiggopt == 2 .and. imurain == 1 .and. lzr < 1 ) THEN ! lzr check because results are weird for 3-moment IF ( ibiggopt == 2 .and. imurain == 1 ) THEN ! ! integrate from Bigg diameter (for given supercooling Ts) to infinity - - volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 (Proc. Phys. Soc. London) + + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 (Proc. Phys. Soc. London) ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2 ! 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. + 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 - + ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) ) - + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) IF ( alp0flag ) THEN j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) @@ -18122,29 +18122,29 @@ subroutine nssl_2mom_gs & ip1 = Min( i+1, nqiacrratio ) jp1 = Min( j+1, nqiacralpha ) - ! interpolate along x, i.e., ratio; + ! interpolate along x, i.e., ratio; tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) - - ! interpolate along alpha; - + + ! interpolate along alpha; + crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv crfrzf(mgs) = crfrz(mgs) - ! interpolate along x, i.e., ratio; + ! interpolate along x, i.e., ratio; tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) - - ! interpolate along alpha; - + + ! interpolate along alpha; + qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv qrfrzf(mgs) = qrfrz(mgs) IF ( qrfrz(mgs)*dtp < qxmin(lh) .or. crfrz(mgs)*dtp < cxmin ) THEN - + crfrz(mgs) = 0.0 qrfrz(mgs) = 0.0 qrfrzf(mgs) = 0.0 - + ELSE !{ @@ -18153,12 +18153,12 @@ subroutine nssl_2mom_gs & cxd1 = crfrz(mgs)*dtp qxd1 = qrfrz(mgs)*dtp - ! interpolate along x, i.e., ratio; + ! 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; - + + ! interpolate along alpha; + IF ( ipconc >= 6 .and. lzr > 1 ) THEN zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr) ! Do the correction for alphamax @@ -18186,7 +18186,7 @@ subroutine nssl_2mom_gs & 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 ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) @@ -18201,10 +18201,10 @@ subroutine nssl_2mom_gs & 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! - + crfrzs(mgs) = crfrz(mgs) qrfrzs(mgs) = qrfrz(mgs) - + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 1.2*xvmn(lr) ) THEN ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) crfrzf(mgs) = 0.0 @@ -18215,10 +18215,10 @@ subroutine nssl_2mom_gs & zrfrzf(mgs) = 0. ENDIF ELSE !{ - + ! recalculate using dhmn for ratio ratio = Min( maxratiolu, Max(dfrz,dhmn)/xdia(mgs,lr,1) ) - + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) ! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) ! j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) @@ -18232,21 +18232,21 @@ subroutine nssl_2mom_gs & ip1 = Min( i+1, nqiacrratio ) jp1 = Min( j+1, nqiacralpha ) - ! interpolate along x, i.e., ratio; + ! interpolate along x, i.e., ratio; tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) - ! interpolate along alpha; - + ! interpolate along alpha; + crfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv - - ! interpolate along x, i.e., ratio; + + ! interpolate along x, i.e., ratio; tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) - - ! interpolate along alpha; - + + ! interpolate along alpha; + qrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv ! now subtract off the difference @@ -18255,12 +18255,12 @@ subroutine nssl_2mom_gs & IF ( ipconc >= 6 .and. lzr > 1 ) THEN zrfrzs(mgs) = zrfrz(mgs) - ! interpolate along x, i.e., ratio; + ! 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; - + + ! interpolate along alpha; + zrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv zrfrzs(mgs) = zrfrzs(mgs) - zrfrzf(mgs) zrfrzf(mgs) = (1000./900.)**2*zrfrzf(mgs) @@ -18271,9 +18271,9 @@ subroutine nssl_2mom_gs & 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) @@ -18287,7 +18287,7 @@ subroutine nssl_2mom_gs & zrfrzf(mgs) = fac*zrfrzf(mgs) ENDIF ENDIF - + ENDIF !} ! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN @@ -18295,14 +18295,14 @@ subroutine nssl_2mom_gs & ! crfrz(mgs) = fac*crfrz(mgs) ! crfrzs(mgs) = fac*crfrzs(mgs) ! ENDIF - + ! qrfrzf(mgs) = qrfrz(mgs) ! crfrzf(mgs) = crfrz(mgs) - + ! qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs) ! crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs) - + ELSEIF ( ibiggopt == 1 ) THEN ! Z85, eq. A34 tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) @@ -18337,23 +18337,23 @@ subroutine nssl_2mom_gs & & ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr))) ! bfnu = 1. ENDIF - ENDIF + ENDIF qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs) - qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) - crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)*dtpinv ) !cxmxd(mgs,lr) + qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)*dtpinv ) !cxmxd(mgs,lr) qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) ) qrfrzf(mgs) = qrfrz(mgs) ENDIF !} - - - - IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN !{ Yes, it compares cx and qxmin, but this is just to be sure that + + + + IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN !{ Yes, it compares cx and qxmin, but this is just to be sure that ! crfrz is greater than zero in the division ! IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN ! IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN - + IF ( (ibiggsnow == 1 .or. ibiggsnow == 3 ) .and. ibiggopt /= 2 ) 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*xvmn(lh)))) @@ -18361,15 +18361,15 @@ subroutine nssl_2mom_gs & qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs) ! qrfrzf(mgs) = frach*qrfrz(mgs) - + ENDIF - + IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN qrfrzs(mgs) = qrfrz(mgs) crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs) ELSE -! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)*dtpinv ) ! cxmxd(mgs,lr) -! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) +! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)*dtpinv ) ! cxmxd(mgs,lr) +! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) qrfrzf(mgs) = frach*qrfrz(mgs) ! crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) ) IF ( ibfr .le. 1 ) THEN @@ -18382,12 +18382,12 @@ subroutine nssl_2mom_gs & crfrzf(mgs) = frach*Max(crfrz(mgs), qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) ELSE crfrzf(mgs) = frach*crfrz(mgs) - ENDIF + ENDIF ! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) ! IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN ! crfrzf(mgs) = crfrz(mgs) ! ENDIF - + ENDIF ! crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) ) ELSE @@ -18401,7 +18401,7 @@ subroutine nssl_2mom_gs & vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz ENDIF - + IF ( nsplinter .ne. 0 ) THEN IF ( nsplinter .ge. 1000 ) THEN ! Lawson et al. 2015 JAS @@ -18444,7 +18444,7 @@ subroutine nssl_2mom_gs & ! end if end if end do - + ENDIF ! ! Homogeneous freezing of cloud drops to ice crystals @@ -18471,10 +18471,10 @@ subroutine nssl_2mom_gs & cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li) ELSEIF ( ipconc .ge. 2 ) THEN IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN - volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 ! for mean temperature for freezing: -ln (V) = a*Ts - b ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 -! dbigg = (6./pi* volt )**(1./3.) +! dbigg = (6./pi* volt )**(1./3.) IF ( alpha(mgs,lc) == 0.0 ) THEN cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))*dtpinv ! number of droplets with volume greater than volt @@ -18484,7 +18484,7 @@ subroutine nssl_2mom_gs & qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) ELSE ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc) - + IF ( .false. .and. usegamxinfcnu ) THEN i = Nint(dgami*(1. + alpha(mgs,lc))) gcnup1 = gmoi(i) @@ -18494,9 +18494,9 @@ subroutine nssl_2mom_gs & cwfrz(mgs) = cx(mgs,lc)*Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) - + ELSE - + ratio = Min( maxratiolu, ratio ) ! write(0,*) 'cwfrz: temp,ratio = ',temcg(mgs),ratio ! write(0,*) 'cwfrz: xv,volt,qx = ',xv(mgs,lc),volt,qx(mgs,lc) @@ -18508,9 +18508,9 @@ subroutine nssl_2mom_gs & tmp = gaminterp(ratio,alpha(mgs,lc),12,1) ! write(0,*) 'cwfrz: tmp2 = ',tmp qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*dtpinv*tmp ! Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) - + ENDIF - + ENDIF ENDIF @@ -18526,12 +18526,12 @@ subroutine nssl_2mom_gs & qwfrzp(mgs) = qwfrz(mgs) cwfrzp(mgs) = cwfrz(mgs) end if -! +! if ( xcolmn(mgs) .eq. 1 ) then qwfrzc(mgs) = qwfrz(mgs) cwfrzc(mgs) = cwfrz(mgs) end if - + ! ! qwfrzp(mgs) = 0.0 ! qwfrzc(mgs) = qwfrz(mgs) @@ -18625,11 +18625,11 @@ subroutine nssl_2mom_gs & qwctfzc(mgs) = qwctfz(mgs) cwctfzc(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 @@ -18831,7 +18831,7 @@ subroutine nssl_2mom_gs & IF ( iferwisventr == 1 ) THEN ! Ferrier fall speed in the ventillation term [uses fx(lr) ] - + alpr = Min(alpharmax,alpha(mgs,lr) ) x = 1. + alpha(mgs,lr) @@ -18854,13 +18854,13 @@ subroutine nssl_2mom_gs & ! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula -- should be equivalent) vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) - - + + rwvent(mgs) = & & 0.78*x + & & 0.308*fvent(mgs)*y* & & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) - + rwventz(mgs) = 0.0 ! rwventz(mgs) = & @@ -18870,7 +18870,7 @@ subroutine nssl_2mom_gs & 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 x = 1. + alpha(mgs,lr) @@ -18898,9 +18898,9 @@ subroutine nssl_2mom_gs & ENDIF - + ENDIF ! iferwisventr - + ENDIF ! imurain ELSE rwvent(mgs) = & @@ -18957,7 +18957,7 @@ subroutine nssl_2mom_gs & ! i = Int(dgami*(tmp)) ! del = tmp - dgam*i ! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - + ! note that hwvent includes a division by Gamma(1+alpha), so Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha ! and g1palp = Gamma(1+alpha) divides into y x = 1. + alpha(mgs,lh) @@ -18971,21 +18971,21 @@ subroutine nssl_2mom_gs & i = Int(dgami*(tmp)) del = tmp - dgam*i y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp - - - hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*Sqrt(axx(mgs,lh)*rhovt(mgs)) + + + hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*Sqrt(axx(mgs,lh)*rhovt(mgs)) hwvent(mgs) = & & ( 0.78*x + y*hwventy(mgs) ) ! & ! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))* & ! & Sqrt(axx(mgs,lh)*rhovt(mgs)) ) - + ENDIF ELSE hwvent(mgs) = 0.0 hwventy(mgs) = 0.0 ENDIF end do - + hlvent(:) = 0.0 hlventy(:) = 0.0 @@ -19027,8 +19027,8 @@ subroutine nssl_2mom_gs & del = tmp - dgam*i y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions - hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*Sqrt(axx(mgs,lhl)*rhovt(mgs)) - + hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*Sqrt(axx(mgs,lhl)*rhovt(mgs)) + hlvent(mgs) = 0.78*x + y*hlventy(mgs) ! & ! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))* & ! & Sqrt(axx(mgs,lhl)*rhovt(mgs))) @@ -19129,7 +19129,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt ! IF ( temg(mgs) .gt. tfr ) THEN - + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN qsmlr(mgs) = & & min( & @@ -19137,7 +19137,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) ! ELSE @@ -19162,24 +19162,24 @@ subroutine nssl_2mom_gs & errmsg = 'ibinhmlr = 1 not available for 2-moment' errflg = 1 RETURN - + ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN ENDIF - - + + IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN ! act as if 100% of the meltwater were soaked into the graupel v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) ! volume available for filling v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh) ! volume of melted ice if it were refrozen in the matrix - + vhsoak(mgs) = Min(v1,v2) - + ENDIF ENDIF ! qx(mgs,lh) .gt. qxmin(lh) - + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN @@ -19202,24 +19202,24 @@ subroutine nssl_2mom_gs & ! act as if 50% of the meltwater were soaked into the graupel v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) ! volume available for filling v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl) ! volume of melted ice if it were refrozen in the matrix - + vhlsoak(mgs) = Min(v1,v2) - + ENDIF - + ENDIF ENDIF ENDIF - + ! -! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) ) -! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) ) +! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) ) +! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) ) ! erm 5/10/2007 changed to next line: - if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) ) + if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) ) 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 ) ) + 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 @@ -19242,13 +19242,13 @@ subroutine nssl_2mom_gs & 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 + 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) csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) ELSEIF ( qx(mgs,ls) > qxmin(ls) ) THEN csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) ENDIF - + csmlrr(mgs) = csmlr(mgs)/rzxs(mgs) IF ( -csmlrr(mgs)*dtp > cxmin .and. -qsmlr(mgs)*dtp > qxmin(lr) .and. snowmeltdia > 0.0 ) THEN rmas = rho0(mgs)*qsmlr(mgs)/csmlrr(mgs) @@ -19256,7 +19256,7 @@ subroutine nssl_2mom_gs & csmlrr(mgs) = rho0(mgs)*qsmlr(mgs)/snowmeltmass ENDIF ENDIF - + ! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN @@ -19267,11 +19267,11 @@ subroutine nssl_2mom_gs & chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) IF ( imltshddmr == 3 .and. qhmlr(mgs) < -qxmin(lh) ) THEN ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) - ! + ! ! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam ! chmlr(mgs) = 0.0 ! ENDIF - + ! test to remove the part of the melting associated with large ice particles so they get smaller tmp = 1. + alpha(mgs,lh) @@ -19284,13 +19284,13 @@ subroutine nssl_2mom_gs & x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh), ratio)/g1palp - hwvent1 = 0.78*x + y*hwventy(mgs) + hwvent1 = 0.78*x + y*hwventy(mgs) qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lh)*hwvent1*xdia(mgs,lh,1), 0.0 ) chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*(qhmlr(mgs) - qhlmlr1) - - + + ENDIF ! IF ( igs(mgs) == 40 ) THEN ! write(0,*) 'is this running? chmlr = ',kgs(mgs), chmlr(mgs) @@ -19304,32 +19304,32 @@ subroutine nssl_2mom_gs & tmp = qx(mgs,lh)/cx(mgs,lh) alp = alpha(mgs,lh) g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) - + zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) ENDIF - + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN IF ( ihmlt .eq. 1 ) THEN - chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain ELSEIF ( ihmlt .eq. 2 ) THEN IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN -! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain +! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain ! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas IF(imltshddmr == 1) THEN ! DTD: If Dmg < sheddiam, then assume complete melting into ! maximal raindrop. Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter - + chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) ! old version chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs))) ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN ! 8/26/2015 ERM updated to use shedalp and tmpdiam ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) - chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain ELSE ! Old method - chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain ENDIF ELSE chmlrr(mgs) = chmlr(mgs) @@ -19339,13 +19339,13 @@ subroutine nssl_2mom_gs & ENDIF ELSE ! ibinhmlr < 0? Already have an outer IF test for ibinhmlr < 1 - chmlrr(mgs) = Min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + chmlrr(mgs) = Min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain ENDIF - + ENDIF ! } ( chmlr(mgs) < 0.0 .and. ibinhmlr < 1) IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! { - + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN ! IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN ! chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3) ! out of hail @@ -19355,11 +19355,11 @@ subroutine nssl_2mom_gs & IF ( imltshddmr == 3 .and. qhlmlr(mgs) < -qxmin(lhl) ) THEN ! IF ( .false. .and. imltshddmr == 3 ) THEN ! tmpdiam = (shedalp+alpha(mgs,lhl))*xdia(mgs,lhl,1) -! +! ! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam ! chlmlr(mgs) = 0.0 ! ENDIF - + ! test to remove the part of the melting associated with large ice particles so they get smaller ! tmp = 1. + alpha(mgs,lhl) @@ -19372,7 +19372,7 @@ subroutine nssl_2mom_gs & x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl), ratio)/g1palp - hwvent1 = 0.78*x + y*hlventy(mgs) + hwvent1 = 0.78*x + y*hlventy(mgs) qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lhl)*hwvent1*xdia(mgs,lhl,1), 0.0 ) @@ -19381,14 +19381,14 @@ subroutine nssl_2mom_gs & ENDIF ! ENDIF ENDIF - + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN !{ IF ( ihmlt .eq. 1 ) THEN - chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain ELSEIF ( ihmlt .eq. 2 ) THEN IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN -! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain -! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain +! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain IF(imltshddmr == 1 ) THEN tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter @@ -19397,9 +19397,9 @@ subroutine nssl_2mom_gs & ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN ! 8/26/2015 ERM updated to use shedalp and tmpdiam ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) - chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain ELSE ! old method - chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain ENDIF ELSE chlmlrr(mgs) = chlmlr(mgs) @@ -19409,10 +19409,10 @@ subroutine nssl_2mom_gs & ENDIF ELSE ! } { ibinhlmlr > 0 - chlmlrr(mgs) = Min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + chlmlrr(mgs) = Min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain ENDIF !} - - + + IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN IF ( cx(mgs,lhl) > 0.0 ) THEN @@ -19420,13 +19420,13 @@ subroutine nssl_2mom_gs & alp = alpha(mgs,lhl) ! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) - + zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) ) ENDIF ENDIF ENDIF ! } - ENDIF ! }.not. mixedphase + ENDIF ! }.not. mixedphase ! 10ice versions: ! chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) @@ -19499,7 +19499,7 @@ subroutine nssl_2mom_gs & ! ! IF ( DoSublimationFix ) THEN - + do mgs = 1,ngscnt qitmp(mgs) = qx(mgs,li) + qx(mgs,ls) + qx(mgs,lh) @@ -19510,11 +19510,11 @@ subroutine nssl_2mom_gs & qsimxdep(mgs) = 0.0 qsimxsub(mgs) = 0.0 dqcitmp(mgs) = 0.0 - + ! IF ( ( qitmp(mgs) > qxmin(li) .or. qrtmp(mgs) > qxmin(lr) ) ) THEN IF ( qitmp(mgs) > qxmin(li) ) THEN - + qitmp1 = qitmp(mgs) qctmp1 = qctmp(mgs) felvcptmp = felvcp(mgs) @@ -19533,16 +19533,16 @@ subroutine nssl_2mom_gs & qsstmp = qisstmp - + dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp ) do itertd = 1,2 - + ! ! calculate super-saturation ! IF ( itertd == 1 ) THEN - + ELSE dqcitmp(mgs) = dqci(mgs) ! dqwvtmp(mgs) = dqwv(mgs) @@ -19590,7 +19590,7 @@ subroutine nssl_2mom_gs & ! condensation/deposition ! IF ( dqwv(mgs) .ge. 0. ) THEN ! { - + ! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) ! ! qitmp(mgs) = qx(mgs,li) @@ -19675,22 +19675,22 @@ subroutine nssl_2mom_gs & 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 qctmp(mgs) = max( 0.0, qctmp(mgs) ) qitmp(mgs) = max( 0.0, qitmp(mgs) ) - + IF ( qitmp(mgs) < qitmp1 ) THEN qsimxsub(mgs) = (qitmp1 - qitmp(mgs))*dtpinv ELSEIF ( qitmp(mgs) > qitmp1 ) THEN qsimxdep(mgs) = (qitmp(mgs) - qitmp1)*dtpinv ENDIF - - + + ENDIF ! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv ! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qxtmp,qctmp(mgs) @@ -19698,18 +19698,18 @@ subroutine nssl_2mom_gs & ! end the saturation adjustment iteration loop ! end do ! itertd - + ENDIF - + end do ! mgs - + ELSE - + DO mgs = 1,ngscnt qsimxdep(mgs) = qvimxd(mgs) qsimxsub(mgs) = 1.e20 ENDDO - + ENDIF ! end of qlimit @@ -19739,7 +19739,7 @@ subroutine nssl_2mom_gs & ENDIF qidpv(mgs) = Max(qidsv(mgs), 0.0) qsdpv(mgs) = Max(qsdsv(mgs), 0.0) - + IF ( qsmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN ! switch snow sublimation to evaporation if there is melting qscev(mgs) = evapfac* & @@ -19766,19 +19766,19 @@ subroutine nssl_2mom_gs & qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) qhdpv(mgs) = Max(qhdsv(mgs), 0.0) ENDIF - + IF ( .true. .and. qhmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing) ! qhcev(mgs) = & ! & evapfac*min( & ! & fmlt1e(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1), 0.0 ) - + qhcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* & & cx(mgs,lh)*xdia(mgs,lh,1)*hwvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) qhcev(mgs) = max(qhcev(mgs), -qhmxd(mgs)) IF ( temg(mgs) > tfr ) qhcev(mgs) = Min(0.0, qhcev(mgs) ) - + ENDIF ENDIF @@ -19798,11 +19798,11 @@ subroutine nssl_2mom_gs & qhlcev(mgs) = max(qhlcev(mgs), -qhlmxd(mgs)) IF ( temg(mgs) > tfr ) qhlcev(mgs) = Min(0.0, qhlcev(mgs) ) - + ENDIF ENDIF ENDIF - + temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) ! IF ( temp1 .gt. qvimxd(mgs) ) THEN @@ -19944,30 +19944,30 @@ subroutine nssl_2mom_gs & IF ( incwet >= 1 ) THEN ! 'incwet' = incomplete gamma for wet growth - ! Find diameter where wet growth starts, then compute dry and wet growth + ! Find diameter where wet growth starts, then compute dry and wet growth ! over [dwet,infinity]. Subtract dry growth from qxacw etc. to get total ! dry growth part dhwet(:) = dg0thresh + 0.0001 dhlwet(:) = dg0thresh + 0.0001 dfwet(:) = dg0thresh + 0.0001 - + DO mgs = 1,ngscnt sqrtrhovt = Sqrt( rhovt(mgs) ) - fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) ltemq = (tfr-163.15)/fqsat+1.5 qvs0 = pqs(mgs)*tabqvs(ltemq) denomdp = felf(mgs) + fcw(mgs)*temcg(mgs) denominvdp = 1.d0/(felf(mgs) + fcw(mgs)*temcg(mgs)) - + IF (((qhacw(mgs) + qhacr(mgs))*dtp > 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 + 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) @@ -19980,13 +19980,13 @@ subroutine nssl_2mom_gs & 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) + 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) + 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 @@ -20001,10 +20001,10 @@ subroutine nssl_2mom_gs & 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 @@ -20016,7 +20016,7 @@ subroutine nssl_2mom_gs & ! 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 ) x = 1.1e4 * rho0(mgs)*(ehlw(mgs)*qx(mgs,lc)+ehlr(mgs)*qx(mgs,lr)) - & - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 + 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) @@ -20029,13 +20029,13 @@ subroutine nssl_2mom_gs & ! 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) + 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) + 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 @@ -20050,18 +20050,18 @@ subroutine nssl_2mom_gs & 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 @@ -20091,7 +20091,7 @@ subroutine nssl_2mom_gs & ! set wet growth and shedding ! do mgs = 1,ngscnt - + IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN ! ! qswet(mgs) = @@ -20115,7 +20115,7 @@ subroutine nssl_2mom_gs & ! 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 @@ -20147,7 +20147,7 @@ subroutine nssl_2mom_gs & ! 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 @@ -20181,7 +20181,7 @@ subroutine nssl_2mom_gs & - qxacwtmp - qxacrtmp + qxwettmp ! qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) - + ! ELSE ! for dwet > 15cm, just assume dry growth ! qhwet(mgs) = qhdry(mgs) ! ENDIF @@ -20197,7 +20197,7 @@ subroutine nssl_2mom_gs & & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) qhlwet(mgs) = max( 0.0, qhlwet(mgs)) - + IF ( incwet == 1 .and. qhlwet(mgs) < qhldry(mgs) .and. dhlwet(mgs) < dg0thresh ) THEN !ELSE !! || defined (WRFEXTRAS) @@ -20205,7 +20205,7 @@ subroutine nssl_2mom_gs & ! 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 @@ -20236,7 +20236,7 @@ subroutine nssl_2mom_gs & 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 @@ -20276,9 +20276,9 @@ subroutine nssl_2mom_gs & ! ENDIF ENDIF ! incwet ENDIF - + ELSE - + qhwet(mgs) = qhdry(mgs) qhlwet(mgs) = qhldry(mgs) ENDIF @@ -20312,7 +20312,7 @@ subroutine nssl_2mom_gs & ! ! qhshr(mgs) = Min( 0.0, qhwet(mgs) - qhdry(mgs) ) ! water that freezes should never be more than what sheds - + qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) @@ -20323,7 +20323,7 @@ subroutine nssl_2mom_gs & qsshr(mgs) = 0.0 ! ! -! no shedding for temperatures < 243.15 +! no shedding for temperatures < 243.15 ! if ( temg(mgs) .lt. 243.15 ) then qsshr(mgs) = 0.0 @@ -20373,34 +20373,34 @@ 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 - + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) ! Base the drop size on the shedding regime ! 8/26/2015 ERM updated to use shedalp and tmpdiam ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) - chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain - - - + chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + + + chlshr(mgs) = 0.0 chlshrr(mgs) = 0.0 - IF ( lhl .gt. 1 ) THEN + IF ( lhl .gt. 1 ) THEN ! chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) chlshr(mgs) = 0.0 ! no change to hail number concentration for wet-growth shedding - + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) ! Base the drop size on the shedding regime ! 8/26/2015 ERM updated to use shedalp and tmpdiam ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) - chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain ENDIF ! ( lhl > 1 ) - + end do end if @@ -20431,13 +20431,13 @@ subroutine nssl_2mom_gs & ! ! if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then - + ! soaking (when not advected liquid water film with graupel) IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN ! rescale volumes to maximum density - IF ( iwetsoak ) THEN + IF ( iwetsoak ) THEN rimdn(mgs,lh) = xdnmx(lh) raindn(mgs,lh) = xdnmx(lh) @@ -20450,21 +20450,21 @@ subroutine nssl_2mom_gs & v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) ! volume available for filling ! tmp = (vx(mgs,lh)/rho0(mgs))*(xdnmx(lh) - xdn(mgs,lh)) ! max mixing ratio of liquid water that can be added v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion - + vhsoak(mgs) = Min(v1,v2) - + ENDIF - + ENDIF vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) - + ELSEIF ( lvol(lh) .gt. 1 .and. mixedphase ) THEN ! vhacw(mgs) = rho0(mgs)*qhacw(mgs)/xdn0(lr) ! vhacr(mgs) = rho0(mgs)*qhacr(mgs)/xdn0(lr) ENDIF - + qhdpv(mgs) = 0.0 ! qhsbv(mgs) = 0.0 @@ -20498,7 +20498,7 @@ subroutine nssl_2mom_gs & ! if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then if ( lhl > 1 .and. ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) ) then ! if ( wetgrowthhl(mgs) ) then - + qhldpv(mgs) = 0.0 ! qhlsbv(mgs) = 0.0 @@ -20511,10 +20511,10 @@ subroutine nssl_2mom_gs & IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN ! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN - IF ( iwetsoak ) THEN + IF ( iwetsoak ) THEN - rimdn(mgs,lhl) = xdnmx(lhl) - raindn(mgs,lhl) = xdnmx(lhl) + rimdn(mgs,lhl) = xdnmx(lhl) + raindn(mgs,lhl) = xdnmx(lhl) vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl) @@ -20535,9 +20535,9 @@ subroutine nssl_2mom_gs & vhlsoak(mgs) = 0.0 ! vhlacw(mgs) = 0.0 ! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) - + ENDIF - + ENDIF vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) @@ -20563,7 +20563,7 @@ subroutine nssl_2mom_gs & ! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)) ! plug it back in ENDIF - + ! qhlwet(mgs) = 1.0 ! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop @@ -20580,27 +20580,27 @@ subroutine nssl_2mom_gs & ! Ice -> graupel conversion ! DO mgs = 1,ngscnt - + qhcni(mgs) = 0.0 chcni(mgs) = 0.0 chcnih(mgs) = 0.0 vhcni(mgs) = 0.0 - + IF ( iglcnvi .ge. 1 ) THEN IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN - - + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*vtxbar(mgs,li,1)) & & /(temg(mgs)-273.15))**(rimc2) tmp = Min( Max( rimc3, tmp ), 900.0 ) - + ! Assume that half the volume of the embryo is rime with density 'tmp' ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 ! V = 2*m/(rhoi + rhorime) - + ! write(0,*) 'rime dens = ',tmp - + IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) ! r = Max( r, 400. ) @@ -20611,25 +20611,25 @@ subroutine nssl_2mom_gs & ! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r ENDIF - + ELSEIF ( iglcnvi == 3 ) THEN IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs)*dtp > 2.*qxmin(lh) .and. gamice73fac*xmas(mgs,li) > xdnmn(lh)*xvmn(lh) ) THEN - - + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*vtxbar(mgs,li,1)) & & /(temg(mgs)-273.15))**(rimc2) tmp = Min( Max( rimc3, tmp ), 900.0 ) - + ! Assume that half the volume of the embryo is rime with density 'tmp' ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 ! V = 2*m/(rhoi + rhorime) - + ! write(0,*) 'rime dens = ',tmp ! convert to particles with the mass of the mass-weighted diameter ! massofmwr = gamice73fac*xmas(mgs,li) - + IF ( tmp .ge. xdnmn(lh) ) THEN r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) ! r = Max( r, 400. ) @@ -20639,17 +20639,17 @@ subroutine nssl_2mom_gs & ! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r ENDIF - + ENDIF - + ENDIF ENDIF - - + + ENDDO - - + + qhlcnh(:) = 0.0 chlcnh(:) = 0.0 chlcnhhl(:) = 0.0 @@ -20664,7 +20664,7 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) THEN - + IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN ! @@ -20677,7 +20677,7 @@ subroutine nssl_2mom_gs & ! : xdia(mgs,lh,3) .gt. 1.e-3 ) THEN IF ( hlcnhdia > 0 ) THEN ltest = xdia(mgs,lh,3) .gt. hlcnhdia ! test on mean volume diameter - ELSE + ELSE ! ltest = xdia(mgs,lh,1)*(3. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on maximum mass diameter ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter ENDIF @@ -20697,7 +20697,7 @@ subroutine nssl_2mom_gs & 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 + 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) @@ -20707,7 +20707,7 @@ subroutine nssl_2mom_gs & 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) + fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) ltemq = (tfr-163.15)/fqsat+1.5 qvs0 = pqs(mgs)*tabqvs(ltemq) @@ -20717,13 +20717,13 @@ subroutine nssl_2mom_gs & ! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs) h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) ) h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs) - h3 = Max(dwehwmin, ehw(mgs))*qx(mgs,lc) + 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) + 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 @@ -20738,12 +20738,12 @@ subroutine nssl_2mom_gs & ELSE am = 1.0 + 0.108*x1**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) ENDIF - + d = 8.*denominvdp*( am*felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qvs0 - qx(mgs,lv)) - ah*ftka(mgs)*temcg(mgs) )/ & (dtp* ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs) + & Max(0.001,vth - vtxbar(mgs,li,1))*h2*denominvdp)) - + ELSE ! Based on Farley and Orville (1986), eq. 5-9 but neglecting the Ci*(T0-Ts) term in (8) since we want Ts=T0 @@ -20752,16 +20752,16 @@ subroutine nssl_2mom_gs & ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + & Max(0.001,vth - vtxbar(mgs,li,1))*h2) - + ENDIF IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT - + ENDDO - + d = Min( d, dg0thresh + 0.0001 ) ENDIF ! dwr < 0.2 .and. dwr > 0.0 ENDIF ! incwet - + ! dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) dg0(mgs) = Max( d, dwmin ) ELSE @@ -20771,20 +20771,20 @@ subroutine nssl_2mom_gs & dg0(mgs) = dg0thresh + 0.0001 ! ENDIF ENDIF - + IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & .and. temg(mgs) .le. tfr+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), dwmax ) ENDIF - + ENDIF wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) - + IF ( ihlcnh == 1 ) THEN ! .or. iusedw == 0 THEN - + IF ( ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and. & ! correct this when hail gets turned on & rimdn(mgs,lh) .gt. 800. .and. & & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! { @@ -20792,7 +20792,7 @@ subroutine nssl_2mom_gs & ! 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+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)) - +! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - ! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) IF ( wtest ) THEN dh0 = dg0(mgs) @@ -20807,16 +20807,16 @@ subroutine nssl_2mom_gs & dg0(mgs) = Min(dh0, dg0thresh + 0.0001) ENDIF ! wtest ! dh0 = Max( dh0, 5.e-3 ) - + ! IF ( dh0 .gt. 0.0 ) write(0,*) 'dh0 = ',dh0 ! IF ( dh0 .gt. 1.0e-4 ) THEN IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN !{ -! IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN +! IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN 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 !{ ! dh0 = Max( xdia(mgs,lh,3), Min( dh0, 5.e-3 ) ) ! do not create hail greater than 5mm diam. unless the graupel is larger IF ( .not. wtest ) dh0 = Min( dh0, 10.e-3 ) ! do not create hail greater than 10mm diam., which is the max graupel size @@ -20826,7 +20826,7 @@ subroutine nssl_2mom_gs & r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter chlcnh(mgs) = Max( chlcnhhl(mgs), r ) ENDIF !} - + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) @@ -20834,9 +20834,9 @@ subroutine nssl_2mom_gs & ENDIF ! } ENDIF ! } - + ELSEIF ( ihlcnh == 3 ) THEN !{ - + IF ( wtest .and. & ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr+hailcnvtoffset .and. qx(mgs,lh) > hlcnhqmin ) ) THEN @@ -20845,7 +20845,7 @@ subroutine nssl_2mom_gs & ! dg0(mgs) = Min( dg0(mgs), hldia1 ) !dg0(mgs) = hldia1 ENDIF - + ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) @@ -20863,10 +20863,10 @@ subroutine nssl_2mom_gs & ! qhlcnh(mgs) = flim*qhlcnh(mgs) ENDIF - - + + IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN - + ! number tmp = gaminterp(ratio,alpha(mgs,lh),1,1) IF ( ipconc == 5 ) THEN @@ -20928,29 +20928,29 @@ subroutine nssl_2mom_gs & 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 + + ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion ! ! Staka and Mansell (2005) type conversion ! ! hldia1 is set in micro_module and namelist ! IF ( .true. ) THEN - + ! convert number, mass, and reflectivity for d > hldia1, ! regardless of wet growth status, but as long as riming > 0 DO mgs = 1,ngscnt @@ -20978,9 +20978,9 @@ subroutine nssl_2mom_gs & ENDIF vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) - + ENDIF - + ENDDO ! ENDIF ELSEIF ( ihlcnh == 0 ) THEN @@ -21006,11 +21006,11 @@ subroutine nssl_2mom_gs & end if end if end do - + ! ENDIF ! true - + ENDIF ! ihlcnh options - + ! convert low-density hail to graupel IF ( icvhl2h >= 1 ) THEN DO mgs = 1,ngscnt @@ -21019,16 +21019,16 @@ subroutine nssl_2mom_gs & qhcnhl(mgs) = tmp*qx(mgs,lhl)*dtpinv chcnhl(mgs) = cx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) vhcnhl(mgs) = vx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) - + ENDIF ENDDO - + ENDIF - + ENDIF ! lhl > 1 - - + + ! ! Ziegler snow conversion to graupel @@ -21125,12 +21125,12 @@ subroutine nssl_2mom_gs & ! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r ENDIF - + ELSEIF ( iglcnvs == 3 ) THEN - + ! convert to particles with the mass of the mass-weighted diameter ! massofmwr = gamice73fac*xmas(mgs,li) - + IF ( tmp > xdnmn(lh) ) THEN r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) ! r = Max( r, 400. ) @@ -21222,7 +21222,7 @@ subroutine nssl_2mom_gs & ! 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) end if @@ -21295,7 +21295,7 @@ subroutine nssl_2mom_gs & ! ICE MULTIPLICATION: Two modes (rimpa, and rimpb) ! (following Cotton et al. 1986) ! - + chmul1(:) = 0.0 chlmul1(:) = 0.0 csmul1(:) = 0.0 @@ -21304,10 +21304,10 @@ subroutine nssl_2mom_gs & qhlmul1(:) = 0.0 qsmul1(:) = 0.0 do mgs = 1,ngscnt - + ltest = qx(mgs,lh) .gt. qxmin(lh) IF ( lhl > 1 ) ltest = ltest .or. qx(mgs,lhl) .gt. qxmin(lhl) - + IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 ) & & .and. qx(mgs,lc) .gt. qxmin(lc)) THEN if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then @@ -21322,7 +21322,7 @@ subroutine nssl_2mom_gs & IF ( alpha(mgs,lc) == 0.0 ) THEN ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc)) ELSE - + ratio = (1. + alpha(mgs,lc))*(7.23e-15)/xv(mgs,lc) IF ( usegamxinfcnu ) THEN @@ -21344,15 +21344,15 @@ subroutine nssl_2mom_gs & ft = 1.0 ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN ft = 0.5 - ELSE + ELSE ft = 0.0 ENDIF ENDIF ! rhoinv = 1./rho0(mgs) ! DNSTAR = ex1*cglacw(mgs) - + IF ( ft > 0.0 ) THEN - + IF ( itype2 > 0 ) THEN IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN chmul1(mgs) = ft*ex1*chacw(mgs) @@ -21382,7 +21382,7 @@ subroutine nssl_2mom_gs & ENDIF ENDIF ! itype1 - + ENDIF ! ft ENDIF ! xv(mgs,lc) .gt. 0.0 .and. @@ -21399,7 +21399,7 @@ subroutine nssl_2mom_gs & fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0 elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0 - ELSE + ELSE fimt1(mgs) = 0.0 end if ! @@ -21411,7 +21411,7 @@ subroutine nssl_2mom_gs & fimt1(mgs) = 1.0 elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then fimt1(mgs) = 0.5 - ELSE + ELSE fimt1(mgs) = 0.0 end if ! @@ -21449,7 +21449,7 @@ subroutine nssl_2mom_gs & fimt2(mgs) = min(fimt2(mgs),1.0) fimt2(mgs) = max(fimt2(mgs),0.0) - + ENDIF ! ! qhmul2 = 0.0 @@ -21481,9 +21481,9 @@ subroutine nssl_2mom_gs & ! qsmul1(mgs) = csmul1(mgs)*(cimas0/rho0(mgs)) ! ENDIF ! ( ipconc .ge. 2 ) - + end if ! (in temperature range) - + ENDIF ! ( itype1 .eq. 1 .or. itype2 .eq. 1) ! end do @@ -21501,7 +21501,7 @@ subroutine nssl_2mom_gs & ! csmul(:) = 0.0 qsmul(:) = 0.0 - + IF ( isnwfrac /= 0 ) THEN do mgs = 1,ngscnt IF (temg(mgs) .gt. 265.0) THEN !{ @@ -21533,7 +21533,7 @@ subroutine nssl_2mom_gs & ! ciacrf(mgs) = ciacr(mgs) end do ! -! +! ! vapor to pristine ice crystals UP ! ! @@ -21548,9 +21548,9 @@ subroutine nssl_2mom_gs & ! > (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) ! qidsvp(mgs) = dqisdt(mgs) ! cnnt = min(cnit*exp(-temcg(mgs)*bta1),1.0e+09) -! qiint(mgs) = +! qiint(mgs) = ! > il5(mgs)*idqis*(1.0*dtpinv) -! < *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs)) +! < *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs)) ! end do ! ! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation @@ -21577,7 +21577,7 @@ subroutine nssl_2mom_gs & ! qidsvp(mgs) = dqisdt(mgs) idqis = 0 if ( ssi(mgs) .gt. 1.0 ) THEN - idqis = 1 + idqis = 1 dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 ) dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 ) qiint(mgs) = & @@ -21587,9 +21587,9 @@ subroutine nssl_2mom_gs & & *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)) + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin - + ! ! limit new crystals so it does not increase the current concentration ! above ciintmx 20,000 per liter (2.e7 per m**3) @@ -21597,7 +21597,7 @@ subroutine nssl_2mom_gs & ! ciintmx = 1.e9 ! ciintmx = 1.e9 IF ( icenucopt /= -10 ) THEN - + IF ( lcin > 1 ) THEN ciint(mgs) = Min(ciint(mgs), ccin(mgs)*dtpinv) ! because ciint is a *rate* ccin(mgs) = ccin(mgs) - ciint(mgs)*dtp @@ -21605,9 +21605,9 @@ subroutine nssl_2mom_gs & ELSEIF ( lcina > 1 ) THEN ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) )) qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) - + ELSEIF ( icenucopt == 1 .and. ciint(mgs) .gt. Max(0.0, ciintmx - cx(mgs,li) - ccitmp )*dtpinv ) THEN - ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv + ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) ELSEIF ( icenucopt == -11 .and. dtp*ciint(mgs) .gt. ( cnina(mgs) - (cx(mgs,li) - ccitmp))) THEN @@ -21616,12 +21616,12 @@ subroutine nssl_2mom_gs & ENDIF ENDIF - + end if endif ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN - + IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 1.0 ) .or. ssi(mgs) > 1.25 ) THEN IF ( lcin > 1 ) THEN ciint(mgs) = Min(cnina(mgs), ccin(mgs)) @@ -21638,9 +21638,9 @@ subroutine nssl_2mom_gs & qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin ENDIF - - - + + + ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN IF ( temg(mgs) .lt. 268.15 ) THEN IF ( lcin > 1 ) THEN @@ -21671,7 +21671,7 @@ subroutine nssl_2mom_gs & ! end do ! -! +! ! ! vapor to cloud droplets UP @@ -21694,7 +21694,7 @@ subroutine nssl_2mom_gs & ! rimc1 = 300.00 ! rimc2 = 0.44 ! -! +! ! zero some arrays ! ! @@ -21713,12 +21713,12 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt 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) ) ENDIF - end do + end do ! ! ! @@ -21771,9 +21771,9 @@ subroutine nssl_2mom_gs & & +chlmul1(mgs) & & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) - + pccii(mgs) = pccii(mgs)*(1.0 - ffrzs) - + ! > + nsplinter*(crfrzf(mgs) + crfrz(mgs)) pccid(mgs) = & & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & @@ -21785,17 +21785,17 @@ subroutine nssl_2mom_gs & & -(1.-il5(mgs))*cimlr(mgs) pccin(mgs) = ciint(mgs) - + end do ENDIF ! ffrzs ELSEIF ( warmonly < 0.8 ) THEN do mgs = 1,ngscnt - + ! qiint(mgs) = 0.0 ! cicint(mgs) = 0.0 ! qicicnt(mgs) = 0.0 - + pccii(mgs) = & & il5(mgs)*cicint(mgs) & & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & @@ -21820,16 +21820,16 @@ subroutine nssl_2mom_gs & end do ENDIF ! warmonly - + ! ENDIF ! ( ipconc .ge. 1 ) ! ! Cloud water ! IF ( ipconc .ge. 2 ) THEN - + do mgs = 1,ngscnt pccwi(mgs) = (0.0) - cwshw(mgs) ! + (1-il5(mgs))*(-cirmlw(mgs)) - + IF ( warmonly < 0.5 ) THEN pccwd(mgs) = & & - cautn(mgs) + & @@ -21846,9 +21846,9 @@ subroutine nssl_2mom_gs & & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & & -cwctfzc(mgs) & & ) & - & -cracw(mgs) -chacw(mgs) -chlacw(mgs) + & -cracw(mgs) -chacw(mgs) -chlacw(mgs) ELSE - + ! tmp3d(igs(mgs),jy,kgs(mgs)) = crcnw(mgs) ! cracw(mgs) = 0.0 ! turn off accretion @@ -21856,9 +21856,9 @@ subroutine nssl_2mom_gs & ! crcev(mgs) = 0.0 ! turn off evap ! qrcev(mgs) = 0.0 ! turn off evap ! cracr(mgs) = 0.0 ! turn off self collection - - -! cautn(mgs) = 0.0 + + +! cautn(mgs) = 0.0 ! crcnw(mgs) = 0.0 ! qrcnw(mgs) = 0.0 @@ -21883,7 +21883,7 @@ subroutine nssl_2mom_gs & 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 @@ -21921,7 +21921,7 @@ subroutine nssl_2mom_gs & 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) IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) @@ -22034,7 +22034,7 @@ subroutine nssl_2mom_gs & & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & & + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio & & + cscnh(mgs) - + IF ( ffrzs > 0.0 ) THEN pcswi(mgs) = pcswi(mgs) + ffrzs* ( & & il5(mgs)*cicint(mgs) & @@ -22046,11 +22046,11 @@ subroutine nssl_2mom_gs & & +csmul(mgs) ) ENDIF - + IF ( ess0 < 0.0 ) THEN csacs(mgs) = Max(0.0, csacs(mgs) - (ifrzs)*(crfrzs(mgs) + ciacrs(mgs))) ENDIF - + pcswd(mgs) = & ! : cracs(mgs) & & -chacs(mgs) - chlacs(mgs) & @@ -22064,22 +22064,22 @@ subroutine nssl_2mom_gs & IF ( imixedphase == 0 ) THEN IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp) - + pcswd(mgs) = frac*pcswd(mgs) - - chacs(mgs) = frac*chacs(mgs) + + chacs(mgs) = frac*chacs(mgs) chlacs(mgs) = frac*chlacs(mgs) - chcns(mgs) = frac*chcns(mgs) - csmlr(mgs) = frac*csmlr(mgs) - csshr(mgs) = frac*csshr(mgs) - cssbv(mgs) = frac*cssbv(mgs) + chcns(mgs) = frac*chcns(mgs) + csmlr(mgs) = frac*csmlr(mgs) + csshr(mgs) = frac*csshr(mgs) + cssbv(mgs) = frac*cssbv(mgs) csacs(mgs) = frac*csacs(mgs) - + ENDIF ENDIF - + pccii(mgs) = pccii(mgs) & & + (1. - ifrzs)*crfrzs(mgs) & & + (1. - ifrzs)*ciacrs(mgs) @@ -22127,25 +22127,25 @@ subroutine nssl_2mom_gs & & (1-il5(mgs))*chlmlr(mgs) & ! > + il5(mgs)*chlsbv(mgs) & & + chlsbv(mgs) - chcnhl(mgs) - + IF ( imixedphase == 0 ) THEN frac = 0.0 IF ( cx(mgs,lhl) + dtp*(pchli(mgs) + pchld(mgs)) < 0.0 ) THEN ! rescale depletion frac = (-cx(mgs,lhl) + pchli(mgs)*dtp)/(pchld(mgs)*dtp) - + chlmlr(mgs) = frac*chlmlr(mgs) chlsbv(mgs) = frac*chlsbv(mgs) chcnhl(mgs) = frac*chcnhl(mgs) - + pchld(mgs) = frac*pchld(mgs) - + ENDIF ENDIF end do - + ENDIF ! @@ -22254,7 +22254,7 @@ subroutine nssl_2mom_gs & ! IF ( warmonly < 0.5 ) THEN do mgs = 1,ngscnt - + ! NOTE: ANY CHANGES HERE ALSO NEED TO GO INTO THE RESUM FARTHER DOWN! pqwvi(mgs) = & & -Min(0.0, qrcev(mgs)) & @@ -22265,7 +22265,7 @@ subroutine nssl_2mom_gs & & -qhsbv(mgs) - qhlsbv(mgs) & & -qssbv(mgs) & & -il5(mgs)*qisbv(mgs) - + pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) & & -Max(0.0, qhcev(mgs)) & @@ -22273,8 +22273,8 @@ subroutine nssl_2mom_gs & & -Max(0.0, qscev(mgs)) & & +il5(mgs)*(-qiint(mgs) & & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & - & -il5(mgs)*qidpv(mgs) - + & -il5(mgs)*qidpv(mgs) + end do ELSEIF ( warmonly < 0.8 ) THEN @@ -22288,7 +22288,7 @@ subroutine nssl_2mom_gs & & -qhdpv(mgs) - qhldpv(mgs)) & ! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & & -Max(0.0, qrcev(mgs)) & - & -il5(mgs)*qidpv(mgs) + & -il5(mgs)*qidpv(mgs) end do ELSE @@ -22350,7 +22350,7 @@ subroutine nssl_2mom_gs & ! STOP ENDIF - + end do ! @@ -22369,11 +22369,11 @@ subroutine nssl_2mom_gs & & + qsplinter(mgs) + qsplinter2(mgs) ! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) ENDIF - + pqcii(mgs) = pqcii(mgs)*(1.0 - ffrzs) & & +il5(mgs)*qidpv(mgs) & & +il5(mgs)*qiacw(mgs) - + pqcid(mgs) = & & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & & -qraci(mgs) & @@ -22385,7 +22385,7 @@ subroutine nssl_2mom_gs & & - qhcni(mgs) end do - + ELSEIF ( warmonly < 0.8 ) THEN do mgs = 1,ngscnt @@ -22475,8 +22475,8 @@ subroutine nssl_2mom_gs & qiacrf(mgs) = frac*qiacrf(mgs) qiacrs(mgs) = frac*qiacrs(mgs) viacrf(mgs) = frac*viacrf(mgs) - qrfrz(mgs) = frac*qrfrz(mgs) - qrfrzs(mgs) = frac*qrfrzs(mgs) + qrfrz(mgs) = frac*qrfrz(mgs) + qrfrzs(mgs) = frac*qrfrzs(mgs) qrfrzf(mgs) = frac*qrfrzf(mgs) vrfrzf(mgs) = frac*vrfrzf(mgs) qsacr(mgs) = frac*qsacr(mgs) @@ -22516,8 +22516,8 @@ subroutine nssl_2mom_gs & ! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & & -qhsbv(mgs) - qhlsbv(mgs) & & -qssbv(mgs) & - & -il5(mgs)*qisbv(mgs) - + & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) & & -Max(0.0, qhcev(mgs)) & @@ -22525,7 +22525,7 @@ subroutine nssl_2mom_gs & & -Max(0.0, qscev(mgs)) & & +il5(mgs)*(-qiint(mgs) & & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & - & -il5(mgs)*qidpv(mgs) + & -il5(mgs)*qidpv(mgs) ENDIF @@ -22565,33 +22565,33 @@ subroutine nssl_2mom_gs & & + qssbv(mgs) & & + Min(0.0, qscev(mgs)) & & -qsmul(mgs) - - + + IF ( imixedphase == 0 .and. pqswd(mgs) .lt. 0.0 ) THEN IF ( qx(mgs,ls) + dtp*(pqswi(mgs) + pqswd(mgs)) < 0.0 ) THEN frac = (-qx(mgs,ls) + pqswi(mgs)*dtp)/(pqswd(mgs)*dtp) - + pqswd(mgs) = frac*pqswd(mgs) - + qracs(mgs) = frac*qracs(mgs) ! only used for single moment at this time - qhacs(mgs) = frac*qhacs(mgs) + qhacs(mgs) = frac*qhacs(mgs) qhlacs(mgs) = frac*qhlacs(mgs) - qhcns(mgs) = frac*qhcns(mgs) - qsmlr(mgs) = frac*qsmlr(mgs) - qsshr(mgs) = frac*qsshr(mgs) - qssbv(mgs) = frac*qssbv(mgs) - qsmul(mgs) = frac*qsmul(mgs) + qhcns(mgs) = frac*qhcns(mgs) + qsmlr(mgs) = frac*qsmlr(mgs) + 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 ENDIF - + pqcii(mgs) = pqcii(mgs) & & + (1. - ifrzs)*qrfrzs(mgs) & & + (1. - ifrzs)*qiacrs(mgs) - - end do - + + end do + ! ! Graupel ! @@ -22643,21 +22643,21 @@ subroutine nssl_2mom_gs & ! rescale depletion frac = (-qx(mgs,lhl) + pqhli(mgs)*dtp)/(pqhld(mgs)*dtp) - + qhlmlr(mgs) = frac*qhlmlr(mgs) qhlsbv(mgs) = frac*qhlsbv(mgs) qhcnhl(mgs) = frac*qhcnhl(mgs) qhlmul1(mgs) = frac*qhlmul1(mgs) IF ( qhlcev(mgs) < 0.0 ) qhlcev(mgs) = frac*qhlcev(mgs) - + pqhld(mgs) = frac*pqhld(mgs) - + ENDIF ENDIF end do - + ENDIF ! lhl ELSEIF ( warmonly < 0.8 ) THEN @@ -22668,7 +22668,7 @@ subroutine nssl_2mom_gs & pqhwi(mgs) = & & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & & +il5(mgs)*(qhdpv(mgs)) & - & +qhacr(mgs)+qhacw(mgs) + & +qhacr(mgs)+qhacw(mgs) pqhwd(mgs) = & & qhshr(mgs) & !null at this point when wet graupel included & - qhlcnh(mgs) & @@ -22703,7 +22703,7 @@ subroutine nssl_2mom_gs & ENDIF ! warmonly ! -! Liquid water on snow and graupel +! Liquid water on snow and graupel ! vhmlr(:) = 0.0 @@ -22713,14 +22713,14 @@ subroutine nssl_2mom_gs & IF ( mixedphase ) THEN ELSE ! set arrays for non-mixedphase graupel - + ! vhshdr(:) = 0.0 vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation ! vhsoak(:) = 0.0 ! vhlshdr(:) = 0.0 vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation -! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) ! vhlsoak(:) = 0.0 ENDIF ! mixedphase @@ -22733,7 +22733,7 @@ subroutine nssl_2mom_gs & if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'graupel reflectivity' do mgs = 1,ngscnt - + ! zhmlr(mgs) = 0.0 ! zhshr(mgs) = 0.0 ! zhmlrr(mgs) = 0.0 @@ -22749,13 +22749,13 @@ subroutine nssl_2mom_gs & zhcni(mgs) = 0.0 zhacs(mgs) = 0.0 zhaci(mgs) = 0.0 - + ENDDO - IF ( lzh .gt. 1 ) THEN ! + IF ( lzh .gt. 1 ) THEN ! do mgs = 1,ngscnt - - + + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) .gt. 0.0 ) THEN tmp = qx(mgs,lh)/cx(mgs,lh) alp = Max( alphamin, alpha(mgs,lh) ) @@ -22765,11 +22765,11 @@ subroutine nssl_2mom_gs & zhaci(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhaci(mgs) ) zhacs(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacs(mgs) ) - + IF ( .not. mixedphase .and. ibinhmlr < 1 ) THEN zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) ENDIF - + zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) ! IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 .and. ibinhmlr < 1 ) THEN @@ -22791,7 +22791,7 @@ subroutine nssl_2mom_gs & ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) ! ENDIF IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail - z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ELSE z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? ENDIF @@ -22801,7 +22801,7 @@ subroutine nssl_2mom_gs & ELSE zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ENDIF - + zhshrr(mgs) = Min( 0.0, zhshrr(mgs) ) ENDIF @@ -22810,13 +22810,13 @@ subroutine nssl_2mom_gs & write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lh),cx(mgs,lh),zx(mgs,lh) write(0,*) ( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ), 2.*tmp * qhshr(mgs), - tmp**2 * chshr(mgs) write(0,*) 'temcg = ',temcg(mgs),'chshr recalc = ',(cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) - + STOP ENDIF ! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) ) - + qtmp = qhdpv(mgs) + qhcev(mgs) + qhsbv(mgs) ctmp = chdpv(mgs) + chcev(mgs) + chsbv(mgs) @@ -22873,7 +22873,7 @@ subroutine nssl_2mom_gs & ! note that 3.6476 = (6/pi)**2 ziacr(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.))* & & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) - ELSE ! imurain == 1 + ELSE ! imurain == 1 ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* & & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) ENDIF @@ -22883,9 +22883,9 @@ subroutine nssl_2mom_gs & ! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qiacrf(mgs) - qsplinter(mgs)) - tmp**2 * ciacrf(mgs) ) ! ziacrf(mgs) = Min( ziacrf(mgs), z ) ENDIF - - - + + + IF ( ffrzh*qrfrzf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 ) THEN tmp = qx(mgs,lr)/cx(mgs,lr) ! alp = 3.0 @@ -22909,13 +22909,13 @@ subroutine nssl_2mom_gs & ! zrfrzf(mgs) = Min( zrfrzf(mgs), z ) ! change this to be alpha=0? ENDIF - + IF ( lhl > 1 .and. qhcnhl(mgs) .gt. 0.0 ) THEN tmp = qx(mgs,lhl)/cx(mgs,lhl) zhcnhl(mgs) = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) ) - + ENDIF - + IF ( qhcns(mgs) > 0.0 .and. chcns(mgs) > 0.0 .and. cx(mgs,ls) > cxmin .and. vhcns(mgs) > 0 ) THEN tmp = qx(mgs,ls)/cx(mgs,ls) r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles @@ -22934,7 +22934,7 @@ subroutine nssl_2mom_gs & zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * & & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcnih(mgs) ) ENDIF - + pzhwi(mgs) = & & +ifrzg*ffrzh*(zrfrzf(mgs) & @@ -22959,13 +22959,13 @@ subroutine nssl_2mom_gs & ! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs) ! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp ! write(0,*) ( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) ) -! +! !! STOP ! ENDIF end do if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'end graupel reflectivity' - + ENDIF ! @@ -22973,11 +22973,11 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt - + zhldsv(mgs) = 0.0 zhlacr(mgs) = 0.0 zhlacw(mgs) = 0.0 - + ENDDO IF ( lzhl .gt. 1 .or. ( lzr > 1 .and. lnhl > 1 ) ) THEN ! also run for 2-moment hail for 3-moment rain sources @@ -22985,17 +22985,17 @@ subroutine nssl_2mom_gs & if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'hail reflectivity' do mgs = 1,ngscnt - + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) .gt. 0.0 ) THEN tmp = qx(mgs,lhl)/cx(mgs,lhl) alp = Max( alphamin, alpha(mgs,lhl) ) ! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) - + IF ( .not. mixedphase .and. qhlmlr(mgs) /= 0.0 .and. chlmlr(mgs) /= 0.0 .and. ibinhlmlr < 1 ) THEN zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) ) ENDIF - + zhlshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) IF ( lzr > 1 .and. qhlshr(mgs) /= 0.0 .and. chlshrr(mgs) /= 0.0 ) THEN IF ( temg(mgs) >= tfr ) THEN @@ -23004,7 +23004,7 @@ subroutine nssl_2mom_gs & ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) ! ENDIF IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail - z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) + z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ELSE z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr? ENDIF @@ -23023,16 +23023,16 @@ subroutine nssl_2mom_gs & write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lhl),cx(mgs,lhl),zx(mgs,lhl) write(0,*) ( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ), 2.*tmp * qhlshr(mgs), - tmp**2 * chlshr(mgs) write(0,*) 'temcg = ',temcg(mgs),'chlshr recalc = ',(cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) - + STOP ENDIF ! zhlshr(mgs) = Min( 0.0, zhlshr(mgs) ) ! zhlshr(mgs) = (xdn0(lr)/(xdn(mgs,lhl)))**2*( zx(mgs,lhl) * qhlshr(mgs) ) - + qtmp = qhldpv(mgs) + qhlcev(mgs) ctmp = chldpv(mgs) + chlcev(mgs) - + zhldsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) alp = Max( alphahacx, alpha(mgs,lhl) ) @@ -23044,7 +23044,7 @@ subroutine nssl_2mom_gs & ! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*qhlacr(mgs))**2)/(cx(mgs,lhl)) zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) ) ! zhlacr(mgs) = Min( zxmxd(mgs,lr), zhlacr(mgs) ) - + ! IF ( z > zx(mgs,lhl) ) THEN ! zhlacr(mgs) = (z - zx(mgs,lhl))*dtpinv ! ELSE @@ -23058,7 +23058,7 @@ subroutine nssl_2mom_gs & 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) ) @@ -23068,7 +23068,7 @@ subroutine nssl_2mom_gs & ! 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 @@ -23078,12 +23078,12 @@ subroutine nssl_2mom_gs & zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv ENDIF ENDIF - + ENDIF ! } - + ENDIF ! qsplinter(mgs) - + IF ( lzhl > 1 ) THEN pzhli(mgs) = ffrzh*(((1.0-ifrzg)*zrfrzf(mgs) & & +il5(mgs)*(1.0-ifiacrg)*ziacrf(mgs) )) & @@ -23098,7 +23098,7 @@ subroutine nssl_2mom_gs & & + zhlshr(mgs) & & - zhcnhl(mgs) & & + Min( 0.0, zhldsv(mgs) ) - + IF ( .not. ( -1.0 < pzhli(mgs) .and. pzhli(mgs) < 1.e20 ) ) THEN write(iunit,*) 'Problem with pzhli!' @@ -23109,11 +23109,11 @@ subroutine nssl_2mom_gs & write(iunit,*) 'Problem with pzhld!' write(iunit,*) 'zhlmlr,zhlshr,zhldsv = ',zhlmlr(mgs),zhlshr(mgs),zhldsv(mgs) ENDIF - + ENDIF ! lzhl > 1 - + end do - + ENDIF ! @@ -23121,10 +23121,10 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'WARMZIEG: dbg = 11' - IF ( lzr .gt. 1 ) THEN ! - + IF ( lzr .gt. 1 ) THEN ! + DO mgs = 1,ngscnt - + zracw(mgs) = 0.0 zracr(mgs) = 0.0 zrcev(mgs) = 0.0 @@ -23148,7 +23148,7 @@ subroutine nssl_2mom_gs & zsmlrr(mgs) = z1 ENDIF ENDIF - + ! zsshr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & ! & ( 2.*tmp * qsshr(mgs) - tmp**2 * csshr(mgs) ) @@ -23156,25 +23156,25 @@ subroutine nssl_2mom_gs & z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsshr(mgs)**2/ csshrr(mgs) ) zsshrr(mgs) = z1 ENDIF - + ENDIF !} - + IF ( .not. mixedphase ) THEN !{ IF ( zhmlr(mgs) < 0.0 .and. chmlrr(mgs) /= 0.0 .and. ibinhmlr == 0 ) THEN !{ tmp = qx(mgs,lh)/cx(mgs,lh) ! zhmlrr(mgs) = Min(0.0, (xdn(mgs,lh)/xdn(mgs,lr))**2 * & ! & g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlrr(mgs) ) ) - + ! IF ( zhmlrr(mgs) >= 0. ) THEN ! zhmlrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhmlr(mgs) ! ENDIF IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of graupel - z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) + z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha) z1 = Min(g1x(mgs,lh),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) ENDIF zhmlrr(mgs) = z1 -! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) ! zhmlrr(mgs) = Max( z1, zhmlrr(mgs)) ENDIF !} @@ -23191,7 +23191,7 @@ subroutine nssl_2mom_gs & ! ENDIF IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail - z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) + z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha) z1 = Min(g1x(mgs,lhl),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) ! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) @@ -23203,7 +23203,7 @@ subroutine nssl_2mom_gs & ! zhlmlr(mgs) = ! zhlshrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlshr(mgs) ENDIF - + ENDIF ! } IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) .gt. 0.0 ) THEN @@ -23215,20 +23215,20 @@ subroutine nssl_2mom_gs & IF ( qracw(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) ) ENDIF - + IF ( cracr(mgs) /= 0.0 .and. cx(mgs,lr) > 0.0 ) THEN zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) ) ENDIF qtmp = qrcev(mgs) ctmp = crcev(mgs) - + ! IF ( .false. .or. iferwisventr == 2 ) THEN ! zrcev(mgs) = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs) ) ! ELSE zrcev(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) - + IF ( iferwisventr == 2 ) THEN vent1 = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs)) zrcev(mgs) = Max( dble(zrcev(mgs)), vent1 ) @@ -23241,21 +23241,21 @@ subroutine nssl_2mom_gs & ! ENDIF zrcev(mgs) = Max( zrcev(mgs), -zxmxd(mgs,lr) ) - IF ( qhacr(mgs) > 0.0 ) THEN + IF ( qhacr(mgs) > 0.0 ) THEN zrach(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhacr(mgs) - tmp**2 * chacr(mgs) ) zrach(mgs) = Min( zrach(mgs), zxmxd(mgs,lr) ) - + ENDIF - IF ( lhl > 1 .and. qhlacr(mgs) > 0.0 ) THEN + IF ( lhl > 1 .and. qhlacr(mgs) > 0.0 ) THEN zrachl(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhlacr(mgs) - tmp**2 * chlacr(mgs) ) zrachl(mgs) = Min( zrachl(mgs), zxmxd(mgs,lr) ) ENDIF - + ENDIF pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) & @@ -23265,7 +23265,7 @@ subroutine nssl_2mom_gs & & - (1-il5(mgs))*zhmlrr(mgs) & & - zhshrr(mgs) & & - (1-il5(mgs))*zhlmlrr(mgs) & - & - zhlshrr(mgs) + & - zhlshrr(mgs) pzrwd(mgs) = 0.0 & @@ -23273,7 +23273,7 @@ subroutine nssl_2mom_gs & & - zrach(mgs) & & - zrachl(mgs) & & - zrfrz(mgs) & - & - il5(mgs)*(ziacr(mgs) ) + & - il5(mgs)*(ziacr(mgs) ) IF ( zx(mgs,lr) + dtp*(pzrwi(mgs)+pzrwd(mgs)) <= 0.0 & @@ -23342,7 +23342,7 @@ subroutine nssl_2mom_gs & ! > + vhfrh(mgs) & & + f2h*vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs))*ffrzh ! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh) - + ! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh) pvhwd(mgs) = rho0(mgs)*( & @@ -23356,7 +23356,7 @@ subroutine nssl_2mom_gs & & - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) - vscnh(mgs) ! IF (mixedphase) THEN -! pvhwd(mgs) = pvhwd(mgs) +! pvhwd(mgs) = pvhwd(mgs) ! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) ! ENDIF @@ -23367,7 +23367,7 @@ subroutine nssl_2mom_gs & xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ & & (vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) ) - IF ( mixedphase ) THEN + IF ( mixedphase ) THEN IF ( qxw(mgs,lh) .gt. 0.0 ) THEN dnmx = xdnmx(lr) ELSE @@ -23378,15 +23378,15 @@ subroutine nssl_2mom_gs & ENDIF xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lh) ) - + drhodt = (xdn_new - xdn(mgs,lh))*dtpinv - + zhwdn(mgs) = -2.*g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh)*6.*pii )**2/(cx(mgs,lh)*xdn(mgs,lh)**3)*drhodt - + pzhwi(mgs) = pzhwi(mgs) + Max(0.0, zhwdn(mgs)) pzhwd(mgs) = pzhwd(mgs) + Min(0.0, zhwdn(mgs)) - - + + ENDIF IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN @@ -23459,9 +23459,9 @@ 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)) & + & + 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) - + pvhld(mgs) = rho0(mgs)*( & & +( qhlsbv(mgs) & & + Min(0.0, qhlcev(mgs)) & @@ -23476,8 +23476,8 @@ subroutine nssl_2mom_gs & xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ & & (vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) ) - - IF ( mixedphase ) THEN + + IF ( mixedphase ) THEN IF ( qxw(mgs,lhl) .gt. 0.0 ) THEN dnmx = xdnmx(lr) ELSE @@ -23487,19 +23487,19 @@ subroutine nssl_2mom_gs & dnmx = xdnmx(lhl) ENDIF xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lhl) ) - + drhodt = (xdn_new - xdn(mgs,lhl))*dtpinv - + zhldn(mgs) = -2.*g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl)*6.*pii )**2/(cx(mgs,lhl)*xdn(mgs,lhl)**3)*drhodt - + pzhli(mgs) = pzhli(mgs) + Max(0.0, zhldn(mgs)) pzhld(mgs) = pzhld(mgs) + Min(0.0, zhldn(mgs)) - - + + ENDIF ENDDO - + ENDIF ENDIF @@ -23518,10 +23518,10 @@ subroutine nssl_2mom_gs & & + pqhli(mgs) + pqhld(mgs) ! - - + + ENDDO - + do mgs = 1,ngscnt if ( ( (ndebug .ge. 0 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & @@ -23673,9 +23673,9 @@ subroutine nssl_2mom_gs & write(iunit,*) -(1-il5(mgs))*qsmlr(mgs) write(iunit,*) -(1-il5(mgs))*qimlr(mgs) write(iunit,*) -qrshr(mgs) - write(iunit,*) 'pqrwi = ', pqrwi(mgs) - write(iunit,*) -qsshr(mgs) - write(iunit,*) -qhshr(mgs) + write(iunit,*) 'pqrwi = ', pqrwi(mgs) + write(iunit,*) -qsshr(mgs) + write(iunit,*) -qhshr(mgs) write(iunit,*) -qhlshr(mgs) write(iunit,*) -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs) write(iunit,*) -il5(mgs)*qrfrz(mgs) @@ -23683,20 +23683,20 @@ subroutine nssl_2mom_gs & write(iunit,*) -qhacr(mgs) write(iunit,*) -qhlacr(mgs) write(iunit,*) qrcev(mgs) - write(iunit,*) 'pqrwd = ', pqrwd(mgs) + write(iunit,*) 'pqrwd = ', pqrwd(mgs) write(iunit,*) 'qrzfac = ', qrzfac(mgs) ! - + write(iunit,*) write(iunit,*) 'Rain concentration' - write(iunit,*) pcrwi(mgs) + write(iunit,*) pcrwi(mgs) write(iunit,*) crcnw(mgs) write(iunit,*) 1-il5(mgs) write(iunit,*) -chmlr(mgs),-csmlr(mgs) write(iunit,*) -crshr(mgs) - write(iunit,*) pcrwd(mgs) + write(iunit,*) pcrwd(mgs) write(iunit,*) il5(mgs) - write(iunit,*) -ciacr(mgs),-crfrz(mgs) + write(iunit,*) -ciacr(mgs),-crfrz(mgs) write(iunit,*) -csacr(mgs),-chacr(mgs) write(iunit,*) +crcev(mgs) write(iunit,*) cracr(mgs) @@ -23713,11 +23713,11 @@ subroutine nssl_2mom_gs & write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) write(iunit,*) qsacw(mgs),qwfrzc(mgs), qwctfzc(mgs), qicichr(mgs) write(iunit,*) qsacr(mgs), qscnh(mgs) - write(iunit,*) il2(mgs)*qsacr(mgs) - write(iunit,*) il5(mgs)*qicicnt(mgs)*ffrzs + 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,*) Max(0.0, qscev(mgs)) + write(iunit,*) qsacw(mgs) + qscnh(mgs) write(iunit,*) 'pqswi = ',pqswi(mgs) write(iunit,*) -qhcns(mgs) write(iunit,*) -qracs(mgs) @@ -23728,11 +23728,11 @@ subroutine nssl_2mom_gs & ! write(iunit,*) qsshrp(mgs) write(iunit,*) il5(mgs)*(qssbv(mgs)) write(iunit,*) 'pqswd = ', pqswd(mgs) - write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) - write(iunit,*) -qhcns(mgs) - write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) + write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) write(iunit,*) qssbv(mgs) - write(iunit,*) Min(0.0, qscev(mgs)) + write(iunit,*) Min(0.0, qscev(mgs)) write(iunit,*) -qsmul(mgs) ! ! @@ -23819,7 +23819,7 @@ subroutine nssl_2mom_gs & pmlt(mgs) = & & (1-il5(mgs))* & & (qhmlr(mgs)+qsmlr(mgs)+ & - & qhlmlr(mgs)) !+qhmlh(mgs)) + & qhlmlr(mgs)) !+qhmlh(mgs)) ! NOTE: psub is sum of sublimation and deposition psub(mgs) = & & il5(mgs)*( & @@ -23839,7 +23839,7 @@ subroutine nssl_2mom_gs & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & & + qhldpv(mgs) & - & + qidpv(mgs) ) & + & + qidpv(mgs) ) & & +il5(mgs)*(qiint(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pfrz(mgs) = & @@ -23853,7 +23853,7 @@ subroutine nssl_2mom_gs & & +qwctfz(mgs)+qiihr(mgs) & & +qiacw(mgs) & & +qhacw(mgs) + qhlacw(mgs) & - & +qhacr(mgs) + qhlacr(mgs) ) + & +qhacr(mgs) + qhlacr(mgs) ) psub(mgs) = 0.0 + & & il5(mgs)*( & & + qhdpv(mgs) & @@ -23861,7 +23861,7 @@ subroutine nssl_2mom_gs & & + qidpv(mgs) + qisbv(mgs) ) & & +il5(mgs)*(qiint(mgs)) pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs) + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs) ELSE pfrz(mgs) = 0.0 psub(mgs) = 0.0 @@ -23950,7 +23950,7 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cx(mgs,li) = cx(mgs,li) + & - & dtp*(pccii(mgs)+pccid(mgs)) + & dtp*(pccii(mgs)+pccid(mgs)) cina(mgs) = cina(mgs) + pccin(mgs)*dtp IF ( ipconc .ge. 2 ) THEN cx(mgs,lc) = cx(mgs,lc) + & @@ -23972,8 +23972,8 @@ subroutine nssl_2mom_gs & & dtp*(pchli(mgs)+pchld(mgs)) - - + + ENDIF ENDIF IF ( ipconc .ge. 6 ) THEN @@ -24002,7 +24002,7 @@ subroutine nssl_2mom_gs & IF ( has_wetscav ) THEN DO mgs = 1,ngscnt - evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) + evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + & qraci(mgs) + qsaci(mgs) + qhaci(mgs) + qhlaci(mgs) + qscni(mgs) ENDDO @@ -24045,7 +24045,7 @@ subroutine nssl_2mom_gs & ! pfrz(mgs) = pfrz(mgs) - qitmp(mgs)*dtpinv ptem(mgs) = ptem(mgs) + & & (1./pi0(mgs))* & - & felfcp(mgs)*(- qitmp(mgs)*dtpinv) + & felfcp(mgs)*(- qitmp(mgs)*dtpinv) IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) - (felfpi(mgs)*qitmp(mgs)) ENDIF @@ -24089,7 +24089,7 @@ subroutine nssl_2mom_gs & ctmp = 0.0 frac = 0.0 qtmp = 0.0 - + ! if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and. & ! & qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then ! commented for test (12/01/2015): @@ -24103,17 +24103,17 @@ subroutine nssl_2mom_gs & ELSEIF ( ibfc /= 2 .or. ipconc < 2 ) THEN frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) ) ELSE - volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 ! for mean temperature for freezing: -ln (V) = a*Ts - b ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 - + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) - frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes - ! sure that cwfrz and qwfrz are consistent and prevents + frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes + ! sure that cwfrz and qwfrz are consistent and prevents ! spurious creation of ice crystals. - + ENDIF qtmp = frac*qx(mgs,lc) @@ -24125,7 +24125,7 @@ subroutine nssl_2mom_gs & pfrz(mgs) = pfrz(mgs) + qtmp*dtpinv ptem(mgs) = ptem(mgs) + & & (1./pi0(mgs))* & - & felfcp(mgs)*(qtmp*dtpinv) + & felfcp(mgs)*(qtmp*dtpinv) IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + felfpi(mgs)*qtmp @@ -24145,7 +24145,7 @@ subroutine nssl_2mom_gs & ELSE ! (ipconc .lt. 2 ) ctmp = 0.0 IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN - qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1) + qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1) ! cx(mgs,lc) = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp @@ -24183,7 +24183,7 @@ subroutine nssl_2mom_gs & ! reset temporaries for cloud particles and vapor ! qcond(:) = 0.0 - + IF ( ipconc .le. 1 .and. lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983) DO mgs = 1,ngscnt @@ -24214,17 +24214,17 @@ subroutine nssl_2mom_gs & qvap(mgs) = qvap(mgs) - qcond(mgs) qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) ) thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs)) - + ENDIF - + ENDDO - + ENDIF - - + + IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN ! IF ( ipconc .le. 1 ) THEN - + do mgs = 1,ngscnt qx(mgs,lv) = max( 0.0, qvap(mgs) ) qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) @@ -24326,7 +24326,7 @@ subroutine nssl_2mom_gs & ! condensation/deposition ! IF ( dqwv(mgs) .ge. 0. ) THEN - + ! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) ! qitmp(mgs) = qx(mgs,li) @@ -24361,7 +24361,7 @@ subroutine nssl_2mom_gs & denom2 = 1.0 + gamss* & & (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1 dqvcnd(mgs) = dqwv(mgs) / denom2 - END IF + END IF ENDIF ! temg(mgs) .lt. tfr ! @@ -24500,17 +24500,17 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt ! an(igs(mgs),jy,kgs(mgs),lt) = & - & theta0(mgs) + thetap(mgs) + & theta0(mgs) + thetap(mgs) an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) ! IF ( eqtset > 2 ) THEN p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) ENDIF ! - + DO il = lc,lhab IF ( ido(il) .eq. 1 ) THEN - IF ( lf > 1 .and. il == lf ) THEN + IF ( lf > 1 .and. il == lf ) THEN lfsave(mgs,1) = an(igs(mgs),jy,kgs(mgs),il) lfsave(mgs,2) = qx(mgs,il) ENDIF @@ -24535,7 +24535,7 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 6 ) THEN DO il = lr,lhab IF ( lz(il) .gt. 1 ) THEN - IF ( lf > 1 .and. il == lf ) THEN + IF ( lf > 1 .and. il == lf ) THEN lfsave(mgs,3) = an(igs(mgs),jy,kgs(mgs),lz(il)) lfsave(mgs,4) = zx(mgs,il) ENDIF @@ -24543,10 +24543,10 @@ subroutine nssl_2mom_gs & an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + & & min( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 ) zx(mgs,il) = an(igs(mgs),jy,kgs(mgs),lz(il)) - + ENDIF ENDDO - + ENDIF ! end do @@ -24565,7 +24565,7 @@ subroutine nssl_2mom_gs & ! STOP IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity - + DO mgs = 1,ngscnt IF ( qx(mgs,il) .le. 0.0 ) THEN @@ -24575,7 +24575,7 @@ subroutine nssl_2mom_gs & ! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) ! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(cxmin,cx(mgs,il))) xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il)) - + ! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN ! write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il) ! ENDIF @@ -24597,13 +24597,13 @@ subroutine nssl_2mom_gs & IF ( il == ls ) THEN xvbarmax = xvbarmax*Max(1.,100./Min(100.,xdn(mgs,ls))) ENDIF - + IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvbarmax ) THEN xv(mgs,il) = Min( xvbarmax, xv(mgs,il) ) xv(mgs,il) = Max( xvmn(il), xv(mgs,il) ) cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il)) ENDIF - + ENDIF !} ! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN @@ -24612,15 +24612,15 @@ subroutine nssl_2mom_gs & ENDIF !} ENDDO ! mgs - + ELSE ! } { is three-moment, so have to adjust Z if size is too large IF ( il == lr .and. imurain == 3 ) THEN ! { { RAIN -! rdmx = -! rdmn = +! rdmx = +! rdmn = DO mgs = 1,ngscnt - + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN IF ( zx(mgs,lr) <= zxmin ) THEN @@ -24639,7 +24639,7 @@ subroutine nssl_2mom_gs & an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) ENDIF ENDIF - + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) @@ -24672,14 +24672,14 @@ subroutine nssl_2mom_gs & ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) z = zx(mgs,il) qr = qx(mgs,il) cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) ENDIF - + IF ( zx(mgs,lr) > 0.0 ) THEN xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) vr = xv(mgs,lr) @@ -24712,15 +24712,15 @@ subroutine nssl_2mom_gs & x3 = x2**3 cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) - ELSE ! simple cutoff + ELSE ! simple cutoff xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) ENDIF !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) - - + + IF ( tmp < cx(mgs,il) ) THEN ! breakup g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) @@ -24742,12 +24742,12 @@ subroutine nssl_2mom_gs & alp = Max( rnumin, Min( rnumax, alp ) ) ENDDO - + ENDIF ENDIF ! -! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the ! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) ! g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) @@ -24756,36 +24756,36 @@ subroutine nssl_2mom_gs & IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) - + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) zx(mgs,il) = z an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) ENDIF ENDIF - - + + ENDIF ENDIF - + ENDIF - + ENDDO -! CALL cld_cpu('Z-MOMENT-1r') - - +! CALL cld_cpu('Z-MOMENT-1r') + + ELSEIF ( il == lh .or. il == lhl .or. il == lf .or. (il == lr .and. imurain == 1 )) THEN ! } { Rain, GRAUPEL OR HAIL - - + + DO mgs = 1,ngscnt - IF ( lf > 1 .and. il == lf ) THEN + IF ( lf > 1 .and. il == lf ) THEN lfsave(mgs,5) = an(igs(mgs),jy,kgs(mgs),ln(il)) lfsave(mgs,6) = cx(mgs,il) ENDIF - + IF ( il == lhl .and. lnhlf > 1 ) THEN IF ( cx(mgs,lhl) > cxmin ) THEN frac = chxf(mgs,lhl)/cx(mgs,lhl) @@ -24804,8 +24804,8 @@ 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 + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! { .or. qx(mgs,il) <= qxmin(il) + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 !! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) qx(mgs,il) = 0.0 cx(mgs,il) = 0.0 @@ -24821,8 +24821,8 @@ subroutine nssl_2mom_gs & 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 + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) zx(mgs,il) = 0.0 qx(mgs,il) = 0.0 @@ -24831,7 +24831,7 @@ subroutine nssl_2mom_gs & an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) ENDIF ELSE - IF ( zx(mgs,il) < 0.0 ) THEN ! .and. qx(mgs,il) > 0.05e-3 + IF ( zx(mgs,il) < 0.0 ) THEN ! .and. qx(mgs,il) > 0.05e-3 zx(mgs,il) = 0.0 ENDIF ENDIF !} @@ -24846,7 +24846,7 @@ subroutine nssl_2mom_gs & an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) ENDIF - + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN !{ xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) @@ -24887,10 +24887,10 @@ subroutine nssl_2mom_gs & ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 ! write(0,*) 'GS: moment problem! il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il) - + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) z = zx(mgs,il) @@ -24898,9 +24898,9 @@ subroutine nssl_2mom_gs & ! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) - + ! write(0,*) 'GS: moment problem! reset il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il) - + ELSE ! have all valid moments, so find shape parameter chw = cx(mgs,il) @@ -24959,40 +24959,40 @@ subroutine nssl_2mom_gs & alp = Max( alphamin, Min( alphamax, alp ) ) ENDDO - + ENDIF ENDIF !} ! -! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the ! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) ! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) - + IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. & & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN !{ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) - + ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. & .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C - + wtest = .false. IF ( irescalerainopt == 0 ) THEN wtest = .false. ELSEIF ( irescalerainopt == 1 ) THEN - wtest = qx(mgs,lc) > qxmin(lc) + wtest = qx(mgs,lc) > qxmin(lc) ELSEIF ( irescalerainopt == 2 ) THEN wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh ELSEIF ( irescalerainopt == 3 ) THEN wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh ENDIF - + IF ( il == lr .and. ( wtest .or. .not. rescale_low_alphar ) ) THEN - ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted + ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted ! drops (i.e., favor preserving Z when alpha tries to go negative) chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1 cx(mgs,il) = chw @@ -25012,15 +25012,15 @@ subroutine nssl_2mom_gs & ENDIF ENDIF !} - - + + ENDIF !} - - + + ENDIF ! !} - - - + + + ENDIF !} IF ( lzr > 1 ) THEN @@ -25047,19 +25047,19 @@ subroutine nssl_2mom_gs & ! write(0,*) 'ix,jy, kz, cf = ',igs(mgs)+ixbeg,jy+jybeg,kgs(mgs), an(igs(mgs),jy,kgs(mgs),ln(lf)),lfsave(mgs,5),lfsave(mgs,6) ! write(0,*) 'qold,qxold,zold,zxold = ',lfsave(mgs,1),lfsave(mgs,2),lfsave(mgs,3),lfsave(mgs,4) ! write(0,*) 'cf_new,pcfwi,pcfwd = ',cx(mgs,lf),cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ),pcfwi(mgs) + pcfwd(mgs) -! +! ! ENDIF - + ENDDO ! mgs -! CALL cld_cpu('Z-DELABK') - +! CALL cld_cpu('Z-DELABK') + + +! CALL cld_cpu('Z-DELABK') + + + -! CALL cld_cpu('Z-DELABK') - - - - ENDIF ! } } ENDIF ! }} @@ -25074,7 +25074,7 @@ subroutine nssl_2mom_gs & ENDIF IF ( il == lhl ) THEN - + IF ( lnhlf > 1 ) THEN ! number of hail from frozen drops ! 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) @@ -25102,9 +25102,9 @@ subroutine nssl_2mom_gs & ENDIF end do ENDIF - + ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN - + DO mgs = 1,ngscnt an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0) ENDDO @@ -25122,11 +25122,11 @@ subroutine nssl_2mom_gs & an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) ) ENDDO - + ENDIF - + ENDDO - + ENDIF ! ! diff --git a/physics/MP/Zhao_Carr/zhaocarr_gscond.meta b/physics/MP/Zhao_Carr/zhaocarr_gscond.meta index ed57ca909..250ca36e7 100644 --- a/physics/MP/Zhao_Carr/zhaocarr_gscond.meta +++ b/physics/MP/Zhao_Carr/zhaocarr_gscond.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = zhaocarr_gscond type = scheme - dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/MP/Zhao_Carr/zhaocarr_precpd.meta b/physics/MP/Zhao_Carr/zhaocarr_precpd.meta index 86e6c7d67..8e8b5919b 100644 --- a/physics/MP/Zhao_Carr/zhaocarr_precpd.meta +++ b/physics/MP/Zhao_Carr/zhaocarr_precpd.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = zhaocarr_precpd type = scheme - dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -267,4 +267,3 @@ dimensions = () type = integer intent = out - diff --git a/physics/MP/calpreciptype.f90 b/physics/MP/calpreciptype.f90 index 792c0ba84..9fa5590e6 100644 --- a/physics/MP/calpreciptype.f90 +++ b/physics/MP/calpreciptype.f90 @@ -11,30 +11,32 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & xlat,xlon, & gt0,gq0,prsl,prsi,prec, & !input phii,tskin, & !input + con_g, con_eps, con_epsm1, & !input + con_epsq, con_fvirt, con_rog, & !input domr,domzr,domip,doms) !output !$$$ subprogram documentation block -! . . . +! . . . ! subprogram: calpreciptype compute dominant precip type ! prgrmmr: chuang org: w/np2 date: 2008-05-28 -! -! +! +! ! abstract: ! this routine computes precipitation type. -! . it is adopted from post but was made into a column to used by gfs model -! +! . it is adopted from post but was made into a column to used by gfs model +! ! -------------------------------------------------------------------- use funcphys, only : fpvs,ftdp,fpkap,ftlcl,stma,fthe - use physcons use machine , only : kind_phys !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! - real(kind=kind_phys), parameter :: pthresh = 0.0, oneog = 1.0/con_g + real(kind=kind_phys), parameter :: pthresh = 0.0 + real(kind=kind_phys) :: oneog integer,parameter :: nalg = 5 -! +! ! declare variables. -! +! integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1 real(kind=kind_phys),intent(in) :: xlat(im),xlon(im) real(kind=kind_phys),intent(in) :: randomno(ix,nrcm) @@ -42,7 +44,9 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & real(kind=kind_phys),dimension(ix,lm), intent(in) :: gt0,gq0,prsl real(kind=kind_phys),dimension(ix,lp1),intent(in) :: prsi,phii real(kind=kind_phys),dimension(im), intent(out) :: domr,domzr,domip,doms - + real(kind=kind_phys),intent(in) :: con_g, con_eps, con_epsm1 + real(kind=kind_phys),intent(in) :: con_epsq, con_fvirt, con_rog + integer, dimension(nalg) :: sleet,rain,freezr,snow real(kind=kind_phys),dimension(lm) :: t,q,pmid real(kind=kind_phys),dimension(lp1) :: pint,zint @@ -53,14 +57,15 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & time_vert,time_ncep,time_ramer,time_bourg,time_revised,& time_dominant,btim,timef,ranl(2) -! + oneog = 1.0/con_g +! ! computes wet bulb here since two algorithms use it ! lp1=lm+1 ! convert geopotential to height ! do l=1,lp1 ! zint(l)=zint(l)/con_g ! end do -! don't forget to flip 3d arrays around because gfs counts from bottom up +! don't forget to flip 3d arrays around because gfs counts from bottom up allocate ( twet(lm),rh(lm),td(lm) ) @@ -96,11 +101,11 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & else twet(k1) = t(k1) endif -! endif +! endif es = min(fpvs(t(k1)), pmid(k1)) qc = con_eps*es / (pmid(k1)+con_epsm1*es) rh(k1) = max(con_epsq,q(k1)) / qc - + k1 = lp1-k+1 pint(k1) = prsi(i,k) zint(k1) = phii(i,k) * oneog @@ -108,7 +113,7 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & enddo pint(1) = prsi(i,lp1) zint(1) = phii(i,lp1) * oneog - + !------------------------------------------------------------------------------- ! if(kdt>15.and.kdt<20) time_vert = time_vert + (timef() - btim) ! debug print statement @@ -123,10 +128,10 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & ! pmid(l),pint(l),zint(l),twet(l) ! end do ! print*,'debug in calpreciptype: lp1,pint,z ', lp1,pint(lp1),zint(lp1) -! end if -! end debug print statement -! call wetbulb(lm,con_rocp,con_epsq,t,q,pmid,twet) -! if(kdt>10.and.kdt<20)btim = timef() +! end if +! end debug print statement +! call wetbulb(lm,con_rocp,con_epsq,t,q,pmid,twet) +! if(kdt>10.and.kdt<20)btim = timef() !------------------------------------------------------------------------------- ! ! instantaneous precipitation type. @@ -153,7 +158,7 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & ! rh(l)=max(con_epsq,q(l))/qc ! pv = pmid(l)*q(l)/(con_eps-con_epsm1*q(l)) ! td(l)=ftdp(pv) -! end do +! end do ! if(kdt>10.and.kdt<20)btim = timef() ! write(0,*)' i=',i,' lm=',lm,' lp1=',lp1,' t=',t(1),q(1),pmid(1) & @@ -194,12 +199,12 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & rain(4) = iwx/8 ! ! explicit algorithm (under 18 not admitted without parent or guardian) - + snow(5) = 0 sleet(5) = 0 freezr(5) = 0 rain(5) = 0 -! +! call calwxt_dominant(nalg,rain(1),freezr(1),sleet(1), & snow(1),domr(i),domzr(i),domip(i),doms(i)) @@ -211,17 +216,17 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & end if enddo ! end loop for i - deallocate (twet,rh,td) + deallocate (twet,rh,td) return end -!> This subroutine computes precipitation type using a decision tree approach that uses -!! variables such as integrated wet bulb temperatue below freezing and lowest layer +!> This subroutine computes precipitation type using a decision tree approach that uses +!! variables such as integrated wet bulb temperatue below freezing and lowest layer !! temperature (Baldwin et al. 1994 \cite baldwin_et_al_1994) subroutine calwxt(lm,lp1,t,q,pmid,pint, & d608,rog,epsq,zint,iwx,twet) use machine , only : kind_phys -! +! ! file: calwxt.f ! written: 11 november 1993, michael baldwin ! revisions: @@ -229,7 +234,7 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! 12 june 1998-conversion to 2-d (t black) ! 01-10-25 h chuang - modified to process hybrid model output ! 02-01-15 mike baldwin - wrf version -! +! ! ! routine to compute precipitation type using a decision tree ! approach that uses variables such as integrated wet bulb temp @@ -238,7 +243,7 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! see baldwin and contorno preprint from 13th weather analysis ! and forecasting conference for more details ! (or baldwin et al, 10th nwp conference preprint) -! +! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -264,18 +269,18 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! internal: ! ! real(kind=kind_phys), allocatable :: twet(:) - real(kind=kind_phys), parameter :: d00=0.0 + real(kind=kind_phys), parameter :: d00=0.0 integer karr,licee real(kind=kind_phys) tcold,twarm ! subroutines called: ! wetbulb -! +! ! ! initialize weather type array to zero (ie, off). ! we do this since we want iwx to represent the ! instantaneous weather type on return. -! +! ! ! allocate local storage ! @@ -374,7 +379,7 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! pintk1 is the pressure at the bottom of the layer ! pintk2 is the pressure at the top of the layer ! -! areap4 is the area of twet above -4 c below highest sat lyr +! areap4 is the area of twet above -4 c below highest sat lyr ! areas8 = d00 areap4 = d00 @@ -482,14 +487,14 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! + ptyp) ! output(2) phase 2=rain, 3=frzg, 4=solid, ! 6=ip jc 9/16/99 ! use params_mod -! use ctlblk_mod +! use ctlblk_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - use machine , only : kind_phys implicit none ! real(kind=kind_phys),parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & & emelt=0.045,rlim=0.04,slim=0.85 - real(kind=kind_phys),parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now + real(kind=kind_phys),parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now ! integer*4 i, k1, lll, k2, toodry ! @@ -518,7 +523,7 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! qc=pq0/p(l) * exp(a2*(t(l)-a3)/(t(l)-a4)) !gsm forcing q (qtmp) to be positive to deal with negative q values ! causing problems later in this subroutine -! qtmp=max(h1m12,q(l)) +! qtmp=max(h1m12,q(l)) ! rhqtmp(lev)=qtmp/qc rhq(lev) = rh(l) pq(lev) = pmid(l) * 0.01 @@ -672,7 +677,7 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) dpk = log(pq(k1)/ptop) !lin dpk=pq(k1)-ptop ! mye = emelt*(1.0-(1.0-rhavg)*efac) mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye + icefrac = icefrac + dpk * dtavg / mye else ! mix where tw curve crosses twmelt in layer if (twq(k1) == twtop) go to 40 ! both equal twmelt, nothing h wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) @@ -683,7 +688,7 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! mye = emelt*(1.0-(1.0-rhavg)*efac) mye = emelt * rhavg ** efac icefrac = icefrac + dpk * dtavg / mye - icefrac = min(1.0,max(icefrac,0.0)) + icefrac = min(1.0,max(icefrac,0.0)) if (icefrac <= 0.0) then ! goto 1020 if (twq(k1) > twice) go to 40 ! cannot commence freezin @@ -735,12 +740,12 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) !gsm algorithms to provide an answer, i will not declare a !gsm type from the ramer in this situation and allow the !gsm other algorithms to make the call. - - ptyp = 0 ! don't know + + ptyp = 0 ! don't know ! ptyp = 5 ! mix else ! ptyp = 5 ! mix - ptyp = 0 ! don't know + ptyp = 0 ! don't know end if end if @@ -871,8 +876,8 @@ function xmytw(t,td,p) ! and layer lmh = bottom ! !$$$ -!>this routine computes precipitation type using a decision tree -!! approach that uses the so-called "energy method" of Bourgouin(2000) +!>this routine computes precipitation type using a decision tree +!! approach that uses the so-called "energy method" of Bourgouin(2000) !! \cite bourgouin_2000. !of aes (canada) 1992 subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) @@ -894,7 +899,7 @@ subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) ! initialize weather type array to zero (ie, off). ! we do this since we want ptype to represent the ! instantaneous weather type on return. -! +! ptype = 0 psfck = pint(lm+1) @@ -918,7 +923,7 @@ subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) lhiwrm = lm + 1 do l = lm, 1, -1 ! gsm added 250 mb check to prevent stratospheric warming situations -! from counting as warm layers aloft +! from counting as warm layers aloft if (t(l) >= 273.15 .and. pmid(l) > 25000.) lhiwrm = l end do @@ -942,7 +947,7 @@ subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) ifrzl = 0 areane = 0.0 areape = 0.0 - surfw = 0.0 + surfw = 0.0 do l = lm, 1, -1 if (ifrzl == 0 .and. t(l) <= 273.15) ifrzl = 1 @@ -961,7 +966,7 @@ subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) endif pintk1 = pintk2 enddo - + ! ! decision tree time ! @@ -1043,11 +1048,11 @@ subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) !! approach that uses variables such as integrated wet bulb temperature !! below freezing and lowest layer temperature (Baldwin et al.1994 !! \cite baldwin_et_al_1994). Since the original version of the algorithm -!! has a high bias for freezing rain and sleet, the revised version is +!! has a high bias for freezing rain and sleet, the revised version is !! to balance that bias with a version more likely to predict snow. subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & d608,rog,epsq,zint,twet,iwx) -! +! ! file: calwxt.f ! written: 11 november 1993, michael baldwin ! revisions: @@ -1057,8 +1062,8 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! 02-01-15 mike baldwin - wrf version ! 05-07-07 binbin zhou - add prec for rsm ! 05-08-24 geoff manikin - modified the area requirements -! to make an alternate algorithm -! +! to make an alternate algorithm +! ! ! routine to compute precipitation type using a decision tree ! approach that uses variables such as integrated wet bulb temp @@ -1088,7 +1093,7 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & integer,intent(in) :: lm,lp1 real(kind=kind_phys),dimension(lm),intent(in) :: t,q,pmid,twet - real(kind=kind_phys),dimension(lp1),intent(in) :: pint,zint + real(kind=kind_phys),dimension(lp1),intent(in) :: pint,zint real(kind=kind_phys),intent(in) :: d608,rog,epsq ! output: ! iwx - instantaneous weather type. @@ -1101,7 +1106,7 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & integer, intent(out) :: iwx ! internal: ! - real(kind=kind_phys), parameter :: d00=0.0 + real(kind=kind_phys), parameter :: d00=0.0 integer karr,licee real(kind=kind_phys) tcold,twarm ! @@ -1111,12 +1116,12 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! subroutines called: ! wetbulb -! +! ! ! initialize weather type array to zero (ie, off). ! we do this since we want iwx to represent the ! instantaneous weather type on return. -! +! ! ! allocate local storage ! @@ -1206,7 +1211,7 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! pintk1 is the pressure at the bottom of the layer ! pintk2 is the pressure at the top of the layer ! -! areap4 is the area of twet above -4 c below highest sat lyr +! areap4 is the area of twet above -4 c below highest sat lyr ! areap0 is the area of twet above 0 c below highest sat lyr ! areas8 = d00 @@ -1214,7 +1219,7 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & areap0 = d00 surfw = d00 surfc = d00 - + ! do l=lmhk,lice,-1 dzkl = zint(l)-zint(l+1) @@ -1301,15 +1306,15 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & return end ! -!> This subroutine takes the precipitation type solutions from +!> This subroutine takes the precipitation type solutions from !! different algorithms and sums them up to give a dominant type. !! !>\section gen_calwxt_dominant GFS calwxt_dominant General Algorithm subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & & domr,domzr,domip,doms) ! -! written: 24 august 2005, g manikin -! +! written: 24 august 2005, g manikin +! ! this routine takes the precip type solutions from different ! algorithms and sums them up to give a dominant type ! @@ -1354,13 +1359,13 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & if (totsn >= totr) then doms = 1 else - domr = 1 + domr = 1 endif elseif (totzr >= totr) then domzr = 1 else domr = 1 - endif + endif else if (totip > totzr) then if (totip >= totr) then domip = 1 diff --git a/physics/MP/multi_gases.F90 b/physics/MP/multi_gases.F90 index 4f7c53aa4..f71a096f2 100644 --- a/physics/MP/multi_gases.F90 +++ b/physics/MP/multi_gases.F90 @@ -1,21 +1,21 @@ !*********************************************************************** -!* GNU Lesser General Public License +!* GNU Lesser General Public License !* !* This file is part of the FV3 dynamical core. !* -!* The FV3 dynamical core is free software: you can redistribute it +!* The FV3 dynamical core is free software: you can redistribute it !* and/or modify it under the terms of the !* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or +!* Free Software Foundation, either version 3 of the License, or !* (at your option) any later version. !* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !* See the GNU General Public License for more details. !* !* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. +!* License along with the FV3 dynamical core. !* If not, see . !*********************************************************************** @@ -36,10 +36,6 @@ module ccpp_multi_gases_mod ! ! use machine, only: kind_dyn - ! DH* TODO - MAKE THIS INPUT ARGUMENTS - use physcons, only : rdgas => con_rd_dyn, & - cp_air => con_cp_dyn - ! *DH implicit none integer num_gas @@ -65,7 +61,9 @@ module ccpp_multi_gases_mod CONTAINS ! -------------------------------------------------------- - subroutine multi_gases_init(ngas, nwat, ri, cpi, is_master) + subroutine multi_gases_init(ngas, nwat, ri, cpi, is_master, rdgas, cp_air) + + !-------------------------------------------- ! !OUTPUT PARAMETERS ! Ouput: vir(i): ri/rdgas - r0/rdgas @@ -80,6 +78,8 @@ subroutine multi_gases_init(ngas, nwat, ri, cpi, is_master) real(kind=kind_dyn), intent(in):: ri(0:ngas) real(kind=kind_dyn), intent(in):: cpi(0:ngas) logical, intent(in):: is_master + real(kind=kind_dyn), intent(in) :: rdgas + real(kind=kind_dyn), intent(in) :: cp_air ! Local: integer n real cvi(0:ngas) diff --git a/physics/PBL/HEDMF/hedmf.f b/physics/PBL/HEDMF/hedmf.f index b75526ba6..65ef618a0 100644 --- a/physics/PBL/HEDMF/hedmf.f +++ b/physics/PBL/HEDMF/hedmf.f @@ -77,15 +77,15 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & & coef_ric_l,coef_ric_s,ldiag3d,ntqv,rtg_ozone_index,ntoz, & & dtend,dtidx,index_of_process_pbl,index_of_x_wind, & & index_of_y_wind,index_of_temperature, & - & flag_for_pbl_generic_tend,errmsg,errflg) + & flag_for_pbl_generic_tend, & + & con_g, con_cp, con_hvap, con_fvirt, & + & errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs !GJF: Note that sending these constants through the argument list !results in regression test failures with "PROD" mode compilation !flags (specifically, grav and cp) - use physcons, grav => con_g, cp => con_cp, - & hvap => con_hvap, fv => con_fvirt implicit none ! @@ -134,6 +134,8 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & ! logical, intent(in) :: dspheat ! flag for tke dissipative heating + real(kind=kind_phys), intent(in) :: con_g, con_cp + real(kind=kind_phys), intent(in) :: con_hvap, con_fvirt character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -210,18 +212,17 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & real :: ttend_fac integer :: idtend1, idtend2 - + !! for hurricane application real(kind=kind_phys) wspm(im,km-1) integer kLOC ! RGF real :: xDKU ! RGF + real(kind=kind_phys) :: grav, cp, hvap, fv + integer, parameter :: useshape=2!0-- no change, original ALPHA adjustment,1-- shape1, 2-- shape2(adjust above sfc) real :: smax,ashape,sz2h, sksfc,skmax,ashape1,skminusk0, hmax cc - parameter(gravi=1.0/grav) - parameter(gocp=grav/cp) - parameter(cont=cp/grav,conq=hvap/grav,conw=1.0/grav) ! for del in pa ! parameter(cont=1000.*cp/grav,conq=1000.*hvap/grav,conw=1000./grav) ! for del in kpa parameter(rlam=30.0,vk=0.4,vk2=vk*vk) parameter(prmin=0.25,prmax=4.,zolcr=0.2,zolcru=-0.5) @@ -270,6 +271,17 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & errmsg = '' errflg = 0 + grav = con_g + cp = con_cp + hvap = con_hvap + fv = con_fvirt + + gravi=1.0/grav + gocp=grav/cp + cont=cp/grav + conq=hvap/grav + conw=1.0/grav + ! compute preliminary variables ! ! iprt = 0 @@ -866,12 +878,12 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & zfac=max(zfac,zfmin) ashape=max(ABS(moninq_fac),0.2) ! should not be smaller than 0.2, otherwise too much adjustment(?) - if (useshape == 1) then + if (useshape == 1) then ashape=(1.0 - ((sz2h*zfac/smax)**0.25) *(1.0 - ashape)) tem = zi(i,k+1) * (zfac) * ashape elseif (useshape == 2) then !only adjus K that is > K_surface_top ashape1=1.0 - if (skmax > sksfc) then + if (skmax > sksfc) then ashape1=(skmax*ashape-sksfc)/(skmax-sksfc) endif skminusk0 = zi(i,k+1)*zfac - hpbl(i)*sksfc @@ -917,7 +929,7 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & ! (2) alpha test ! if alpha < 0, find alpha for each column and do the loop again ! if alpha > 0, we are finished - + !GJF: redundant check for moninq_fac < 0? if (moninq_fac .lt. 0.) then ! variable alpha test ! k-level of layer around 500 m @@ -938,7 +950,7 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & wspm(i,3) = wspm(i,1)/xDKU ! ratio of cap to Km at k-level, store in WSPM(i,3) !WSPM(i,4) = amin1(WSPM(I,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed wspm(i,4) = min(wspm(i,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed - !! recalculate K capped by WSPM(i,1) + !! recalculate K capped by WSPM(i,1) do k = 1, kmpbl if(k < kpbl(i)) then ! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ @@ -957,16 +969,16 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & skmax=hmax*(1.0-hmax)**pfac sksfc=min(zi(i,2)/hpbl(i),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) sksfc=sksfc*(1-sksfc)**pfac - + zfac=max(zfac,zfmin) ashape=max(wspm(i,4),0.2) !! adjustment coef should not smaller than 0.2 - if(useshape ==1) then + if(useshape ==1) then ashape=(1.0 - ((sz2h*zfac/smax)**0.25)* & (1.0 - ashape)) tem = zi(i,k+1) * (zfac) * ashape elseif (useshape == 2) then !only adjus K that is > K_surface_top ashape1=1.0 - if (skmax > sksfc) then + if (skmax > sksfc) then ashape1=(skmax*ashape-sksfc)/(skmax-sksfc) endif skminusk0=zi(i,k+1)*zfac - hpbl(i)*sksfc @@ -1108,7 +1120,7 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & !> For details of the mfpbl subroutine, step into its documentation ::mfpbl call mfpbl(im,im,km,ntrac,dt2,pcnvflg, & zl,zi,thvx,q1,t1,u1,v1,hpbl,kpbl, - & sflux,ustar,wstar,xmf,tcko,qcko,ucko,vcko) + & sflux,ustar,wstar,xmf,tcko,qcko,ucko,vcko,con_g,con_cp) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! compute diffusion coefficients for cloud-top driven diffusion @@ -1374,7 +1386,7 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & else ttend_fac = 0.5 endif - + do i = 1,im tem = govrth(i)*sflux(i) tem1 = tem + stress(i)*spd1(i)/zl(i,1) diff --git a/physics/PBL/HEDMF/hedmf.meta b/physics/PBL/HEDMF/hedmf.meta index 3d9b492c0..cf1e9ba0e 100644 --- a/physics/PBL/HEDMF/hedmf.meta +++ b/physics/PBL/HEDMF/hedmf.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = hedmf type = scheme - dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90,../mfpbl.f,../tridi.f + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../mfpbl.f,../tridi.f ######################################################################## [ccpp-arg-table] @@ -574,6 +574,38 @@ dimensions = () type = logical intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/PBL/SATMEDMF/mfscu.f b/physics/PBL/SATMEDMF/mfscu.f index a9faa735e..eb36bf271 100644 --- a/physics/PBL/SATMEDMF/mfscu.f +++ b/physics/PBL/SATMEDMF/mfscu.f @@ -14,14 +14,11 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix, & & thlx,thvx,thlvx,gdx,thetae,radj, & & krad,mrad,radmin,buo,xmfd, & - & tcdo,qcdo,ucdo,vcdo,xlamde) + & tcdo,qcdo,ucdo,vcdo,xlamde, & + & con_g,con_cp,con_rv,con_hvap,con_fvirt,con_eps,con_epsm1) ! use machine , only : kind_phys use funcphys , only : fpvs - use physcons, grav => con_g, cp => con_cp & - &, rv => con_rv, hvap => con_hvap & - &, fv => con_fvirt & - &, eps => con_eps, epsm1 => con_epsm1 ! implicit none ! @@ -43,6 +40,8 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & & tcdo(im,km), qcdo(im,km,ntrac1), & & ucdo(im,km), vcdo(im,km), & & xlamde(im,km-1) + real(kind=kind_phys), intent(in) :: con_g,con_cp,con_rv,con_hvap + real(kind=kind_phys), intent(in) :: con_fvirt,con_eps,con_epsm1 ! ! local variables and arrays ! @@ -76,9 +75,6 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & real(kind=kind_phys) actei, cldtime ! c physical parameters - parameter(g=grav) - parameter(gocp=g/cp) - parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) parameter(ce0=0.4,cm=1.0,pgcon=0.55) parameter(qmin=1.e-8,qlmin=1.e-12) parameter(b1=0.45,f1=0.15) @@ -90,6 +86,18 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & ! !************************************************************************ !! + grav = con_g + cp = con_cp + rv = con_rv + hvap = con_hvap + fv = con_fvirt + eps = con_eps + epsm1 = con_epsm1 + g=grav + gocp=g/cp + elocp=hvap/cp + el2orc=hvap*hvap/(rv*cp) + totflg = .true. do i=1,im totflg = totflg .and. (.not. cnvflg(i)) @@ -164,7 +172,7 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & enddo ! !> - First-guess level of downdraft extension (mrad) -! +! do i = 1, im flg(i) = cnvflg(i) mrad(i) = krad(i) @@ -225,7 +233,7 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & dz = zl(i,k+1) - zl(i,k) tem = 0.5 * xlamde(i,k) * dz factor = 1. + tem -! +! thld(i,k) = ((1.-tem)*thld(i,k+1)+tem* & (thlx(i,k)+thlx(i,k+1)))/factor qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem* @@ -407,7 +415,7 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & endif enddo ! -!> - Compute scale-aware function based on +!> - Compute scale-aware function based on !! Arakawa and Wu (2013) \cite arakawa_and_wu_2013 ! do i = 1, im @@ -458,7 +466,7 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & ! do k = kmscu,1,-1 do i=1,im - if(cnvflg(i) .and. + if(cnvflg(i) .and. & (k >= mrad(i) .and. k < krad(i))) then dz = zl(i,k+1) - zl(i,k) tem = 0.5 * xlamde(i,k) * dz @@ -520,7 +528,7 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & dz = zl(i,k+1) - zl(i,k) tem = 0.5 * xlamde(i,k) * dz factor = 1. + tem -! +! qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* & (q1(i,k,n)+q1(i,k+1,n)))/factor endif @@ -543,7 +551,7 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & dz = zl(i,k+1) - zl(i,k) tem = 0.5 * xlamde(i,k) * dz factor = 1. + tem -! +! qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* & (q1(i,k,n)+q1(i,k+1,n)))/factor endif diff --git a/physics/PBL/SATMEDMF/mfscuq.f b/physics/PBL/SATMEDMF/mfscuq.f index a934cf5e9..c1e5afa0f 100644 --- a/physics/PBL/SATMEDMF/mfscuq.f +++ b/physics/PBL/SATMEDMF/mfscuq.f @@ -15,14 +15,12 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix, & thlx,thvx,thlvx,gdx,thetae, & krad,mrad,radmin,buo,wush,tkemean,vez0fun,xmfd, - & tcdo,qcdo,ucdo,vcdo,xlamdeq,a1) + & tcdo,qcdo,ucdo,vcdo,xlamdeq,a1, +! the following are constants being passed in + & con_g, con_cp, con_rv, con_hvap, con_fvirt, con_eps, con_epsm1) ! use machine , only : kind_phys use funcphys , only : fpvs - use physcons, grav => con_g, cp => con_cp - &, rv => con_rv, hvap => con_hvap - &, fv => con_fvirt - &, eps => con_eps, epsm1 => con_epsm1 ! implicit none ! @@ -45,6 +43,9 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, & tcdo(im,km),qcdo(im,km,ntrac1), & ucdo(im,km),vcdo(im,km), & xlamdeq(im,km-1) + real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rv + real(kind=kind_phys), intent(in) :: con_hvap, con_fvirt + real(kind=kind_phys), intent(in) :: con_eps, con_epsm1 ! ! local variables and arrays ! @@ -79,11 +80,10 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, logical totflg, flg(im) ! real(kind=kind_phys) actei, cldtime + real(kind=kind_phys) :: grav, cp, rv, hvap, fv, eps, epsm1 + ! c physical parameters - parameter(g=grav) - parameter(gocp=g/cp) - parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) parameter(ce0=0.4,cm=1.0,cq=1.0,pgcon=0.55) parameter(tkcrt=2.,cmxfac=5.) parameter(qmin=1.e-8,qlmin=1.e-12) @@ -95,6 +95,21 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, ! !************************************************************************ !! +! variable initialization + grav = con_g + rv = con_rv + hvap = con_hvap + fv = con_fvirt + eps = con_eps + epsm1 = con_epsm1 + g = grav + cp = con_cp + gocp = g/cp + elocp = hvap/cp + el2orc = hvap*hvap/(rv*cp) + + + totflg = .true. do i=1,im totflg = totflg .and. (.not. cnvflg(i)) @@ -159,7 +174,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, enddo ! !> - First-guess level of downdraft extension (mrad) -! +! do i = 1, im flg(i) = cnvflg(i) mrad(i) = krad(i) @@ -244,7 +259,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, dz = zl(i,k+1) - zl(i,k) tem = 0.5 * xlamde(i,k) * dz factor = 1. + tem -! +! thld(i,k) = ((1.-tem)*thld(i,k+1)+tem* & (thlx(i,k)+thlx(i,k+1)))/factor ! @@ -427,7 +442,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, endif enddo ! -!> - Compute scale-aware function based on +!> - Compute scale-aware function based on !! Arakawa and Wu (2013) \cite arakawa_and_wu_2013 ! do i = 1, im @@ -481,7 +496,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, ! do k = kmscu,1,-1 do i=1,im - if(cnvflg(i) .and. + if(cnvflg(i) .and. & (k >= mrad(i) .and. k < krad(i))) then dz = zl(i,k+1) - zl(i,k) tem = 0.5 * xlamde(i,k) * dz @@ -546,7 +561,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, dz = zl(i,k+1) - zl(i,k) tem = 0.5 * xlamdeq(i,k) * dz factor = 1. + tem -! +! qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* & (q1(i,k,n)+q1(i,k+1,n)))/factor endif @@ -569,7 +584,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, dz = zl(i,k+1) - zl(i,k) tem = 0.5 * xlamdeq(i,k) * dz factor = 1. + tem -! +! qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* & (q1(i,k,n)+q1(i,k+1,n)))/factor endif diff --git a/physics/PBL/SATMEDMF/satmedmfvdifq.F b/physics/PBL/SATMEDMF/satmedmfvdifq.F index 5ebb947ac..5cc8c46fd 100644 --- a/physics/PBL/SATMEDMF/satmedmfvdifq.F +++ b/physics/PBL/SATMEDMF/satmedmfvdifq.F @@ -79,9 +79,9 @@ end subroutine satmedmfvdifq_init !! satmedmfvdifq_run() computes subgrid vertical turbulence mixing !! using the scale-aware TKE-based moist eddy-diffusion mass-flux (EDMF) parameterization of !! Han and Bretherton (2019) \cite Han_2019 . -!! -# The local turbulent mixing is represented by an eddy-diffusivity scheme which +!! -# The local turbulent mixing is represented by an eddy-diffusivity scheme which !! is a function of a prognostic TKE. -!! -# For the convective boundary layer, nonlocal transport by large eddies +!! -# For the convective boundary layer, nonlocal transport by large eddies !! (mfpbltq.f), is represented using a mass flux approach (Siebesma et al.(2007) \cite Siebesma_2007 ). !! -# A mass-flux approach is also used to represent the stratocumulus-top-induced turbulence !! (mfscuq.f). @@ -773,10 +773,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & flg(i) = .false. rbup(i) = rbsoil(i) enddo -!> - Given the thermal's properties and the critical Richardson number, -!! a loop is executed to find the first level above the surface (kpblx) where +!> - Given the thermal's properties and the critical Richardson number, +!! a loop is executed to find the first level above the surface (kpblx) where !! the modified Richardson number is greater than the critical Richardson -!! number, using equation 10a from Troen and Mahrt (1996) \cite troen_and_mahrt_1986 +!! number, using equation 10a from Troen and Mahrt (1996) \cite troen_and_mahrt_1986 !! (also equation 8 from Hong and Pan (1996) \cite hong_and_pan_1996): do k = 1, kmpbl do i = 1, im @@ -942,7 +942,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !! \f[ !! \zeta = Ri_{sfc}\frac{F_m^2}{F_h} = \frac{z}{L} !! \f] -!! where \f$F_m\f$ and \f$F_h\f$ are surface Monin-Obukhov stability functions calculated in sfc_diff.f and +!! where \f$F_m\f$ and \f$F_h\f$ are surface Monin-Obukhov stability functions calculated in sfc_diff.f and !! \f$L\f$ is the Obukhov length. do i=1,im zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) @@ -987,7 +987,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !! w_s=(u_*^3+7\alpha\kappa w_*^3)^{1/3} !! \f] !! where \f$u_*\f$ (ustar) is the surface friction velocity,\f$\alpha\f$ is the ratio -!! of the surface layer height to the PBL height (specified as sfcfrac =0.1), +!! of the surface layer height to the PBL height (specified as sfcfrac =0.1), !! \f$\kappa =0.4\f$ is the von Karman constant, and \f$w_*\f$ is the convective velocity !! scale defined as eqn23 of Han et al.(2019): !! \f[ @@ -1144,7 +1144,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !> ## Determine whether stratocumulus layers exist and compute quantities !! - Starting at the PBL top and going downward, if the level is less than 2.5 km !! and \f$q_l\geq q_{lcr}\f$ then set kcld = k (find the cloud top index in the PBL. -!! If no cloud water above the threshold is hound, \e scuflg is set to F. +!! If no cloud water above the threshold is hound, \e scuflg is set to F. do i=1,im flg(i) = scuflg(i) enddo @@ -1174,7 +1174,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo !> - Starting at the PBL top and going downward, if the level is less !! than the cloud top, find the level of the minimum radiative heating -!! rate wihin the cloud. If the level of the minimum is the lowest model +!! rate wihin the cloud. If the level of the minimum is the lowest model !! level or the minimum radiative heating rate is positive, then set !! scuflg to F. do i = 1, im @@ -1235,14 +1235,16 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & call mfpbltq(im,im,km,kmpbl,ntcw,ntrac1,dt2, & pcnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, & gdx,hpbl,kpbl,vpert,buou,wush,tkemean,vez0fun,xmf, - & tcko,qcko,ucko,vcko,xlamue,bl_upfr) + & tcko,qcko,ucko,vcko,xlamue,bl_upfr, + & grav,cp,rv,hvap,fv,eps,epsm1) !> - Call mfscuq(), which is a new mass-flux parameterization for !! stratocumulus-top-induced turbulence mixing. For details of the mfscuq subroutine, step into its documentation ::mfscuq call mfscuq(im,im,km,kmscu,ntcw,ntrac1,dt2, & scuflg,zl,zm,q1,t1,u1,v1,plyr,pix, & thlx,thvx,thlvx,gdx,thetae, & krad,mrad,radmin,buod,wush,tkemean,vez0fun,xmfd, - & tcdo,qcdo,ucdo,vcdo,xlamde,bl_dnfr) + & tcdo,qcdo,ucdo,vcdo,xlamde,bl_dnfr, + & grav,cp,rv,hvap,fv,eps,epsm1) if (tc_pbl == 1) then !> - unify mass fluxes with Cu diff --git a/physics/PBL/mfpbl.f b/physics/PBL/mfpbl.f index c9629ac2b..e2317b0e1 100644 --- a/physics/PBL/mfpbl.f +++ b/physics/PBL/mfpbl.f @@ -47,10 +47,9 @@ module mfpbl_mod !! @{ subroutine mfpbl(im,ix,km,ntrac,delt,cnvflg, & & zl,zm,thvx,q1,t1,u1,v1,hpbl,kpbl, & - & sflx,ustar,wstar,xmf,tcko,qcko,ucko,vcko) + & sflx,ustar,wstar,xmf,tcko,qcko,ucko,vcko,con_g,con_cp) ! use machine , only : kind_phys - use physcons, grav => con_g, cp => con_cp ! implicit none ! @@ -67,6 +66,8 @@ subroutine mfpbl(im,ix,km,ntrac,delt,cnvflg, & & wstar(im), xmf(im,km), & & tcko(im,km),qcko(im,km,ntrac), & & ucko(im,km),vcko(im,km) + real(kind=kind_phys), intent(in) :: con_g + real(kind=kind_phys), intent(in) :: con_cp ! c local variables and arrays ! @@ -91,14 +92,25 @@ subroutine mfpbl(im,ix,km,ntrac,delt,cnvflg, & & buo(im,km) ! logical totflg, flg(im) + real(kind=kind_phys) :: grav + real(kind=kind_phys) :: cp ! + grav = con_g + cp = con_cp c physical parameters - parameter(g=grav) - parameter(gocp=g/cp) + g=grav + gocp=g/cp ! parameter(ce0=0.37,qmin=1.e-8,alp=1.0,pgcon=0.55) - parameter(ce0=0.38,qmin=1.e-8,alp=1.0,pgcon=0.55) - parameter(a1=0.08,b1=0.5,f1=0.15,c1=0.3,d1=2.58,tau=500.) - parameter(zfmin=1.e-8,h1=0.33333333) + ce0=0.38 + qmin=1.e-8 + alp=1.0 + pgcon=0.55 + a1=0.08 + b1=0.5 + f1=0.15 +c 1=0.3,d1=2.58,tau=500. + zfmin=1.e-8 + h1=0.33333333 ! c----------------------------------------------------------------------- ! diff --git a/physics/PBL/mfpblt.f b/physics/PBL/mfpblt.f index 52179b35a..643c3d955 100644 --- a/physics/PBL/mfpblt.f +++ b/physics/PBL/mfpblt.f @@ -1,29 +1,26 @@ !>\file mfpblt.f !! This file contains the subroutine that calculates mass flux and -!! updraft parcel properties for thermals driven by surface heating +!! updraft parcel properties for thermals driven by surface heating !! for use in the TKE-EDMF PBL scheme. !> This module contains the subroutine that calculates mass flux and -!! updraft parcel properties for thermals driven by surface heating +!! updraft parcel properties for thermals driven by surface heating !! for use in the TKE-EDMF PBL scheme. module mfpblt_mod contains !> This subroutine computes mass flux and updraft parcel properties for -!! thermals driven by surface heating. -!!\section mfpblt_gen GFS mfpblt General Algorithm +!! thermals driven by surface heating. +!!\section mfpblt_gen GFS mfpblt General Algorithm !> @{ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, & & gdx,hpbl,kpbl,vpert,buo,xmf, & - & tcko,qcko,ucko,vcko,xlamue) + & tcko,qcko,ucko,vcko,xlamue, & + & con_g,con_cp,con_rv,con_hvap,con_fvirt,con_eps,con_epsm1) ! use machine , only : kind_phys use funcphys , only : fpvs - use physcons, grav => con_g, cp => con_cp & - &, rv => con_rv, hvap => con_hvap & - &, fv => con_fvirt & - &, eps => con_eps, epsm1 => con_epsm1 ! implicit none ! @@ -64,6 +61,9 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & real(kind=kind_phys) rbdn(im), rbup(im), hpblx(im), & xlamuem(im,km-1) ! + real(kind=kind_phys), intent(in) :: con_g,con_cp,con_rv,con_hvap + real(kind=kind_phys), intent(in) :: con_fvirt,con_eps,con_epsm1 + real(kind=kind_phys) wu2(im,km), thlu(im,km), & qtx(im,km), qtu(im,km) ! @@ -73,9 +73,6 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & logical totflg, flg(im) ! ! physical parameters - parameter(g=grav) - parameter(gocp=g/cp) - parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) parameter(ce0=0.4,cm=1.0) parameter(qmin=1.e-8,qlmin=1.e-12) parameter(alp=1.0,pgcon=0.55) @@ -83,6 +80,18 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & ! !************************************************************************ !! + grav = con_g + cp = con_cp + rv = con_rv + hvap = con_hvap + fv = con_fvirt + eps = con_eps + epsm1 = con_epsm1 + g=grav + gocp=g/cp + elocp=hvap/cp + el2orc=hvap*hvap/(rv*cp) + totflg = .true. do i=1,im totflg = totflg .and. (.not. cnvflg(i)) @@ -124,7 +133,7 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & tem = max((hpbl(i)-zm(i,k)+dz) ,dz) ptem1 = 1./tem xlamue(i,k) = ce0 * (ptem+ptem1) - else + else xlamue(i,k) = ce0 / dz endif xlamuem(i,k) = cm * xlamue(i,k) @@ -168,7 +177,7 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & enddo enddo ! -!> - Compute updraft velocity square(wu2, eqn 13 in +!> - Compute updraft velocity square(wu2, eqn 13 in !! Han et al.(2019) \cite Han_2019) ! ! tem = 1.-2.*f1 @@ -241,7 +250,7 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & hpblx(i) = zm(i,k-1) + rbint*(zm(i,k)-zm(i,k-1)) endif enddo -! +! do i = 1,im if(cnvflg(i)) then if(kpbl(i) > kpblx(i)) then @@ -262,7 +271,7 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & tem = max((hpbl(i)-zm(i,k)+dz) ,dz) ptem1 = 1./tem xlamue(i,k) = ce0 * (ptem+ptem1) - else + else xlamue(i,k) = ce0 / dz endif xlamuem(i,k) = cm * xlamue(i,k) @@ -320,7 +329,7 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & endif enddo ! -!> - Compute scale-aware function based on +!> - Compute scale-aware function based on !! Arakawa and Wu (2013) \cite arakawa_and_wu_2013 ! do i = 1, im @@ -423,7 +432,7 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & dz = zl(i,k) - zl(i,k-1) tem = 0.5 * xlamue(i,k-1) * dz factor = 1. + tem -! +! qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* & (q1(i,k,n)+q1(i,k-1,n)))/factor endif @@ -444,7 +453,7 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & dz = zl(i,k) - zl(i,k-1) tem = 0.5 * xlamue(i,k-1) * dz factor = 1. + tem -! +! qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* & (q1(i,k,n)+q1(i,k-1,n)))/factor endif diff --git a/physics/PBL/mfpbltq.f b/physics/PBL/mfpbltq.f index 8bf687757..47697b7f8 100644 --- a/physics/PBL/mfpbltq.f +++ b/physics/PBL/mfpbltq.f @@ -1,29 +1,27 @@ !>\file mfpbltq.f -!! This file contains the subroutine that computes mass flux and +!! This file contains the subroutine that computes mass flux and !! updraft parcel properties for !! thermals driven by surface heating !> This module contains the subroutine that calculates mass flux and -!! updraft parcel properties for thermals driven by surface heating +!! updraft parcel properties for thermals driven by surface heating !! for use in the TKE-EDMF PBL scheme (updated version). module mfpbltq_mod contains !>\ingroup module_satmedmfvdifq !! This subroutine computes mass flux and updraft parcel properties for -!! thermals driven by surface heating. -!!\section mfpbltq_gen GFS mfpblt General Algorithm +!! thermals driven by surface heating. +!!\section mfpbltq_gen GFS mfpblt General Algorithm !> @{ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, & gdx,hpbl,kpbl,vpert,buo,wush,tkemean,vez0fun,xmf, - & tcko,qcko,ucko,vcko,xlamueq,a1) + & tcko,qcko,ucko,vcko,xlamueq,a1, +! The following are constants being passed in by argument + & con_g,con_cp,con_rv,con_hvap,con_fvirt,con_eps,con_epsm1) ! use machine , only : kind_phys use funcphys , only : fpvs - use physcons, grav => con_g, cp => con_cp - &, rv => con_rv, hvap => con_hvap - &, fv => con_fvirt - &, eps => con_eps, epsm1 => con_epsm1 ! implicit none ! @@ -37,11 +35,13 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & plyr(im,km),pix(im,km),thlx(im,km), & thvx(im,km),zl(im,km), zm(im,km), & gdx(im), hpbl(im), vpert(im), - & buo(im,km), wush(im,km), + & buo(im,km), wush(im,km), & tkemean(im),vez0fun(im),xmf(im,km), & tcko(im,km),qcko(im,km,ntrac1), & ucko(im,km),vcko(im,km), & xlamueq(im,km-1) + real(kind=kind_phys), intent(in) :: con_g,con_cp,con_rv,con_hvap + real(kind=kind_phys), intent(in) :: con_fvirt,con_eps,con_epsm1 ! c local variables and arrays ! @@ -72,12 +72,10 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, real(kind=kind_phys) xlamavg(im), sigma(im), & scaldfunc(im), sumx(im) ! + real(kind=kind_phys) :: grav, cp, rv, hvap, fv, eps, epsm1 logical totflg, flg(im) ! ! physical parameters - parameter(g=grav) - parameter(gocp=g/cp) - parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) parameter(ce0=0.4,cm=1.0,cq=1.0,tkcrt=2.,cmxfac=5.) parameter(qmin=1.e-8,qlmin=1.e-12) parameter(alp=1.5,vpertmax=3.0,pgcon=0.55) @@ -85,6 +83,18 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! !************************************************************************ !! + grav = con_g + cp = con_cp + rv = con_rv + hvap = con_hvap + fv = con_fvirt + eps = con_eps + epsm1 = con_epsm1 + g=grav + gocp=g/cp + elocp=hvap/cp + el2orc=hvap*hvap/(rv*cp) + totflg = .true. do i=1,im totflg = totflg .and. (.not. cnvflg(i)) @@ -117,11 +127,11 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, enddo ! !> - Compute entrainment rate -! +! ! if tkemean>tkcrt, ce0t=sqrt(tkemean/tkcrt)*ce0 ! do i=1,im - if(cnvflg(i)) then + if(cnvflg(i)) then ce0t(i) = ce0 * vez0fun(i) if(tkemean(i) > tkcrt) then tem = sqrt(tkemean(i)/tkcrt) @@ -198,7 +208,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, enddo enddo ! -!> - Compute updraft velocity square(wu2, eqn 13 in +!> - Compute updraft velocity square(wu2, eqn 13 in !! Han et al.(2019) \cite Han_2019) ! ! tem = 1.-2.*f1 @@ -284,7 +294,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, if(kpbl(i) <= 1) cnvflg(i)=.false. endif enddo -! +! !> - Update entrainment rate ! do i=1,im @@ -305,7 +315,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, tem = max((hpbl(i)-zm(i,k)+delz(i)) ,delz(i)) ptem1 = 1./tem xlamue(i,k) = ce0t(i) * (ptem+ptem1) - else + else xlamue(i,k) = xlamax(i) endif ! @@ -359,7 +369,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, endif enddo ! -!> - Compute scale-aware function based on +!> - Compute scale-aware function based on !! Arakawa and Wu (2013) \cite arakawa_and_wu_2013 ! do i = 1, im @@ -468,7 +478,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, dz = zl(i,k) - zl(i,k-1) tem = 0.5 * xlamueq(i,k-1) * dz factor = 1. + tem -! +! qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* & (q1(i,k,n)+q1(i,k-1,n)))/factor endif @@ -489,7 +499,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, dz = zl(i,k) - zl(i,k-1) tem = 0.5 * xlamueq(i,k-1) * dz factor = 1. + tem -! +! qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* & (q1(i,k,n)+q1(i,k-1,n)))/factor endif diff --git a/physics/Radiation/RRTMG/module_bfmicrophysics.f b/physics/Radiation/RRTMG/module_bfmicrophysics.f index 6285653d2..4690020db 100644 --- a/physics/Radiation/RRTMG/module_bfmicrophysics.f +++ b/physics/Radiation/RRTMG/module_bfmicrophysics.f @@ -1,4 +1,4 @@ -!>\file module_bfmicrophysics.f +!>\file module_bfmicrophysics.f !!This file contains some subroutines used in microphysics. !> This module contains some subroutines used in microphysics. @@ -6,10 +6,6 @@ MODULE module_microphysics ! USE MACHINE , ONLY : kind_phys USE FUNCPHYS - USE PHYSCONS, CP => con_CP, RD => con_RD, RV => con_RV & - &, T0C => con_T0C, HVAP => con_HVAP, HFUS => con_HFUS & - &, EPS => con_EPS, EPSM1 => con_EPSM1 & - &, EPS1 => con_FVirt, pi => con_pi, grav => con_g implicit none ! !--- Common block of constants used in column microphysics @@ -116,7 +112,7 @@ MODULE module_microphysics CONTAINS ! !> This subroutine initializes constants & lookup tables for microphysics. - SUBROUTINE GSMCONST (DTPG,mype,first) + SUBROUTINE GSMCONST (DTPG,mype,first, pi, t0c) ! implicit none !------------------------------------------------------------------------------- @@ -156,6 +152,7 @@ SUBROUTINE GSMCONST (DTPG,mype,first) integer mype real dtpg logical first + real, intent(in) :: pi, t0c ! !--- Parameters & data statement for local calculations ! @@ -231,8 +228,8 @@ SUBROUTINE GSMCONST (DTPG,mype,first) ! read(1) my_growth ! Applicable only for DTPH=180 s for offline testing CLOSE (1) else - CALL ICE_LOOKUP ! Lookup tables for ice - CALL RAIN_LOOKUP ! Lookup tables for rain + CALL ICE_LOOKUP(pi) ! Lookup tables for ice + CALL RAIN_LOOKUP(pi) ! Lookup tables for rain if (write_lookup) then open(unit=1,file='micro_lookup.dat',form='unformatted') write(1) ventr1 @@ -391,11 +388,11 @@ SUBROUTINE MY_GROWTH_RATES (DTPH) implicit none ! !--- Below are tabulated values for the predicted mass of ice crystals -! after 600 s of growth in water saturated conditions, based on +! after 600 s of growth in water saturated conditions, based on ! calculations from Miller and Young (JAS, 1979). These values are ! crudely estimated from tabulated curves at 600 s from Fig. 6.9 of -! Young (1993). Values at temperatures colder than -27C were -! assumed to be invariant with temperature. +! Young (1993). Values at temperatures colder than -27C were +! assumed to be invariant with temperature. ! !--- Used to normalize Miller & Young (1979) calculations of ice growth ! over large time steps using their tabulated values at 600 s. @@ -425,7 +422,7 @@ SUBROUTINE MY_GROWTH_RATES (DTPH) END subroutine MY_GROWTH_RATES ! !> This subroutine creates lookup tables for ice processes. - subroutine ice_lookup + subroutine ice_lookup(pi) ! implicit none !----------------------------------------------------------------------------------- @@ -446,7 +443,7 @@ subroutine ice_lookup ! diameter merged with analogous relationships for larger sized aggregates. ! Relationships are derived as functions of mean ice particle sizes assuming ! exponential size spectra and assuming the properties of ice crystals at -! sizes smaller than 1.5 mm and aggregates at larger sizes. +! sizes smaller than 1.5 mm and aggregates at larger sizes. ! !----------------------------------------------------------------------------------- ! @@ -455,8 +452,9 @@ subroutine ice_lookup ! - DmaxI - maximum diameter for integration (2 cm) ! - DdelI - interval for integration (1 micron) ! + real, intent(in) :: pi real, parameter :: DminI=.02e-3, DmaxI=20.e-3, DdelI=1.e-6, & - & XImin=1.e6*DminI, XImax=1.e6*DmaxI + & XImin=1.e6*DminI, XImax=1.e6*DmaxI integer, parameter :: IDImin=XImin, IDImax=XImax ! !---- Meaning of the following arrays: @@ -494,11 +492,11 @@ subroutine ice_lookup ! - VENTI2 - integrated quantity associated w/ ventilation effects ! (with fall speed) for calculating vapor deposition onto ice ! - ACCRI - integrated quantity associated w/ cloud water collection by ice -! - MASSI - integrated quantity associated w/ ice mass +! - MASSI - integrated quantity associated w/ ice mass ! - VSNOWI - mass-weighted fall speed of snow, used to calculate precip rates ! !--- Mean ice-particle diameters varying from 50 microns to 1000 microns (1 mm), -! assuming an exponential size distribution. +! assuming an exponential size distribution. ! real mdiam ! @@ -517,7 +515,7 @@ subroutine ice_lookup real, parameter :: cvent1i=.86, cvent2i=.28 ! !---- These parameters are used for calculating the ventilation factors for larger -! aggregates, where D>=1.5 mm (see Rutledge and Hobbs, JAS, 1983; +! aggregates, where D>=1.5 mm (see Rutledge and Hobbs, JAS, 1983; ! Thorpe and Mason, 1966). ! real, parameter :: cvent1a=.65, cvent2a=.44 @@ -554,7 +552,7 @@ subroutine ice_lookup !--- A value of Nrime=40 for a logarithmic ratio of 1.1 yields a maximum rime factor ! of 1.1**40 = 45.26 that is resolved in these tables. This allows the largest ! ice particles with a mean diameter of MDImax=1000 microns to achieve bulk -! densities of 900 kg/m**3 for rimed ice. +! densities of 900 kg/m**3 for rimed ice. ! ! integer, parameter :: Nrime=40 real m_rime, & @@ -595,14 +593,14 @@ subroutine ice_lookup enddo ! !####################################################################### -! Characteristics as functions of actual ice particle diameter +! Characteristics as functions of actual ice particle diameter !####################################################################### ! -!---- M(D) & V(D) for 3 categories of ice crystals described by Starr -!---- & Cox (1985). +!---- M(D) & V(D) for 3 categories of ice crystals described by Starr +!---- & Cox (1985). ! !---- Capacitance & characteristic lengths for Reynolds Number calculations -!---- are based on Young (1993; p. 144 & p. 150). c-axis & a-axis +!---- are based on Young (1993; p. 144 & p. 150). c-axis & a-axis !---- relationships are from Heymsfield (JAS, 1972; Table 1, p. 1351). ! icount=60 @@ -616,7 +614,7 @@ subroutine ice_lookup & '(m/s), and ventilation factors', & & ' D(mm) CR_mass Mass_bull Mass_col Mass_plat ', & & ' Mass_agg CR_vel V_bul CR_col CR_pla Aggreg', & - & ' Vent1 Vent2 ' + & ' Vent1 Vent2 ' write(7,"(3a)") ' <----------------------------------',& & '--------------- Rime Factor --------------------------', & & '--------------------------->' @@ -649,7 +647,7 @@ subroutine ice_lookup ! !---- Mass-diameter relationships from Heymsfield (1972) & used ! in Starr & Cox (1985), units in mg -!---- "d" is maximum dimension size of crystal in mm, +!---- "d" is maximum dimension size of crystal in mm, ! ! Mass of pure ice for spherical particles, used as an upper limit for the ! mass of small columns (<~ 80 microns) & plates (<~ 35 microns) @@ -682,7 +680,7 @@ subroutine ice_lookup v_column=4.352e-2*dx**.453 v_bullet=2.144e-2*dx**.581 v_plate=3.161e-3*dx**.812 - else + else v_column=3.833e-2*dx**.472 v_bullet=3.948e-2*dx**.489 v_plate=7.109e-3*dx**.691 @@ -742,7 +740,7 @@ subroutine ice_lookup !---- Characteristic length for columns following Young (1993, p. 150, eq. 6.7) cl_column=(wd+2.*d)/(c1+c2*d/wd) ! Characteristic lengths for columns ! -!---- Convert shape factor & characteristic lengths from mm to m for +!---- Convert shape factor & characteristic lengths from mm to m for ! ventilation calculations ! c_bullet=.001*c_bullet @@ -773,10 +771,10 @@ subroutine ice_lookup else ! !---- This block of code calculates bulk characteristics based on average -! characteristics of unrimed aggregates >= 1.5 mm using Locatelli & +! characteristics of unrimed aggregates >= 1.5 mm using Locatelli & ! Hobbs (JGR, 1974, 2185-2197) data. ! -!----- This category is a composite of aggregates of unrimed radiating +!----- This category is a composite of aggregates of unrimed radiating !----- assemblages of dendrites or dendrites; aggregates of unrimed !----- radiating assemblages of plates, side planes, bullets, & columns; !----- aggregates of unrimed side planes (mass in mg, velocity in m/s) @@ -900,7 +898,7 @@ subroutine ice_lookup enddo ! !--- Increased fall velocities functions of mean diameter (j), - ! normalized by ice content, and rime factor (k) + ! normalized by ice content, and rime factor (k) ! do k=1,Nrime ivel_rime(j,k)=rime_vel(k)/MASSI(J) @@ -957,24 +955,25 @@ subroutine ice_lookup end subroutine ice_lookup ! !> This subroutine creates lookup tables for rain processes. - subroutine rain_lookup + subroutine rain_lookup(pi) implicit none ! !--- Parameters & arrays for fall speeds of rain as a function of rain drop ! diameter. These quantities are integrated over exponential size ! distributions of rain drops at 1 micron intervals (DdelR) from minimum ! drop sizes of .05 mm (50 microns, DminR) to maximum drop sizes of 10 mm -! (DmaxR). +! (DmaxR). ! + real, intent(in) :: pi real, parameter :: DminR=.05e-3, DmaxR=10.e-3, DdelR=1.e-6, & & XRmin=1.e6*DminR, XRmax=1.e6*DmaxR integer, parameter :: IDRmin=XRmin, IDRmax=XRmax real diam(IDRmin:IDRmax), vel(IDRmin:IDRmax) ! !--- Parameters rain lookup tables, which establish the range of mean drop -! diameters; from a minimum mean diameter of 0.05 mm (DMRmin) to a +! diameters; from a minimum mean diameter of 0.05 mm (DMRmin) to a ! maximum mean diameter of 0.45 mm (DMRmax). The tables store solutions -! at 1 micron intervals (DelDMR) of mean drop diameter. +! at 1 micron intervals (DelDMR) of mean drop diameter. ! real mdiam, mass ! @@ -1053,7 +1052,7 @@ subroutine rain_lookup !--- Derived based on ventilation, F(D)=0.78+.31*Schmidt**(1/3)*Reynold**.5, ! where Reynold=(V*D*rho/dyn_vis), V is velocity, D is particle diameter, ! rho is air density, & dyn_vis is dynamic viscosity. Only terms - ! containing velocity & diameter are retained in these tables. + ! containing velocity & diameter are retained in these tables. ! VENTR1(J)=.78*pi2*mdiam**2 VENTR2(J)=.31*pi2*VENTR2(J) @@ -1077,7 +1076,7 @@ end subroutine rain_lookup ! (2) Microphysical equations are modified to be less sensitive to time ! steps by use of Clausius-Clapeyron equation to account for changes in ! saturation mixing ratios in response to latent heating/cooling. -! (3) Prevent spurious temperature oscillations across 0C due to +! (3) Prevent spurious temperature oscillations across 0C due to ! microphysics. ! (4) Uses lookup tables for: calculating two different ventilation ! coefficients in condensation and deposition processes; accretion of @@ -1122,7 +1121,9 @@ end subroutine rain_lookup ! SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & & LSFC, P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & - & THICK_col, WC_col, LM, RHC_col, XNCW, FLGmin, PRINT_diag, psfc) + & THICK_col, WC_col, LM, RHC_col, XNCW, FLGmin, PRINT_diag, psfc, & + & con_hvap, con_hfus, con_cp, con_rv, con_t0c, con_rd, con_epsm1, & + & con_fvirt, con_eps) ! implicit none ! @@ -1133,22 +1134,22 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & !----- NOTE: In this version of the Code threading should be done outside! !------------------------------------------------------------------------------- !$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . +! . . . ! SUBPROGRAM: Grid-scale microphysical processes - condensation & precipitation ! PRGRMMR: Ferrier ORG: W/NP22 DATE: 08-2001 ! Updated: Moorthi for GFS application !------------------------------------------------------------------------------- ! ABSTRACT: -! * Merges original GSCOND & PRECPD subroutines. +! * Merges original GSCOND & PRECPD subroutines. ! * Code has been substantially streamlined and restructured. ! * Exchange between water vapor & small cloud condensate is calculated using ! the original Asai (1965, J. Japan) algorithm. See also references to ! Yau and Austin (1979, JAS), Rutledge and Hobbs (1983, JAS), and Tao et al. ! (1989, MWR). This algorithm replaces the Sundqvist et al. (1989, MWR) -! parameterization. +! parameterization. !------------------------------------------------------------------------------- -! -! USAGE: +! +! USAGE: ! * CALL GSMCOLUMN FROM SUBROUTINE GSMDRIVE ! * SUBROUTINE GSMDRIVE CALLED FROM MAIN PROGRAM EBU ! @@ -1166,9 +1167,9 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! T_col - vertical column of model temperature (deg K) ! THICK_col - vertical column of model mass thickness (density*height increment) ! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) -! ! -! OUTPUT ARGUMENT LIST: +! +! OUTPUT ARGUMENT LIST: ! ARAIN - accumulated rainfall at the surface (kg) ! ASNOW - accumulated snowfall at the surface (kg) ! QV_col - vertical column of model water vapor specific humidity (kg/kg) @@ -1178,18 +1179,18 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! QR_col - vertical column of model rain ratio (kg/kg) ! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) ! T_col - vertical column of model temperature (deg K) -! +! ! OUTPUT FILES: ! NONE -! +! ! Subprograms & Functions called: ! * Real Function CONDENSE - cloud water condensation ! * Real Function DEPOSIT - ice deposition (not sublimation) ! ! UNIQUE: NONE -! +! ! LIBRARY: NONE -! +! ! ATTRIBUTES: ! LANGUAGE: FORTRAN 90 ! MACHINE : IBM SP @@ -1202,6 +1203,8 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & REAL ARAING, ASNOWG, P_col(LM), QI_col(LM), QR_col(LM), QV_col(LM)& &, QW_col(LM), RimeF_col(LM), T_col(LM), THICK_col(LM), & & WC_col(LM), RHC_col(LM), XNCW(LM), ARAIN, ASNOW, dtpg, psfc + real, intent(in) :: con_hvap, con_hfus, con_cp, con_rv, con_t0c + real, intent(in) :: con_rd, con_epsm1, con_fvirt, con_eps real flgmin ! INTEGER I_index, J_index, LSFC @@ -1210,16 +1213,16 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & !------------------------------------------------------------------------- ! !--- Mean ice-particle diameters varying from 50 microns to 1000 microns -! (1 mm), assuming an exponential size distribution. +! (1 mm), assuming an exponential size distribution. ! -!---- Meaning of the following arrays: +!---- Meaning of the following arrays: ! - mdiam - mean diameter (m) ! - VENTI1 - integrated quantity associated w/ ventilation effects ! (capacitance only) for calculating vapor deposition onto ice ! - VENTI2 - integrated quantity associated w/ ventilation effects ! (with fall speed) for calculating vapor deposition onto ice ! - ACCRI - integrated quantity associated w/ cloud water collection by ice -! - MASSI - integrated quantity associated w/ ice mass +! - MASSI - integrated quantity associated w/ ice mass ! - VSNOWI - mass-weighted fall speed of snow (large ice), used to calculate ! precipitation rates ! @@ -1237,14 +1240,15 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! * Set EPSQ to the universal value of 1.e-12 throughout the code ! condensate. The value of EPSQ will need to be changed in the other ! subroutines in order to make it consistent throughout the Eta code. -! * Set CLIMIT=10.*EPSQ as the lower limit for the total mass of +! * Set CLIMIT=10.*EPSQ as the lower limit for the total mass of ! condensate in the current layer and the input flux of condensate ! from above (TOT_ICE, TOT_ICEnew, TOT_RAIN, and TOT_RAINnew). ! !-- NLImax - maximum number concentration of large ice crystals (20,000 /m**3, 20 per liter) !-- NLImin - minimum number concentration of large ice crystals (100 /m**3, 0.1 per liter) ! - REAL, PARAMETER :: RHOL=1000., XLS=HVAP+HFUS & + REAL :: XLS, CLIMIT, RCP, RCPRV, RRHOLD, XLS1, XLS2, XLS3 + REAL, PARAMETER :: RHOL=1000., & ! &, T_ICE=-10. !- Ver1 ! &, T_ICE_init=-5. !- Ver1 @@ -1253,10 +1257,6 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! &, T_ICE_init=-15., !- Ver2 ! ! & CLIMIT=10.*EPSQ, EPS1=RV/RD-1., RCP=1./CP, - - &,CLIMIT=10.*EPSQ, RCP=1./CP, & - & RCPRV=RCP/RV, RRHOL=1./RHOL, XLS1=XLS*RCP, XLS2=XLS*XLS*RCPRV, & - & XLS3=XLS*XLS/RV, & & C1=1./3., C2=1./6., C3=3.31/6., & & DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3, N0r0=8.E6, N0rmin=1.e4, & & N0s0=4.E6, RHO0=1.194, XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, & @@ -1271,7 +1271,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! precipitation (large) ice amounts are estimated to be the precip ! ice present at the start of the time step. ! -!--- Extended to include sedimentation of rain on 2/5/01 +!--- Extended to include sedimentation of rain on 2/5/01 ! REAL, PARAMETER :: BLEND=1. ! @@ -1283,7 +1283,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! REAL EMAIRI, N0r, NLICE, NSmICE, NLImax, pfac LOGICAL CLEAR, ICE_logical, DBG_logical, RAIN_logical - + integer lbef, ipass, ixrf, ixs, itdx, idr & &, index_my, indexr, indexr1, indexs & &, i, j, k, l, ntimes, item @@ -1315,12 +1315,34 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & &, piacw, piacwi, piacwr, qv, dwvi & &, arainnew, thick, asnownew & &, qinew, qi_min_0c, QSW_l, QSI_l, QSW0_l, SCHMIT_FAC - + real :: cp, rv, hvap, hfus, t0c, rrhol, rd, epsm1, eps1, eps + ! ! !####################################################################### !########################## Begin Execution ############################ !####################################################################### + CP = con_CP + RD = con_RD + RV = con_RV + T0C = con_T0C + HVAP = con_HVAP + HFUS = con_HFUS + EPS = con_EPS + EPSM1 = con_EPSM1 + EPS1 = con_FVirt +! pi => con_pi +! grav => con_g + + + XLS=HVAP+HFUS + CLIMIT=10.*EPSQ + RCP=1./CP + RCPRV=RCP/RV + RRHOL=1./RHOL + XLS1=XLS*RCP + XLS2=XLS*XLS*RCPRV + XLS3=XLS*XLS/RV ! DTPH = DTPG / mic_step ARAING = 0. ! Total Accumulated rainfall at surface (kg/m**2) @@ -1366,9 +1388,9 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & pfac = 1.0 ! CLEAR = .TRUE. -! +! !--- Check grid-scale saturation when no condensate is present -! +! ESW = min(PP, FPVSL(TK)) ! Saturation vapor pressure w/r/t water ! QSW = EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water QSW = EPS*ESW/(PP+epsm1*ESW) ! Saturation specific humidity w/r/t water @@ -1405,7 +1427,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! !--- Check if any ice is falling into layer from above ! -!--- NOTE that "SNOW" in variable names is synonomous with +!--- NOTE that "SNOW" in variable names is synonomous with ! large, precipitation ice particles ! IF (ASNOW > CLIMIT) THEN @@ -1472,7 +1494,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! IF (DUM1 > DUM2) THEN ! WRITE(6,"(/2(a,i4),a,i2)") '{@ i=',I_index,' j=',J_index, ! & ' L=',L -! WRITE(6,"(4(a12,g11.4,1x))") +! WRITE(6,"(4(a12,g11.4,1x))") ! & '{@ TCold=',TC,'P=',.01*PP,'DIFF=',DUM,'WCold=',WC, ! & '{@ QIold=',QI,'QWold=',QW,'QRold=',QR ! ENDIF @@ -1507,7 +1529,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & SCHMIT_FAC = (RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 ! !--- Air resistance term for the fall speed of ice following the -! basic research by Heymsfield, Kajikawa, others +! basic research by Heymsfield, Kajikawa, others ! GAMMAS = (1.E5/PP)**C1 ! @@ -1545,7 +1567,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! * XSIMASS - used for calculating small ice mixing ratio !--- ! * TOT_ICE - total mass (small & large) ice before microphysics, -! which is the sum of the total mass of large ice in the +! which is the sum of the total mass of large ice in the ! current layer and the input flux of ice from above ! * PILOSS - greatest loss (<0) of total (small & large) ice by ! sublimation, removing all of the ice falling from above @@ -1616,7 +1638,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! converted from Fig. 5 plot of LAMDAs. Similar set of relationships ! also shown in Fig. 8 of Ryan (BAMS, 1996, p. 66). ! - !--- Begin 6/19/03 changes => allow NLImax to increase & FLARGE to + !--- Begin 6/19/03 changes => allow NLImax to increase & FLARGE to ! decrease at COLDER temperatures; set FLARGE to zero (i.e., only small ! ice) if the ice mixing ratio is below QI_min @@ -1684,7 +1706,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ELSE IF (XLI <= MASSI(MDImax) ) THEN DLI = 3.9751E6*XLI**.49870 ! DLI in microns INDEXS = MIN(MDImax, MAX(MDImin, INT(DLI) ) ) - ELSE + ELSE INDEXS = MDImax ENDIF ! End IF (XLI <= MASSI(MDImin) ) ENDIF ! End IF (TC < 0) @@ -1704,7 +1726,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & IF (DUM >= NLImax .AND. INDEXS >= MDImax) & & RimeF1 = RHO*(QTICE/NLImax-XSIMASS)/MASSI(INDEXS) ! -! WRITE(6,"(4(a12,g11.4,1x))") +! WRITE(6,"(4(a12,g11.4,1x))") ! & '{$ TC=',TC,'P=',.01*PP,'NLICE=',NLICE,'DUM=',DUM, ! & '{$ XLI=',XLI,'INDEXS=',FLOAT(INDEXS),'RHO=',RHO,'QTICE=',QTICE, ! & '{$ XSIMASS=',XSIMASS,'RimeF1=',RimeF1 @@ -1722,7 +1744,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! IF (QW > EPSQ .AND. TC >= T_ICE) THEN ! - !--- QW0 could be modified based on land/sea properties, + !--- QW0 could be modified based on land/sea properties, ! presence of convection, etc. This is why QAUT0 and CRAUT ! are passed into the subroutine as externally determined ! parameters. Can be changed in the future if desired. @@ -1756,10 +1778,10 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! !--- Adjust to ice saturation at T DUM) PIDEP = DEPOSIT(PP, RHgrd, DUM1, DUM2) + IF (DUM2 > DUM) PIDEP = DEPOSIT(PP, RHgrd, DUM1, DUM2 & + & , CP, RV, HVAP, HFUS) DWVi = 0. ! Used only for debugging ! @@ -1785,7 +1808,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! * SFACTOR - [VEL_INC**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5], ! where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS) ! * Units: SFACTOR - s**.5/m ; ABI - m**2/s ; NLICE - m**-3 ; -! VENTIL, VENTIS - m**-2 ; VENTI1 - m ; +! VENTIL, VENTIS - m**-2 ; VENTI1 - m ; ! VENTI2 - m**2/s**.5 ; DIDEP - unitless ! ! SFACTOR = VEL_INC**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 @@ -1826,13 +1849,13 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! !--- DUM1 is the supersaturation w/r/t ice at water-saturated conditions ! -!--- DUM2 is the number of ice crystals nucleated at water-saturated +!--- DUM2 is the number of ice crystals nucleated at water-saturated ! conditions based on Meyers et al. (JAM, 1992). ! !--- Prevent unrealistically large ice initiation (limited by PIDEP_max) ! if DUM2 values are increased in future experiments ! - DUM1 = QSW/QSI - 1. + DUM1 = QSW/QSI - 1. DUM2 = 1.E3*EXP(12.96*DUM1-0.639) PIDEP = MIN(PIDEP_max,DUM2*MY_GROWTH(INDEX_MY)*RRHO) ! @@ -1850,7 +1873,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! IF (TC >= T_ICE .AND. (QW > EPSQ .OR. WV > QSWgrd)) THEN IF (PIACWI == 0. .AND. PIDEP == 0.) THEN - PCOND = CONDENSE (PP, QW, RHgrd, TK, WV) + PCOND = CONDENSE (PP, QW, RHgrd, TK, WV, CP, RV) ELSE !-- Modify cloud condensation in response to ice processes DUM = XLV*QSWgrd*RCPRV*TK2 DENOMWI = 1. + XLS*DUM @@ -1869,7 +1892,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ENDIF ! EndIF (TC >= T_ICE .AND. (QW > EPSQ .OR. WV > QSWgrd)) ! !--- Limit freezing of accreted rime to prevent temperature oscillations, -! a crude Schumann-Ludlam limit (p. 209 of Young, 1993). +! a crude Schumann-Ludlam limit (p. 209 of Young, 1993). ! TCC = TC + XLV1*PCOND + XLS1*PIDEP + XLF1*PIACWI IF (TCC > 0.) THEN @@ -1881,7 +1904,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! !--- Calculate melting and evaporation/condensation ! * Units: SFACTOR - s**.5/m ; ABI - m**2/s ; NLICE - m**-3 ; -! VENTIL - m**-2 ; VENTI1 - m ; +! VENTIL - m**-2 ; VENTI1 - m ; ! VENTI2 - m**2/s**.5 ; CIEVP - /s ! ! SFACTOR = VEL_INC**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 @@ -1953,7 +1976,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & VRAIN1 = 0. ELSE ! - !--- INDEXR (related to mean diameter) & N0r could be modified + !--- INDEXR (related to mean diameter) & N0r could be modified ! by land/sea properties, presence of convection, etc. ! !--- Rain rate normalized to a density of 1.194 kg/m**3 @@ -2013,13 +2036,13 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! INDEXR = INT( 1.355E3*RR**.2144 + .5 ) INDEXR = MAX( MDR3, MIN(INDEXR, MDRmax) ) - ELSE + ELSE ! !--- Assume fixed mean diameter of rain (0.45 mm) for high rain rates, ! instead vary N0r with rain rate ! INDEXR = MDRmax - ENDIF ! End IF (RR <= RR_DRmin) etc. + ENDIF ! End IF (RR <= RR_DRmin) etc. ! VRAIN1 = GAMMAR*VRAIN(INDEXR) ENDIF ! End IF (ARAIN <= 0.) @@ -2057,7 +2080,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ! * RFACTOR - [GAMMAR**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5], ! where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS) ! -! * Units: RFACTOR - s**.5/m ; ABW - m**2/s ; VENTR - m**-2 ; +! * Units: RFACTOR - s**.5/m ; ABW - m**2/s ; VENTR - m**-2 ; ! N0r - m**-4 ; VENTR1 - m**2 ; VENTR2 - m**3/s**.5 ; ! CREVP - unitless ! @@ -2065,7 +2088,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & RFACTOR = sqrt(GAMMAR)*SCHMIT_FAC ABW = 1./(RHO*XLV2/THERM_COND+1./DIFFUS) ! -!--- Note that VENTR1, VENTR2 lookup tables do not include the +!--- Note that VENTR1, VENTR2 lookup tables do not include the ! 1/Davg multiplier as in the ice tables ! VENTR = N0r*(VENTR1(INDEXR)+RFACTOR*VENTR2(INDEXR)) @@ -2119,7 +2142,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ENDIF ! End If (DUM < PRLOSS) ENDIF ! End IF (TC < 0. .AND. TCC < 0.) ENDIF ! End IF (TC < T_ICE) - ENDIF ! End IF (RAIN_logical) + ENDIF ! End IF (RAIN_logical) ! !---------------------------------------------------------------------- !---------------------- Main Budget Equations ------------------------- @@ -2231,7 +2254,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & !--- ! * TOT_RAINnew - total mass of rain after microphysics ! current layer and the input flux of ice from above -! * VRAIN2 - time-averaged fall speed of rain in grid and below +! * VRAIN2 - time-averaged fall speed of rain in grid and below ! (with air resistance correction) ! * QRnew - updated rain mixing ratio in layer ! -> TOT_RAINnew=QRnew*(THICK+BLDTRH*VRAIN2) @@ -2277,7 +2300,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & ELSE IF (RR <= RR_DRmax) THEN IDR = INT( 1.355E3*RR**.2144 + .5 ) IDR = MAX( MDR3, MIN(IDR, MDRmax) ) - ELSE + ELSE IDR = MDRmax ENDIF ! End IF (RR <= RR_DRmin) VRAIN2 = GAMMAR*VRAIN(IDR) @@ -2433,7 +2456,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & IF (QInew > EPSQ) NSTATS(ITdx,1) = NSTATS(ITdx,1)+1 IF (QInew > EPSQ .AND. QRnew+QWnew > EPSQ) & & NSTATS(ITdx,2) = NSTATS(ITdx,2)+1 - IF (QWnew > EPSQ) NSTATS(ITdx,3) = NSTATS(ITdx,3)+1 + IF (QWnew > EPSQ) NSTATS(ITdx,3) = NSTATS(ITdx,3)+1 IF (QRnew > EPSQ) NSTATS(ITdx,4) = NSTATS(ITdx,4)+1 ! QMAX(ITdx,1) = MAX(QMAX(ITdx,1), QInew) @@ -2509,7 +2532,7 @@ SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & !--------- Produces accurate calculation of cloud condensation --------- !####################################################################### ! - REAL FUNCTION CONDENSE (PP, QW, RHgrd, TK, WV) + REAL FUNCTION CONDENSE (PP, QW, RHgrd, TK, WV, CP, RV) ! implicit none ! @@ -2520,11 +2543,12 @@ REAL FUNCTION CONDENSE (PP, QW, RHgrd, TK, WV) !--------------------------------------------------------------------------------- ! real pp, qw, rhgrd, tk, wv + real, intent(in) :: cp, rv INTEGER, PARAMETER :: HIGH_PRES=kind_phys ! INTEGER, PARAMETER :: HIGH_PRES=Selected_Real_Kind(15) REAL (KIND=HIGH_PRES), PARAMETER :: & & RHLIMIT=.001, RHLIMIT1=-RHLIMIT - REAL, PARAMETER :: RCP=1./CP, RCPRV=RCP/RV + REAL :: RCP, RCPRV REAL (KIND=HIGH_PRES) :: COND, SSAT, WCdum, tsq real wvdum, tdum, xlv, xlv1, xlv2, ws, dwv, esw, rfac ! @@ -2536,6 +2560,8 @@ REAL FUNCTION CONDENSE (PP, QW, RHgrd, TK, WV) ! XLV1=XLV*RCP ! XLV2=XLV*XLV*RCPRV ! + RCP=1./CP + RCPRV=RCP/RV Tdum = TK WVdum = WV WCdum = QW @@ -2576,7 +2602,7 @@ END FUNCTION CONDENSE !---------------- Calculate ice deposition at T=-10C, ! all ice for T<=-30C, ! and a linear mixture at -10C > T > -30C @@ -2737,16 +2771,16 @@ SUBROUTINE rsipath(im, ix, ix2, levs, prsl, prsi, t, q, clw & !! SNOW (large ice) & CLOUD ICE ! !--- Effective radius (RESNOW) & total ice path (SNOWP) - !--- Total ice path (CICEP) for cloud ice + !--- Total ice path (CICEP) for cloud ice !--- Factor of 1.5 accounts for r**3/r**2 moments for exponentially - ! distributed ice particles in effective radius calculations + ! distributed ice particles in effective radius calculations ! !--- Separation of cloud ice & "snow" uses algorithm from ! subroutine GSMCOLUMN ! IF(QCICE > 0.) THEN ! - !--- Mean particle size following Houze et al. (JAS, 1979, p. 160), + !--- Mean particle size following Houze et al. (JAS, 1979, p. 160), ! converted from Fig. 5 plot of LAMDAs. An analogous set of ! relationships also shown by Fig. 8 of Ryan (BAMS, 1996, p. 66), ! but with a variety of different relationships that parallel the @@ -2795,7 +2829,7 @@ SUBROUTINE rsipath(im, ix, ix2, levs, prsl, prsi, t, q, clw & ! & .OR. TC > -3.)THEN ! FLARGE=FLG0P2 ! ELSE - + !--- Parameterize effects of rime splintering by increasing ! number of small ice particles ! @@ -2815,9 +2849,9 @@ SUBROUTINE rsipath(im, ix, ix2, levs, prsl, prsi, t, q, clw & NLICE=RHO*QCICE/(XSIMASS+RimeF*MASSI(INDEXS)) ! !--- From subroutine GSMCOLUMN: - !--- Minimum number concentration for large ice of NLImin=10/m**3 - ! at T>=0C. Done in order to prevent unrealistically small - ! melting rates and tiny amounts of snow from falling to + !--- Minimum number concentration for large ice of NLImin=10/m**3 + ! at T>=0C. Done in order to prevent unrealistically small + ! melting rates and tiny amounts of snow from falling to ! unrealistically warm temperatures. ! IF(TC >= 0.) THEN @@ -2827,13 +2861,13 @@ SUBROUTINE rsipath(im, ix, ix2, levs, prsl, prsi, t, q, clw & !--- Ferrier 6/13/01: Prevent excess accumulation of ice ! XLI=(RHO*QCICE/NLImax-XSIMASS)/RimeF - + IF(XLI <= MASSI(450) ) THEN DSNOW=9.5885E5*XLI**.42066 ELSE DSNOW=3.9751E6*XLI**.49870 ENDIF - + INDEXS=MIN(MDImax, MAX(INDEXS, INT(DSNOW))) NLICE=RHO*QCICE/(XSIMASS+RimeF*MASSI(INDEXS)) ENDIF @@ -2876,7 +2910,7 @@ SUBROUTINE rsipath(im, ix, ix2, levs, prsl, prsi, t, q, clw & ! &,' qcice=',qcice,' cicep=',cicep(i,l) ! endif - + ENDIF ! END QCICE BLOCK ENDIF ! QTOT IF BLOCK @@ -2897,8 +2931,8 @@ END SUBROUTINE rsipath subroutine rsipath2 & & ( plyr, plvl, tlyr, qlyr, qcwat, qcice, qrain, rrime, & ! inputs & IM, LEVS, iflip, flgmin, & - & cwatp, cicep, rainp, snowp, recwat, rerain, resnow, snden & ! outputs - & ) + & cwatp, cicep, rainp, snowp, recwat, rerain, resnow, snden, & ! outputs + & eps1, grav, rd, t0c) ! constant inputs ! ================= subprogram documentation block ================ ! ! ! @@ -2955,6 +2989,7 @@ subroutine rsipath2 & ! --- constant parameter: real, parameter :: CEXP= 1.0/3.0 + real, intent(in) :: eps1, grav, rd, t0c ! --- inputs: real, dimension(:,:), intent(in) :: & @@ -3190,4 +3225,3 @@ end subroutine rsipath2 !----------------------------------- end MODULE module_microphysics - diff --git a/physics/Radiation/RRTMG/radlw_main.F90 b/physics/Radiation/RRTMG/radlw_main.F90 index 57bebd88f..49bcdbf40 100644 --- a/physics/Radiation/RRTMG/radlw_main.F90 +++ b/physics/Radiation/RRTMG/radlw_main.F90 @@ -79,7 +79,6 @@ ! ! ! external modules referenced: ! ! ! -! 'module physcons' ! ! 'mersenne_twister' ! ! ! ! compilation sequence is: ! @@ -255,7 +254,7 @@ ! apr 2012, b. ferrier and y. hou -- added conversion factor to fu's! ! cloud-snow optical property scheme. ! ! nov 2012, yu-tai hou -- modified control parameters thru ! -! module 'physparam'. ! +! module 'physparam'. ! ! FEB 2017 A.Cheng - add odpth output, effective radius input ! ! jun 2018, h-m lin/y-t hou -- added new option of cloud overlap ! ! method 'de-correlation-length' for mcica application ! @@ -273,12 +272,10 @@ !!!!! end descriptions !!!!! !!!!! ============================================================== !!!!! -!> This module contains the CCPP-compliant NCEP's modifications of the +!> This module contains the CCPP-compliant NCEP's modifications of the !! rrtmg-lw radiation code from aer inc. - module rrtmg_lw + module rrtmg_lw ! - use physcons, only : con_g, con_cp, con_avgd, con_amd, & - & con_amw, con_amo3 use mersenne_twister, only : random_setseed, random_number, & & random_stat use machine, only : kind_phys, & @@ -316,10 +313,6 @@ module rrtmg_lw real (kind=kind_phys), parameter :: f_zero = 0.0 real (kind=kind_phys), parameter :: f_one = 1.0 -! ... atomic weights for conversion from mass to volume mixing ratios - real (kind=kind_phys), parameter :: amdw = con_amd/con_amw - real (kind=kind_phys), parameter :: amdo3 = con_amd/con_amo3 - ! ... band indices integer, dimension(nbands) :: nspa, nspb @@ -430,7 +423,8 @@ subroutine rrtmg_lw_run & & HLW0,HLWB,FLXPRF, & ! --- optional & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & & cld_rwp,cld_ref_rain, cld_swp, cld_ref_snow, & - & cld_od, errmsg, errflg & + & cld_od, con_g, con_amd, con_amw, con_amo3, & + & con_avgd, errmsg, errflg & & ) ! ==================== defination of variables ==================== ! @@ -637,6 +631,8 @@ subroutine rrtmg_lw_run & & aeraod, aerssa logical, intent(in) :: lslwr, top_at_1 + real(kind=kind_phys), intent(in) :: con_g, con_amd, con_amw, con_amo3 + real(kind=kind_phys) :: con_avgd ! --- outputs: real (kind=kind_phys), dimension(:,:), intent(inout) :: hlwc real (kind=kind_phys), dimension(:,:), intent(inout) :: & @@ -706,6 +702,9 @@ subroutine rrtmg_lw_run & integer :: iend ! ending band of calculation integer :: iout ! output option flag (inactive) +! ... atomic weights for conversion from mass to volume mixing ratios + real (kind=kind_phys) :: amdw + real (kind=kind_phys) :: amdo3 ! !===> ... begin here @@ -714,6 +713,9 @@ subroutine rrtmg_lw_run & errmsg = '' errflg = 0 + amdw = con_amd/con_amw + amdo3 = con_amd/con_amo3 + !mz* ! For passing in cloud physical properties; cloud optics parameterized ! in RRTMG: @@ -1313,7 +1315,7 @@ end subroutine rrtmg_lw_run !> \ingroup module_radlw_main !> \brief This subroutine performs calculations necessary for the initialization !! of the longwave model, which includes non-varying model variables, conversion -!! factors, and look-up tables +!! factors, and look-up tables !! !! Lookup tables are computed for use in the lw !! radiative transfer, and input absorption coefficient data for each @@ -1322,7 +1324,7 @@ end subroutine rrtmg_lw_run !!\section rlwinit_gen rlwinit General Algorithm subroutine rlwinit( me, rad_hr_units, inc_minor_gas, ilwcliq, & isubclw, iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr,& - iovr_exp, iovr_exprand, errflg, errmsg ) + iovr_exp, iovr_exprand, con_g, con_cp, errflg, errmsg ) ! =================== program usage description =================== ! ! ! @@ -1394,7 +1396,7 @@ subroutine rlwinit( me, rad_hr_units, inc_minor_gas, ilwcliq, & iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & iovr_exprand logical, intent(in) :: inc_minor_gas - + real(kind=kind_phys), intent(in) :: con_g, con_cp ! --- outputs: character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -1521,8 +1523,8 @@ end subroutine rlwinit !!\param nlay number of layer number !!\param nlp1 number of veritcal levels !!\param ipseed permutation seed for generating random numbers (isubclw>0) -!!\param dz layer thickness (km) -!!\param de_lgth layer cloud decorrelation length (km) +!!\param dz layer thickness (km) +!!\param de_lgth layer cloud decorrelation length (km) !!\param iovr cloud overlapping control flag !!\param alpha EXP/ER cloud overlap decorrelation parameter !!\param cldfmc cloud fraction for each sub-column @@ -1904,7 +1906,7 @@ subroutine mcica_subcol & & ) !> - Sub-column set up according to overlapping assumption: -!! - For random overlap, pick a random value at every level +!! - For random overlap, pick a random value at every level !! - For max-random overlap, pick a random value at every level !! - For maximum overlap, pick same random numebr at every level @@ -2046,13 +2048,13 @@ subroutine mcica_subcol & ! For exponential cloud overlap, the correlation is applied across layers ! without regard to the configuration of clear and cloudy layers. -! For exponential-random cloud overlap, a new exponential transition is -! performed within each group of adjacent cloudy layers and blocks of -! cloudy layers with clear layers between them are correlated randomly. +! For exponential-random cloud overlap, a new exponential transition is +! performed within each group of adjacent cloudy layers and blocks of +! cloudy layers with clear layers between them are correlated randomly. ! -! NOTE: The code below is identical for case (4) and (5) because the -! distinction in the vertical correlation between EXP and ER is already -! built into the specification of alpha (in subroutine get_alpha_exper). +! NOTE: The code below is identical for case (4) and (5) because the +! distinction in the vertical correlation between EXP and ER is already +! built into the specification of alpha (in subroutine get_alpha_exper). ! --- setup 2 sets of random numbers @@ -2077,7 +2079,7 @@ subroutine mcica_subcol & enddo ! --- then working upward from the surface: -! if a random number (from an independent set: cdfun2) is smaller than +! if a random number (from an independent set: cdfun2) is smaller than ! alpha, then use the previous layer's number, otherwise use a new random ! number (keep the originally assigned one in cdfunc for that layer). @@ -3830,7 +3832,7 @@ end subroutine rtrnmc !!\param fracs planck fractions !!\param tautot total optical depth (gas+aerosols) !>\section taumol_gen taumol General Algorithm -!! subprograms called: taugb## (## = 01 -16) +!! subprograms called: taugb## (## = 01 -16) subroutine taumol & & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, & ! --- inputs & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, & @@ -6893,58 +6895,58 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & integer(kind=im) :: lay ! Layer index integer(kind=im) :: ib ! spectral band index integer(kind=im) :: ig ! g-point interval index - integer(kind=im) :: index - integer(kind=im) :: icb(nbands) + integer(kind=im) :: index + integer(kind=im) :: icb(nbands) real(kind=rb) , dimension(2) :: absice0 real(kind=rb) , dimension(2,5) :: absice1 real(kind=rb) , dimension(43,16) :: absice2 real(kind=rb) , dimension(46,16) :: absice3 real(kind=rb) :: absliq0 real(kind=rb) , dimension(58,16) :: absliq1 - - real(kind=rb) :: abscoice(ngptlw) ! ice absorption coefficients - real(kind=rb) :: abscoliq(ngptlw) ! liquid absorption coefficients - real(kind=rb) :: abscosno(ngptlw) ! snow absorption coefficients - real(kind=rb) :: cwp ! cloud water path - real(kind=rb) :: radice ! cloud ice effective size (microns) - real(kind=rb) :: factor ! - real(kind=rb) :: fint ! - real(kind=rb) :: radliq ! cloud liquid droplet radius (microns) - real(kind=rb) :: radsno ! cloud snow effective size (microns) - real(kind=rb), parameter :: eps = 1.e-6_rb ! epsilon - real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities - -! ------- Definitions ------- - -! Explanation of the method for each value of INFLAG. Values of -! 0 or 1 for INFLAG do not distingish being liquid and ice clouds. -! INFLAG = 2 does distinguish between liquid and ice clouds, and -! requires further user input to specify the method to be used to -! compute the aborption due to each. -! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray) -! optical depth are input. -! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud -! water path (g/m2) are input. The (gray) cloud optical -! depth is computed as in CCM2. -! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud -! water path (g/m2), and cloud ice fraction are input. -! ICEFLAG = 0: The ice effective radius (microns) is input and the -! optical depths due to ice clouds are computed as in CCM3. -! ICEFLAG = 1: The ice effective radius (microns) is input and the -! optical depths due to ice clouds are computed as in -! Ebert and Curry, JGR, 97, 3831-3836 (1992). The -! spectral regions in this work have been matched with -! the spectral bands in RRTM to as great an extent -! as possible: -! E&C 1 IB = 5 RRTM bands 9-16 -! E&C 2 IB = 4 RRTM bands 6-8 -! E&C 3 IB = 3 RRTM bands 3-5 -! E&C 4 IB = 2 RRTM band 2 -! E&C 5 IB = 1 RRTM band 1 + + real(kind=rb) :: abscoice(ngptlw) ! ice absorption coefficients + real(kind=rb) :: abscoliq(ngptlw) ! liquid absorption coefficients + real(kind=rb) :: abscosno(ngptlw) ! snow absorption coefficients + real(kind=rb) :: cwp ! cloud water path + real(kind=rb) :: radice ! cloud ice effective size (microns) + real(kind=rb) :: factor ! + real(kind=rb) :: fint ! + real(kind=rb) :: radliq ! cloud liquid droplet radius (microns) + real(kind=rb) :: radsno ! cloud snow effective size (microns) + real(kind=rb), parameter :: eps = 1.e-6_rb ! epsilon + real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities + +! ------- Definitions ------- + +! Explanation of the method for each value of INFLAG. Values of +! 0 or 1 for INFLAG do not distingish being liquid and ice clouds. +! INFLAG = 2 does distinguish between liquid and ice clouds, and +! requires further user input to specify the method to be used to +! compute the aborption due to each. +! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray) +! optical depth are input. +! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud +! water path (g/m2) are input. The (gray) cloud optical +! depth is computed as in CCM2. +! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud +! water path (g/m2), and cloud ice fraction are input. +! ICEFLAG = 0: The ice effective radius (microns) is input and the +! optical depths due to ice clouds are computed as in CCM3. +! ICEFLAG = 1: The ice effective radius (microns) is input and the +! optical depths due to ice clouds are computed as in +! Ebert and Curry, JGR, 97, 3831-3836 (1992). The +! spectral regions in this work have been matched with +! the spectral bands in RRTM to as great an extent +! as possible: +! E&C 1 IB = 5 RRTM bands 9-16 +! E&C 2 IB = 4 RRTM bands 6-8 +! E&C 3 IB = 3 RRTM bands 3-5 +! E&C 4 IB = 2 RRTM band 2 +! E&C 5 IB = 1 RRTM band 1 ! ICEFLAG = 2: The ice effective radius (microns) is input and the ! optical properties due to ice clouds are computed from ! the optical properties stored in the RT code, -! STREAMER v3.0 (Reference: Key. J., Streamer +! STREAMER v3.0 (Reference: Key. J., Streamer ! User's Guide, Cooperative Institute for ! Meteorological Satellite Studies, 2001, 96 pp.). ! Valid range of values for re are between 5.0 and @@ -6959,20 +6961,20 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & ! 140.0 micron. ! LIQFLAG = 0: The optical depths due to water clouds are computed as ! in CCM3. -! LIQFLAG = 1: The water droplet effective radius (microns) is input -! and the optical depths due to water clouds are computed +! LIQFLAG = 1: The water droplet effective radius (microns) is input +! and the optical depths due to water clouds are computed ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993). ! The values for absorption coefficients appropriate for -! the spectral bands in RRTM have been obtained for a -! range of effective radii by an averaging procedure +! the spectral bands in RRTM have been obtained for a +! range of effective radii by an averaging procedure ! based on the work of J. Pinto (private communication). -! Linear interpolation is used to get the absorption +! Linear interpolation is used to get the absorption ! coefficients for the input effective radius. data icb /1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5/ ! Everything below is for INFLAG = 2. -! ABSICEn(J,IB) are the parameters needed to compute the liquid water +! ABSICEn(J,IB) are the parameters needed to compute the liquid water ! absorption coefficient in spectral region IB for ICEFLAG=n. The units ! of ABSICEn(1,IB) are m2/g and ABSICEn(2,IB) has units (microns (m2/g)). ! For ICEFLAG = 0. @@ -7027,57 +7029,57 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & ! band 4 1.804566e-01_rb,1.168987e-01_rb,8.680442e-02_rb,6.910060e-02_rb,5.738174e-02_rb, & 4.902332e-02_rb,4.274585e-02_rb,3.784923e-02_rb,3.391734e-02_rb,3.068690e-02_rb, & - 2.798301e-02_rb,2.568480e-02_rb,2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb, & - 1.912777e-02_rb,1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb, & - 1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,1.156669e-02_rb, & - 1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,9.614854e-03_rb,9.202335e-03_rb, & - 8.814470e-03_rb,8.449077e-03_rb,8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb, & - 7.176671e-03_rb,6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb, & - 5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/) - absice2(:,5) = (/ & -! band 5 - 2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,5.941273e-02_rb, & - 4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,3.337910e-02_rb,2.994978e-02_rb, & - 2.711556e-02_rb,2.473461e-02_rb,2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb, & - 1.810267e-02_rb,1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb, & - 1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,1.082583e-02_rb, & - 1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,9.031157e-03_rb,8.657217e-03_rb, & - 8.307449e-03_rb,7.979609e-03_rb,7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb, & - 6.851298e-03_rb,6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb, & - 5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/) - absice2(:,6) = (/ & -! band 6 - 1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,5.399997e-02_rb, & - 4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,3.300218e-02_rb,3.000586e-02_rb, & - 2.747148e-02_rb,2.529633e-02_rb,2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb, & - 1.896487e-02_rb,1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb, & - 1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,1.135657e-02_rb, & - 1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,9.318505e-03_rb,8.882815e-03_rb, & - 8.471458e-03_rb,8.082364e-03_rb,7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb, & - 6.714725e-03_rb,6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb, & - 5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/) - absice2(:,7) = (/ & -! band 7 - 7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,4.225986e-02_rb, & - 3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,3.045798e-02_rb,2.845343e-02_rb, & - 2.667231e-02_rb,2.507353e-02_rb,2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb, & - 1.997617e-02_rb,1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb, & - 1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,1.264164e-02_rb, & - 1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,1.035218e-02_rb,9.839297e-03_rb, & - 9.346733e-03_rb,8.873057e-03_rb,8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb, & - 7.143210e-03_rb,6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb, & - 5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/) - absice2(:,8) = (/ & -! band 8 - 9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,4.305946e-02_rb, & - 3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,2.929794e-02_rb,2.712627e-02_rb, & - 2.523856e-02_rb,2.357810e-02_rb,2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb, & - 1.850310e-02_rb,1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb, & - 1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,1.180456e-02_rb, & - 1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,9.864433e-03_rb,9.439878e-03_rb, & - 9.035637e-03_rb,8.650140e-03_rb,8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb, & - 7.269505e-03_rb,6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb, & - 5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/) + 2.798301e-02_rb,2.568480e-02_rb,2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb, & + 1.912777e-02_rb,1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb, & + 1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,1.156669e-02_rb, & + 1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,9.614854e-03_rb,9.202335e-03_rb, & + 8.814470e-03_rb,8.449077e-03_rb,8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb, & + 7.176671e-03_rb,6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb, & + 5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/) + absice2(:,5) = (/ & +! band 5 + 2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,5.941273e-02_rb, & + 4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,3.337910e-02_rb,2.994978e-02_rb, & + 2.711556e-02_rb,2.473461e-02_rb,2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb, & + 1.810267e-02_rb,1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb, & + 1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,1.082583e-02_rb, & + 1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,9.031157e-03_rb,8.657217e-03_rb, & + 8.307449e-03_rb,7.979609e-03_rb,7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb, & + 6.851298e-03_rb,6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb, & + 5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/) + absice2(:,6) = (/ & +! band 6 + 1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,5.399997e-02_rb, & + 4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,3.300218e-02_rb,3.000586e-02_rb, & + 2.747148e-02_rb,2.529633e-02_rb,2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb, & + 1.896487e-02_rb,1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb, & + 1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,1.135657e-02_rb, & + 1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,9.318505e-03_rb,8.882815e-03_rb, & + 8.471458e-03_rb,8.082364e-03_rb,7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb, & + 6.714725e-03_rb,6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb, & + 5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/) + absice2(:,7) = (/ & +! band 7 + 7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,4.225986e-02_rb, & + 3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,3.045798e-02_rb,2.845343e-02_rb, & + 2.667231e-02_rb,2.507353e-02_rb,2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb, & + 1.997617e-02_rb,1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb, & + 1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,1.264164e-02_rb, & + 1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,1.035218e-02_rb,9.839297e-03_rb, & + 9.346733e-03_rb,8.873057e-03_rb,8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb, & + 7.143210e-03_rb,6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb, & + 5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/) + absice2(:,8) = (/ & +! band 8 + 9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,4.305946e-02_rb, & + 3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,2.929794e-02_rb,2.712627e-02_rb, & + 2.523856e-02_rb,2.357810e-02_rb,2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb, & + 1.850310e-02_rb,1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb, & + 1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,1.180456e-02_rb, & + 1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,9.864433e-03_rb,9.439878e-03_rb, & + 9.035637e-03_rb,8.650140e-03_rb,8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb, & + 7.269505e-03_rb,6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb, & + 5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/) absice2(:,9) = (/ & ! band 9 1.294087e-01_rb,8.788217e-02_rb,6.728288e-02_rb,5.479720e-02_rb,4.635049e-02_rb, & @@ -7095,79 +7097,79 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 4.171159e-02_rb,3.638480e-02_rb,3.226692e-02_rb,2.898717e-02_rb,2.631256e-02_rb, & 2.408925e-02_rb,2.221156e-02_rb,2.060448e-02_rb,1.921325e-02_rb,1.799699e-02_rb, & 1.692456e-02_rb,1.597177e-02_rb,1.511961e-02_rb,1.435289e-02_rb,1.365933e-02_rb, & - 1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,1.099230e-02_rb, & - 1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,9.498395e-03_rb,9.185047e-03_rb, & - 8.891237e-03_rb,8.615185e-03_rb,8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb, & - 7.659759e-03_rb,7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb, & - 6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/) - absice2(:,11) = (/ & -! band 11 - 1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,4.828355e-02_rb, & - 4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,2.824593e-02_rb,2.560156e-02_rb, & - 2.341503e-02_rb,2.157740e-02_rb,2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb, & - 1.645421e-02_rb,1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb, & - 1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,1.082096e-02_rb, & - 1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,9.428223e-03_rb,9.137756e-03_rb, & - 8.865964e-03_rb,8.611115e-03_rb,8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb, & - 7.733187e-03_rb,7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb, & - 6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/) - absice2(:,12) = (/ & -! band 12 - 9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,3.418456e-02_rb, & - 2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,2.153915e-02_rb,1.980791e-02_rb, & - 1.836689e-02_rb,1.714979e-02_rb,1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb, & - 1.373468e-02_rb,1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb, & - 1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,9.976896e-03_rb, & - 9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,9.058902e-03_rb,8.868710e-03_rb, & - 8.691240e-03_rb,8.525312e-03_rb,8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb, & - 7.957917e-03_rb,7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb, & - 7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/) + 1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,1.099230e-02_rb, & + 1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,9.498395e-03_rb,9.185047e-03_rb, & + 8.891237e-03_rb,8.615185e-03_rb,8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb, & + 7.659759e-03_rb,7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb, & + 6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/) + absice2(:,11) = (/ & +! band 11 + 1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,4.828355e-02_rb, & + 4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,2.824593e-02_rb,2.560156e-02_rb, & + 2.341503e-02_rb,2.157740e-02_rb,2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb, & + 1.645421e-02_rb,1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb, & + 1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,1.082096e-02_rb, & + 1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,9.428223e-03_rb,9.137756e-03_rb, & + 8.865964e-03_rb,8.611115e-03_rb,8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb, & + 7.733187e-03_rb,7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb, & + 6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/) + absice2(:,12) = (/ & +! band 12 + 9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,3.418456e-02_rb, & + 2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,2.153915e-02_rb,1.980791e-02_rb, & + 1.836689e-02_rb,1.714979e-02_rb,1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb, & + 1.373468e-02_rb,1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb, & + 1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,9.976896e-03_rb, & + 9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,9.058902e-03_rb,8.868710e-03_rb, & + 8.691240e-03_rb,8.525312e-03_rb,8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb, & + 7.957917e-03_rb,7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb, & + 7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/) absice2(:,13) = (/ & -! band 13 - 1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,4.096790e-02_rb, & - 3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,2.412102e-02_rb,2.195132e-02_rb, & - 2.017124e-02_rb,1.868641e-02_rb,1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb, & - 1.461388e-02_rb,1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb, & - 1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,1.030126e-02_rb, & - 1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,9.276155e-03_rb,9.065205e-03_rb, & - 8.868808e-03_rb,8.685571e-03_rb,8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb, & - 8.061776e-03_rb,7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb, & - 7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/) - absice2(:,14) = (/ & -! band 14 - 1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,3.888637e-02_rb, & - 3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,2.330224e-02_rb,2.126754e-02_rb, & - 1.959258e-02_rb,1.819130e-02_rb,1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb, & - 1.432666e-02_rb,1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb, & - 1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,1.019440e-02_rb, & - 9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,9.205005e-03_rb,9.001022e-03_rb, & - 8.810992e-03_rb,8.633588e-03_rb,8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb, & - 8.028878e-03_rb,7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb, & - 7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/) - absice2(:,15) = (/ & -! band 15 - 8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,3.119623e-02_rb, & - 2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,1.986526e-02_rb,1.830306e-02_rb, & - 1.699991e-02_rb,1.589698e-02_rb,1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb, & - 1.278883e-02_rb,1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb, & - 1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,9.337044e-03_rb, & - 9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,8.486341e-03_rb,8.309594e-03_rb, & - 8.144500e-03_rb,7.989986e-03_rb,7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb, & - 7.460376e-03_rb,7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb, & - 6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/) - absice2(:,16) = (/ & -! band 16 - 1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,4.063891e-02_rb, & - 3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,2.390631e-02_rb,2.169972e-02_rb, & - 1.987596e-02_rb,1.834393e-02_rb,1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb, & - 1.407780e-02_rb,1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb, & - 1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,9.402477e-03_rb, & - 9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,8.251146e-03_rb,8.011373e-03_rb, & - 7.787140e-03_rb,7.577002e-03_rb,7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb, & - 6.854061e-03_rb,6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb, & - 6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/) - -! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in +! band 13 + 1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,4.096790e-02_rb, & + 3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,2.412102e-02_rb,2.195132e-02_rb, & + 2.017124e-02_rb,1.868641e-02_rb,1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb, & + 1.461388e-02_rb,1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb, & + 1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,1.030126e-02_rb, & + 1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,9.276155e-03_rb,9.065205e-03_rb, & + 8.868808e-03_rb,8.685571e-03_rb,8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb, & + 8.061776e-03_rb,7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb, & + 7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/) + absice2(:,14) = (/ & +! band 14 + 1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,3.888637e-02_rb, & + 3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,2.330224e-02_rb,2.126754e-02_rb, & + 1.959258e-02_rb,1.819130e-02_rb,1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb, & + 1.432666e-02_rb,1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb, & + 1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,1.019440e-02_rb, & + 9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,9.205005e-03_rb,9.001022e-03_rb, & + 8.810992e-03_rb,8.633588e-03_rb,8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb, & + 8.028878e-03_rb,7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb, & + 7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/) + absice2(:,15) = (/ & +! band 15 + 8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,3.119623e-02_rb, & + 2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,1.986526e-02_rb,1.830306e-02_rb, & + 1.699991e-02_rb,1.589698e-02_rb,1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb, & + 1.278883e-02_rb,1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb, & + 1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,9.337044e-03_rb, & + 9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,8.486341e-03_rb,8.309594e-03_rb, & + 8.144500e-03_rb,7.989986e-03_rb,7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb, & + 7.460376e-03_rb,7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb, & + 6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/) + absice2(:,16) = (/ & +! band 16 + 1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,4.063891e-02_rb, & + 3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,2.390631e-02_rb,2.169972e-02_rb, & + 1.987596e-02_rb,1.834393e-02_rb,1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb, & + 1.407780e-02_rb,1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb, & + 1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,9.402477e-03_rb, & + 9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,8.251146e-03_rb,8.011373e-03_rb, & + 7.787140e-03_rb,7.577002e-03_rb,7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb, & + 6.854061e-03_rb,6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb, & + 6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/) + +! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in ! increments of 3 microns. ! units = m2/g ! Hexagonal Ice Particle Parameterization @@ -7231,9 +7233,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.301260e-02_rb,1.254781e-02_rb,1.210941e-02_rb,1.169468e-02_rb,1.130118e-02_rb, & 1.092675e-02_rb,1.056945e-02_rb,1.022757e-02_rb,9.899560e-03_rb,9.584021e-03_rb, & 9.279705e-03_rb,8.985479e-03_rb,8.700322e-03_rb,8.423306e-03_rb,8.153590e-03_rb, & - 7.890412e-03_rb/) - absice3(:,6) = (/ & -! band 6 + 7.890412e-03_rb/) + absice3(:,6) = (/ & +! band 6 1.145369e-01_rb,1.174566e-01_rb,9.917866e-02_rb,8.332990e-02_rb,7.104263e-02_rb, & 6.153370e-02_rb,5.405472e-02_rb,4.806281e-02_rb,4.317918e-02_rb,3.913795e-02_rb, & 3.574916e-02_rb,3.287437e-02_rb,3.041067e-02_rb,2.828017e-02_rb,2.642292e-02_rb, & @@ -7243,9 +7245,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.293447e-02_rb,1.252685e-02_rb,1.213939e-02_rb,1.176968e-02_rb,1.141555e-02_rb, & 1.107508e-02_rb,1.074655e-02_rb,1.042839e-02_rb,1.011923e-02_rb,9.817799e-03_rb, & 9.522962e-03_rb,9.233688e-03_rb,8.949041e-03_rb,8.668171e-03_rb,8.390301e-03_rb, & - 8.114723e-03_rb/) - absice3(:,7) = (/ & -! band 7 + 8.114723e-03_rb/) + absice3(:,7) = (/ & +! band 7 1.222345e-02_rb,5.344230e-02_rb,5.523465e-02_rb,5.128759e-02_rb,4.676925e-02_rb, & 4.266150e-02_rb,3.910561e-02_rb,3.605479e-02_rb,3.342843e-02_rb,3.115052e-02_rb, & 2.915776e-02_rb,2.739935e-02_rb,2.583499e-02_rb,2.443266e-02_rb,2.316681e-02_rb, & @@ -7255,9 +7257,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.191172e-02_rb,1.149171e-02_rb,1.108936e-02_rb,1.070341e-02_rb,1.033271e-02_rb, & 9.976220e-03_rb,9.633021e-03_rb,9.302273e-03_rb,8.983216e-03_rb,8.675161e-03_rb, & 8.377478e-03_rb,8.089595e-03_rb,7.810986e-03_rb,7.541170e-03_rb,7.279706e-03_rb, & - 7.026186e-03_rb/) - absice3(:,8) = (/ & -! band 8 + 7.026186e-03_rb/) + absice3(:,8) = (/ & +! band 8 6.711058e-02_rb,6.918198e-02_rb,6.127484e-02_rb,5.411944e-02_rb,4.836902e-02_rb, & 4.375293e-02_rb,3.998077e-02_rb,3.683587e-02_rb,3.416508e-02_rb,3.186003e-02_rb, & 2.984290e-02_rb,2.805671e-02_rb,2.645895e-02_rb,2.501733e-02_rb,2.370689e-02_rb, & @@ -7267,9 +7269,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.173682e-02_rb,1.129925e-02_rb,1.088393e-02_rb,1.048961e-02_rb,1.011516e-02_rb, & 9.759543e-03_rb,9.421813e-03_rb,9.101089e-03_rb,8.796559e-03_rb,8.507464e-03_rb, & 8.233098e-03_rb,7.972798e-03_rb,7.725942e-03_rb,7.491940e-03_rb,7.270238e-03_rb, & - 7.060305e-03_rb/) - absice3(:,9) = (/ & -! band 9 + 7.060305e-03_rb/) + absice3(:,9) = (/ & +! band 9 1.236780e-01_rb,9.222386e-02_rb,7.383997e-02_rb,6.204072e-02_rb,5.381029e-02_rb, & 4.770678e-02_rb,4.296928e-02_rb,3.916131e-02_rb,3.601540e-02_rb,3.335878e-02_rb, & 3.107493e-02_rb,2.908247e-02_rb,2.732282e-02_rb,2.575276e-02_rb,2.433968e-02_rb, & @@ -7279,9 +7281,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.208808e-02_rb,1.167094e-02_rb,1.127862e-02_rb,1.090979e-02_rb,1.056323e-02_rb, & 1.023786e-02_rb,9.932665e-03_rb,9.646744e-03_rb,9.379250e-03_rb,9.129409e-03_rb, & 8.896500e-03_rb,8.679856e-03_rb,8.478852e-03_rb,8.292904e-03_rb,8.121463e-03_rb, & - 7.964013e-03_rb/) - absice3(:,10) = (/ & -! band 10 + 7.964013e-03_rb/) + absice3(:,10) = (/ & +! band 10 1.655966e-01_rb,1.134205e-01_rb,8.714344e-02_rb,7.129241e-02_rb,6.063739e-02_rb, & 5.294203e-02_rb,4.709309e-02_rb,4.247476e-02_rb,3.871892e-02_rb,3.559206e-02_rb, & 3.293893e-02_rb,3.065226e-02_rb,2.865558e-02_rb,2.689288e-02_rb,2.532221e-02_rb, & @@ -7291,9 +7293,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.239992e-02_rb,1.198486e-02_rb,1.159647e-02_rb,1.123323e-02_rb,1.089375e-02_rb, & 1.057679e-02_rb,1.028124e-02_rb,1.000607e-02_rb,9.750376e-03_rb,9.513303e-03_rb, & 9.294082e-03_rb,9.092003e-03_rb,8.906412e-03_rb,8.736702e-03_rb,8.582314e-03_rb, & - 8.442725e-03_rb/) - absice3(:,11) = (/ & -! band 11 + 8.442725e-03_rb/) + absice3(:,11) = (/ & +! band 11 1.775615e-01_rb,1.180046e-01_rb,8.929607e-02_rb,7.233500e-02_rb,6.108333e-02_rb, & 5.303642e-02_rb,4.696927e-02_rb,4.221206e-02_rb,3.836768e-02_rb,3.518576e-02_rb, & 3.250063e-02_rb,3.019825e-02_rb,2.819758e-02_rb,2.643943e-02_rb,2.487953e-02_rb, & @@ -7303,9 +7305,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.229321e-02_rb,1.189350e-02_rb,1.151915e-02_rb,1.116859e-02_rb,1.084042e-02_rb, & 1.053338e-02_rb,1.024636e-02_rb,9.978326e-03_rb,9.728357e-03_rb,9.495613e-03_rb, & 9.279327e-03_rb,9.078798e-03_rb,8.893383e-03_rb,8.722488e-03_rb,8.565568e-03_rb, & - 8.422115e-03_rb/) - absice3(:,12) = (/ & -! band 12 + 8.422115e-03_rb/) + absice3(:,12) = (/ & +! band 12 9.465447e-02_rb,6.432047e-02_rb,5.060973e-02_rb,4.267283e-02_rb,3.741843e-02_rb, & 3.363096e-02_rb,3.073531e-02_rb,2.842405e-02_rb,2.651789e-02_rb,2.490518e-02_rb, & 2.351273e-02_rb,2.229056e-02_rb,2.120335e-02_rb,2.022541e-02_rb,1.933763e-02_rb, & @@ -7315,9 +7317,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.112148e-02_rb,1.081609e-02_rb,1.052642e-02_rb,1.025178e-02_rb,9.991540e-03_rb, & 9.745130e-03_rb,9.512038e-03_rb,9.291797e-03_rb,9.083980e-03_rb,8.888195e-03_rb, & 8.704081e-03_rb,8.531306e-03_rb,8.369560e-03_rb,8.218558e-03_rb,8.078032e-03_rb, & - 7.947730e-03_rb/) - absice3(:,13) = (/ & -! band 13 + 7.947730e-03_rb/) + absice3(:,13) = (/ & +! band 13 1.560311e-01_rb,9.961097e-02_rb,7.502949e-02_rb,6.115022e-02_rb,5.214952e-02_rb, & 4.578149e-02_rb,4.099731e-02_rb,3.724174e-02_rb,3.419343e-02_rb,3.165356e-02_rb, & 2.949251e-02_rb,2.762222e-02_rb,2.598073e-02_rb,2.452322e-02_rb,2.321642e-02_rb, & @@ -7327,9 +7329,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.204183e-02_rb,1.167164e-02_rb,1.132567e-02_rb,1.100281e-02_rb,1.070207e-02_rb, & 1.042258e-02_rb,1.016352e-02_rb,9.924197e-03_rb,9.703953e-03_rb,9.502199e-03_rb, & 9.318400e-03_rb,9.152066e-03_rb,9.002749e-03_rb,8.870038e-03_rb,8.753555e-03_rb, & - 8.652951e-03_rb/) - absice3(:,14) = (/ & -! band 14 + 8.652951e-03_rb/) + absice3(:,14) = (/ & +! band 14 1.559547e-01_rb,9.896700e-02_rb,7.441231e-02_rb,6.061469e-02_rb,5.168730e-02_rb, & 4.537821e-02_rb,4.064106e-02_rb,3.692367e-02_rb,3.390714e-02_rb,3.139438e-02_rb, & 2.925702e-02_rb,2.740783e-02_rb,2.578547e-02_rb,2.434552e-02_rb,2.305506e-02_rb, & @@ -7339,9 +7341,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.205973e-02_rb,1.169780e-02_rb,1.135989e-02_rb,1.104492e-02_rb,1.075192e-02_rb, & 1.048004e-02_rb,1.022850e-02_rb,9.996611e-03_rb,9.783753e-03_rb,9.589361e-03_rb, & 9.412924e-03_rb,9.253977e-03_rb,9.112098e-03_rb,8.986903e-03_rb,8.878039e-03_rb, & - 8.785184e-03_rb/) - absice3(:,15) = (/ & -! band 15 + 8.785184e-03_rb/) + absice3(:,15) = (/ & +! band 15 1.102926e-01_rb,7.176622e-02_rb,5.530316e-02_rb,4.606056e-02_rb,4.006116e-02_rb, & 3.579628e-02_rb,3.256909e-02_rb,3.001360e-02_rb,2.791920e-02_rb,2.615617e-02_rb, & 2.464023e-02_rb,2.331426e-02_rb,2.213817e-02_rb,2.108301e-02_rb,2.012733e-02_rb, & @@ -7351,9 +7353,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.145348e-02_rb,1.114612e-02_rb,1.085730e-02_rb,1.058633e-02_rb,1.033263e-02_rb, & 1.009564e-02_rb,9.874895e-03_rb,9.669960e-03_rb,9.480449e-03_rb,9.306014e-03_rb, & 9.146339e-03_rb,9.001138e-03_rb,8.870154e-03_rb,8.753148e-03_rb,8.649907e-03_rb, & - 8.560232e-03_rb/) + 8.560232e-03_rb/) absice3(:,16) = (/ & -! band 16 +! band 16 1.688344e-01_rb,1.077072e-01_rb,7.994467e-02_rb,6.403862e-02_rb,5.369850e-02_rb, & 4.641582e-02_rb,4.099331e-02_rb,3.678724e-02_rb,3.342069e-02_rb,3.065831e-02_rb, & 2.834557e-02_rb,2.637680e-02_rb,2.467733e-02_rb,2.319286e-02_rb,2.188299e-02_rb, & @@ -7363,16 +7365,16 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.149683e-02_rb,1.116436e-02_rb,1.085153e-02_rb,1.055701e-02_rb,1.027961e-02_rb, & 1.001831e-02_rb,9.772141e-03_rb,9.540280e-03_rb,9.321966e-03_rb,9.116517e-03_rb, & 8.923315e-03_rb,8.741803e-03_rb,8.571472e-03_rb,8.411860e-03_rb,8.262543e-03_rb, & - 8.123136e-03_rb/) - -! For LIQFLAG = 0. - absliq0 = 0.0903614_rb - -! For LIQFLAG = 1. In each band, the absorption -! coefficients are listed for a range of effective radii from 2.5 -! to 59.5 microns in increments of 1.0 micron. - absliq1(:, 1) = (/ & -! band 1 + 8.123136e-03_rb/) + +! For LIQFLAG = 0. + absliq0 = 0.0903614_rb + +! For LIQFLAG = 1. In each band, the absorption +! coefficients are listed for a range of effective radii from 2.5 +! to 59.5 microns in increments of 1.0 micron. + absliq1(:, 1) = (/ & +! band 1 1.64047e-03_rb, 6.90533e-02_rb, 7.72017e-02_rb, 7.78054e-02_rb, 7.69523e-02_rb, & 7.58058e-02_rb, 7.46400e-02_rb, 7.35123e-02_rb, 7.24162e-02_rb, 7.13225e-02_rb, & 6.99145e-02_rb, 6.66409e-02_rb, 6.36582e-02_rb, 6.09425e-02_rb, 5.84593e-02_rb, & @@ -7384,9 +7386,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 2.47189e-02_rb, 2.40678e-02_rb, 2.34418e-02_rb, 2.28392e-02_rb, 2.22586e-02_rb, & 2.16986e-02_rb, 2.11580e-02_rb, 2.06356e-02_rb, 2.01305e-02_rb, 1.96417e-02_rb, & 1.91682e-02_rb, 1.87094e-02_rb, 1.82643e-02_rb, 1.78324e-02_rb, 1.74129e-02_rb, & - 1.70052e-02_rb, 1.66088e-02_rb, 1.62231e-02_rb/) - absliq1(:, 2) = (/ & -! band 2 + 1.70052e-02_rb, 1.66088e-02_rb, 1.62231e-02_rb/) + absliq1(:, 2) = (/ & +! band 2 2.19486e-01_rb, 1.80687e-01_rb, 1.59150e-01_rb, 1.44731e-01_rb, 1.33703e-01_rb, & 1.24355e-01_rb, 1.15756e-01_rb, 1.07318e-01_rb, 9.86119e-02_rb, 8.92739e-02_rb, & 8.34911e-02_rb, 7.70773e-02_rb, 7.15240e-02_rb, 6.66615e-02_rb, 6.23641e-02_rb, & @@ -7398,9 +7400,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 2.08834e-02_rb, 2.03051e-02_rb, 1.97536e-02_rb, 1.92271e-02_rb, 1.87239e-02_rb, & 1.82425e-02_rb, 1.77816e-02_rb, 1.73399e-02_rb, 1.69162e-02_rb, 1.65094e-02_rb, & 1.61187e-02_rb, 1.57430e-02_rb, 1.53815e-02_rb, 1.50334e-02_rb, 1.46981e-02_rb, & - 1.43748e-02_rb, 1.40628e-02_rb, 1.37617e-02_rb/) - absliq1(:, 3) = (/ & -! band 3 + 1.43748e-02_rb, 1.40628e-02_rb, 1.37617e-02_rb/) + absliq1(:, 3) = (/ & +! band 3 2.95174e-01_rb, 2.34765e-01_rb, 1.98038e-01_rb, 1.72114e-01_rb, 1.52083e-01_rb, & 1.35654e-01_rb, 1.21613e-01_rb, 1.09252e-01_rb, 9.81263e-02_rb, 8.79448e-02_rb, & 8.12566e-02_rb, 7.44563e-02_rb, 6.86374e-02_rb, 6.36042e-02_rb, 5.92094e-02_rb, & @@ -7412,9 +7414,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.96561e-02_rb, 1.91239e-02_rb, 1.86161e-02_rb, 1.81311e-02_rb, 1.76673e-02_rb, & 1.72234e-02_rb, 1.67981e-02_rb, 1.63903e-02_rb, 1.59989e-02_rb, 1.56230e-02_rb, & 1.52615e-02_rb, 1.49138e-02_rb, 1.45791e-02_rb, 1.42565e-02_rb, 1.39455e-02_rb, & - 1.36455e-02_rb, 1.33559e-02_rb, 1.30761e-02_rb/) - absliq1(:, 4) = (/ & -! band 4 + 1.36455e-02_rb, 1.33559e-02_rb, 1.30761e-02_rb/) + absliq1(:, 4) = (/ & +! band 4 3.00925e-01_rb, 2.36949e-01_rb, 1.96947e-01_rb, 1.68692e-01_rb, 1.47190e-01_rb, & 1.29986e-01_rb, 1.15719e-01_rb, 1.03568e-01_rb, 9.30028e-02_rb, 8.36658e-02_rb, & 7.71075e-02_rb, 7.07002e-02_rb, 6.52284e-02_rb, 6.05024e-02_rb, 5.63801e-02_rb, & @@ -7426,9 +7428,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.91711e-02_rb, 1.86625e-02_rb, 1.81769e-02_rb, 1.77126e-02_rb, 1.72683e-02_rb, & 1.68426e-02_rb, 1.64344e-02_rb, 1.60427e-02_rb, 1.56664e-02_rb, 1.53046e-02_rb, & 1.49565e-02_rb, 1.46214e-02_rb, 1.42985e-02_rb, 1.39871e-02_rb, 1.36866e-02_rb, & - 1.33965e-02_rb, 1.31162e-02_rb, 1.28453e-02_rb/) - absliq1(:, 5) = (/ & -! band 5 + 1.33965e-02_rb, 1.31162e-02_rb, 1.28453e-02_rb/) + absliq1(:, 5) = (/ & +! band 5 2.64691e-01_rb, 2.12018e-01_rb, 1.78009e-01_rb, 1.53539e-01_rb, 1.34721e-01_rb, & 1.19580e-01_rb, 1.06996e-01_rb, 9.62772e-02_rb, 8.69710e-02_rb, 7.87670e-02_rb, & 7.29272e-02_rb, 6.70920e-02_rb, 6.20977e-02_rb, 5.77732e-02_rb, 5.39910e-02_rb, & @@ -7440,9 +7442,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.89917e-02_rb, 1.84984e-02_rb, 1.80269e-02_rb, 1.75755e-02_rb, 1.71431e-02_rb, & 1.67283e-02_rb, 1.63303e-02_rb, 1.59478e-02_rb, 1.55801e-02_rb, 1.52262e-02_rb, & 1.48853e-02_rb, 1.45568e-02_rb, 1.42400e-02_rb, 1.39342e-02_rb, 1.36388e-02_rb, & - 1.33533e-02_rb, 1.30773e-02_rb, 1.28102e-02_rb/) - absliq1(:, 6) = (/ & -! band 6 + 1.33533e-02_rb, 1.30773e-02_rb, 1.28102e-02_rb/) + absliq1(:, 6) = (/ & +! band 6 8.81182e-02_rb, 1.06745e-01_rb, 9.79753e-02_rb, 8.99625e-02_rb, 8.35200e-02_rb, & 7.81899e-02_rb, 7.35939e-02_rb, 6.94696e-02_rb, 6.56266e-02_rb, 6.19148e-02_rb, & 5.83355e-02_rb, 5.49306e-02_rb, 5.19642e-02_rb, 4.93325e-02_rb, 4.69659e-02_rb, & @@ -7454,9 +7456,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.94280e-02_rb, 1.89501e-02_rb, 1.84913e-02_rb, 1.80506e-02_rb, 1.76270e-02_rb, & 1.72196e-02_rb, 1.68276e-02_rb, 1.64500e-02_rb, 1.60863e-02_rb, 1.57357e-02_rb, & 1.53975e-02_rb, 1.50710e-02_rb, 1.47558e-02_rb, 1.44511e-02_rb, 1.41566e-02_rb, & - 1.38717e-02_rb, 1.35960e-02_rb, 1.33290e-02_rb/) - absliq1(:, 7) = (/ & -! band 7 + 1.38717e-02_rb, 1.35960e-02_rb, 1.33290e-02_rb/) + absliq1(:, 7) = (/ & +! band 7 4.32174e-02_rb, 7.36078e-02_rb, 6.98340e-02_rb, 6.65231e-02_rb, 6.41948e-02_rb, & 6.23551e-02_rb, 6.06638e-02_rb, 5.88680e-02_rb, 5.67124e-02_rb, 5.38629e-02_rb, & 4.99579e-02_rb, 4.86289e-02_rb, 4.70120e-02_rb, 4.52854e-02_rb, 4.35466e-02_rb, & @@ -7468,9 +7470,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.90824e-02_rb, 1.86174e-02_rb, 1.81706e-02_rb, 1.77411e-02_rb, 1.73281e-02_rb, & 1.69307e-02_rb, 1.65483e-02_rb, 1.61801e-02_rb, 1.58254e-02_rb, 1.54835e-02_rb, & 1.51538e-02_rb, 1.48358e-02_rb, 1.45288e-02_rb, 1.42322e-02_rb, 1.39457e-02_rb, & - 1.36687e-02_rb, 1.34008e-02_rb, 1.31416e-02_rb/) - absliq1(:, 8) = (/ & -! band 8 + 1.36687e-02_rb, 1.34008e-02_rb, 1.31416e-02_rb/) + absliq1(:, 8) = (/ & +! band 8 1.41881e-01_rb, 7.15419e-02_rb, 6.30335e-02_rb, 6.11132e-02_rb, 6.01931e-02_rb, & 5.92420e-02_rb, 5.78968e-02_rb, 5.58876e-02_rb, 5.28923e-02_rb, 4.84462e-02_rb, & 4.60839e-02_rb, 4.56013e-02_rb, 4.45410e-02_rb, 4.31866e-02_rb, 4.17026e-02_rb, & @@ -7482,9 +7484,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.88056e-02_rb, 1.83564e-02_rb, 1.79241e-02_rb, 1.75079e-02_rb, 1.71070e-02_rb, & 1.67207e-02_rb, 1.63482e-02_rb, 1.59890e-02_rb, 1.56424e-02_rb, 1.53077e-02_rb, & 1.49845e-02_rb, 1.46722e-02_rb, 1.43702e-02_rb, 1.40782e-02_rb, 1.37955e-02_rb, & - 1.35219e-02_rb, 1.32569e-02_rb, 1.30000e-02_rb/) - absliq1(:, 9) = (/ & -! band 9 + 1.35219e-02_rb, 1.32569e-02_rb, 1.30000e-02_rb/) + absliq1(:, 9) = (/ & +! band 9 6.72726e-02_rb, 6.61013e-02_rb, 6.47866e-02_rb, 6.33780e-02_rb, 6.18985e-02_rb, & 6.03335e-02_rb, 5.86136e-02_rb, 5.65876e-02_rb, 5.39839e-02_rb, 5.03536e-02_rb, & 4.71608e-02_rb, 4.63630e-02_rb, 4.50313e-02_rb, 4.34526e-02_rb, 4.17876e-02_rb, & @@ -7496,9 +7498,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.83944e-02_rb, 1.79578e-02_rb, 1.75378e-02_rb, 1.71335e-02_rb, 1.67440e-02_rb, & 1.63687e-02_rb, 1.60069e-02_rb, 1.56579e-02_rb, 1.53210e-02_rb, 1.49958e-02_rb, & 1.46815e-02_rb, 1.43778e-02_rb, 1.40841e-02_rb, 1.37999e-02_rb, 1.35249e-02_rb, & - 1.32585e-02_rb, 1.30004e-02_rb, 1.27502e-02_rb/) - absliq1(:,10) = (/ & -! band 10 + 1.32585e-02_rb, 1.30004e-02_rb, 1.27502e-02_rb/) + absliq1(:,10) = (/ & +! band 10 7.97040e-02_rb, 7.63844e-02_rb, 7.36499e-02_rb, 7.13525e-02_rb, 6.93043e-02_rb, & 6.72807e-02_rb, 6.50227e-02_rb, 6.22395e-02_rb, 5.86093e-02_rb, 5.37815e-02_rb, & 5.14682e-02_rb, 4.97214e-02_rb, 4.77392e-02_rb, 4.56961e-02_rb, 4.36858e-02_rb, & @@ -7510,9 +7512,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.83483e-02_rb, 1.79043e-02_rb, 1.74778e-02_rb, 1.70678e-02_rb, 1.66735e-02_rb, & 1.62941e-02_rb, 1.59286e-02_rb, 1.55766e-02_rb, 1.52371e-02_rb, 1.49097e-02_rb, & 1.45937e-02_rb, 1.42885e-02_rb, 1.39936e-02_rb, 1.37085e-02_rb, 1.34327e-02_rb, & - 1.31659e-02_rb, 1.29075e-02_rb, 1.26571e-02_rb/) - absliq1(:,11) = (/ & -! band 11 + 1.31659e-02_rb, 1.29075e-02_rb, 1.26571e-02_rb/) + absliq1(:,11) = (/ & +! band 11 1.49438e-01_rb, 1.33535e-01_rb, 1.21542e-01_rb, 1.11743e-01_rb, 1.03263e-01_rb, & 9.55774e-02_rb, 8.83382e-02_rb, 8.12943e-02_rb, 7.42533e-02_rb, 6.70609e-02_rb, & 6.38761e-02_rb, 5.97788e-02_rb, 5.59841e-02_rb, 5.25318e-02_rb, 4.94132e-02_rb, & @@ -7524,9 +7526,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.84317e-02_rb, 1.79679e-02_rb, 1.75238e-02_rb, 1.70983e-02_rb, 1.66901e-02_rb, & 1.62983e-02_rb, 1.59219e-02_rb, 1.55599e-02_rb, 1.52115e-02_rb, 1.48761e-02_rb, & 1.45528e-02_rb, 1.42411e-02_rb, 1.39402e-02_rb, 1.36497e-02_rb, 1.33690e-02_rb, & - 1.30976e-02_rb, 1.28351e-02_rb, 1.25810e-02_rb/) - absliq1(:,12) = (/ & -! band 12 + 1.30976e-02_rb, 1.28351e-02_rb, 1.25810e-02_rb/) + absliq1(:,12) = (/ & +! band 12 3.71985e-02_rb, 3.88586e-02_rb, 3.99070e-02_rb, 4.04351e-02_rb, 4.04610e-02_rb, & 3.99834e-02_rb, 3.89953e-02_rb, 3.74886e-02_rb, 3.54551e-02_rb, 3.28870e-02_rb, & 3.32576e-02_rb, 3.22444e-02_rb, 3.12384e-02_rb, 3.02584e-02_rb, 2.93146e-02_rb, & @@ -7538,10 +7540,10 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.56842e-02_rb, 1.53840e-02_rb, 1.50920e-02_rb, 1.48080e-02_rb, 1.45318e-02_rb, & 1.42631e-02_rb, 1.40016e-02_rb, 1.37472e-02_rb, 1.34996e-02_rb, 1.32586e-02_rb, & 1.30239e-02_rb, 1.27954e-02_rb, 1.25728e-02_rb, 1.23559e-02_rb, 1.21445e-02_rb, & - 1.19385e-02_rb, 1.17376e-02_rb, 1.15417e-02_rb/) + 1.19385e-02_rb, 1.17376e-02_rb, 1.15417e-02_rb/) - absliq1(:,13) = (/ & -! band 13 + absliq1(:,13) = (/ & +! band 13 3.11868e-02_rb, 4.48357e-02_rb, 4.90224e-02_rb, 4.96406e-02_rb, 4.86806e-02_rb, & 4.69610e-02_rb, 4.48630e-02_rb, 4.25795e-02_rb, 4.02138e-02_rb, 3.78236e-02_rb, & 3.74266e-02_rb, 3.60384e-02_rb, 3.47074e-02_rb, 3.34434e-02_rb, 3.22499e-02_rb, & @@ -7553,9 +7555,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.62956e-02_rb, 1.59624e-02_rb, 1.56393e-02_rb, 1.53259e-02_rb, 1.50219e-02_rb, & 1.47268e-02_rb, 1.44404e-02_rb, 1.41624e-02_rb, 1.38925e-02_rb, 1.36302e-02_rb, & 1.33755e-02_rb, 1.31278e-02_rb, 1.28871e-02_rb, 1.26530e-02_rb, 1.24253e-02_rb, & - 1.22038e-02_rb, 1.19881e-02_rb, 1.17782e-02_rb/) - absliq1(:,14) = (/ & -! band 14 + 1.22038e-02_rb, 1.19881e-02_rb, 1.17782e-02_rb/) + absliq1(:,14) = (/ & +! band 14 1.58988e-02_rb, 3.50652e-02_rb, 4.00851e-02_rb, 4.07270e-02_rb, 3.98101e-02_rb, & 3.83306e-02_rb, 3.66829e-02_rb, 3.50327e-02_rb, 3.34497e-02_rb, 3.19609e-02_rb, & 3.13712e-02_rb, 3.03348e-02_rb, 2.93415e-02_rb, 2.83973e-02_rb, 2.75037e-02_rb, & @@ -7567,9 +7569,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.50936e-02_rb, 1.48146e-02_rb, 1.45429e-02_rb, 1.42782e-02_rb, 1.40203e-02_rb, & 1.37691e-02_rb, 1.35243e-02_rb, 1.32858e-02_rb, 1.30534e-02_rb, 1.28270e-02_rb, & 1.26062e-02_rb, 1.23909e-02_rb, 1.21810e-02_rb, 1.19763e-02_rb, 1.17766e-02_rb, & - 1.15817e-02_rb, 1.13915e-02_rb, 1.12058e-02_rb/) - absliq1(:,15) = (/ & -! band 15 + 1.15817e-02_rb, 1.13915e-02_rb, 1.12058e-02_rb/) + absliq1(:,15) = (/ & +! band 15 5.02079e-03_rb, 2.17615e-02_rb, 2.55449e-02_rb, 2.59484e-02_rb, 2.53650e-02_rb, & 2.45281e-02_rb, 2.36843e-02_rb, 2.29159e-02_rb, 2.22451e-02_rb, 2.16716e-02_rb, & 2.11451e-02_rb, 2.05817e-02_rb, 2.00454e-02_rb, 1.95372e-02_rb, 1.90567e-02_rb, & @@ -7581,9 +7583,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.20881e-02_rb, 1.19131e-02_rb, 1.17412e-02_rb, 1.15723e-02_rb, 1.14063e-02_rb, & 1.12434e-02_rb, 1.10834e-02_rb, 1.09264e-02_rb, 1.07722e-02_rb, 1.06210e-02_rb, & 1.04725e-02_rb, 1.03269e-02_rb, 1.01839e-02_rb, 1.00436e-02_rb, 9.90593e-03_rb, & - 9.77080e-03_rb, 9.63818e-03_rb, 9.50800e-03_rb/) - absliq1(:,16) = (/ & -! band 16 + 9.77080e-03_rb, 9.63818e-03_rb, 9.50800e-03_rb/) + absliq1(:,16) = (/ & +! band 16 5.64971e-02_rb, 9.04736e-02_rb, 8.11726e-02_rb, 7.05450e-02_rb, 6.20052e-02_rb, & 5.54286e-02_rb, 5.03503e-02_rb, 4.63791e-02_rb, 4.32290e-02_rb, 4.06959e-02_rb, & 3.74690e-02_rb, 3.52964e-02_rb, 3.33799e-02_rb, 3.16774e-02_rb, 3.01550e-02_rb, & @@ -7595,7 +7597,7 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.41532e-02_rb, 1.38734e-02_rb, 1.36028e-02_rb, 1.33410e-02_rb, 1.30875e-02_rb, & 1.28420e-02_rb, 1.26041e-02_rb, 1.23735e-02_rb, 1.21497e-02_rb, 1.19325e-02_rb, & 1.17216e-02_rb, 1.15168e-02_rb, 1.13177e-02_rb, 1.11241e-02_rb, 1.09358e-02_rb, & - 1.07525e-02_rb, 1.05741e-02_rb, 1.04003e-02_rb/) + 1.07525e-02_rb, 1.05741e-02_rb, 1.04003e-02_rb/) !jm not thread safe hvrclc = '$Revision: 1.8 $' @@ -7676,52 +7678,52 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & ! & ,ig, lay, ciwpmc(ig,lay), radice ! errflg = 1 ! return -! end if - ncbands = 16 - factor = (min(max(radice,5.0_rb),140._rb) - 2._rb)/3._rb - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) +! end if + ncbands = 16 + factor = (min(max(radice,5.0_rb),140._rb) - 2._rb)/3._rb + index = int(factor) + if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) abscoice(ig) = & & absice3(index,ib) + fint * & - & (absice3(index+1,ib) - (absice3(index,ib))) - abscosno(ig) = 0.0_rb - - endif - -!..Incorporate additional effects due to snow. - if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then - radsno = resnmc(lay) -! if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then + & (absice3(index+1,ib) - (absice3(index,ib))) + abscosno(ig) = 0.0_rb + + endif + +!..Incorporate additional effects due to snow. + if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then + radsno = resnmc(lay) +! if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then ! write(errmsg,'(a,i5,i5,f8.2,f8.2)' ) & -! & 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & -! & ,ig, lay, cswpmc(ig,lay), radsno +! & 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & +! & ,ig, lay, cswpmc(ig,lay), radsno ! errflg = 1 ! return -! end if - ncbands = 16 - factor = (min(max(radsno,5.0_rb),140.0_rb) - 2._rb)/3._rb - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) +! end if + ncbands = 16 + factor = (min(max(radsno,5.0_rb),140.0_rb) - 2._rb)/3._rb + index = int(factor) + if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) abscosno(ig) = & & absice3(index,ib) + fint * & - & (absice3(index+1,ib) - (absice3(index,ib))) - endif - - - -! Calculation of absorption coefficients due to water clouds. - if (clwpmc(ig,lay) .eq. 0.0_rb) then - abscoliq(ig) = 0.0_rb - - elseif (liqflag .eq. 0) then - abscoliq(ig) = absliq0 - - elseif (liqflag .eq. 1) then - radliq = relqmc(lay) + & (absice3(index+1,ib) - (absice3(index,ib))) + endif + + + +! Calculation of absorption coefficients due to water clouds. + if (clwpmc(ig,lay) .eq. 0.0_rb) then + abscoliq(ig) = 0.0_rb + + elseif (liqflag .eq. 0) then + abscoliq(ig) = absliq0 + + elseif (liqflag .eq. 1) then + radliq = relqmc(lay) ! if (radliq .lt. 2.5_rb .or. radliq .gt. 60._rb) then ! write(errmsg,'(a,i5,i5,f8.2,f8.2)' ) & !& 'ERROR: LIQUID EFFECTIVE SIZE OUT OF BOUNDS' & @@ -7729,27 +7731,27 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & ! errflg = 1 ! return ! end if - index = int(min(max(radliq,2.5_rb),60._rb) - 1.5_rb) - if (index .eq. 0) index = 1 - if (index .eq. 58) index = 57 - fint = radliq - 1.5_rb - float(index) - ib = ngb(ig) + index = int(min(max(radliq,2.5_rb),60._rb) - 1.5_rb) + if (index .eq. 0) index = 1 + if (index .eq. 58) index = 57 + fint = radliq - 1.5_rb - float(index) + ib = ngb(ig) abscoliq(ig) = & & absliq1(index,ib) + fint * & - & (absliq1(index+1,ib) - (absliq1(index,ib))) - endif - + & (absliq1(index+1,ib) - (absliq1(index,ib))) + endif + taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + & & clwpmc(ig,lay) * abscoliq(ig) + & - & cswpmc(ig,lay) * abscosno(ig) - - endif - endif - enddo - enddo - - end subroutine cldprmc - + & cswpmc(ig,lay) * abscosno(ig) + + endif + endif + enddo + enddo + + end subroutine cldprmc + !> @} !........................................!$ end module rrtmg_lw !$ diff --git a/physics/Radiation/RRTMG/radlw_main.meta b/physics/Radiation/RRTMG/radlw_main.meta index ec90cc533..65d977921 100644 --- a/physics/Radiation/RRTMG/radlw_main.meta +++ b/physics/Radiation/RRTMG/radlw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw type = scheme - dependencies = ../../hooks/machine.F,../mersenne_twister.f,../../hooks/physcons.F90,radlw_datatb.f,radlw_param.f + dependencies = ../../hooks/machine.F,../mersenne_twister.f,radlw_datatb.f,radlw_param.f ######################################################################## [ccpp-arg-table] @@ -428,6 +428,46 @@ type = real kind = kind_phys intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amd] + standard_name = molecular_weight_of_dry_air + long_name = molecular weight of dry air + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amw] + standard_name = molecular_weight_of_water_vapor + long_name = molecular weight of water vapor + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amo3] + standard_name = molecular_weight_of_ozone + long_name = molecular weight of ozone + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_avgd] + standard_name = avogadro_consant + long_name = Avogadro constant + units = mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/Radiation/RRTMG/radsw_main.F90 b/physics/Radiation/RRTMG/radsw_main.F90 index d21c07d5a..6bcc89c62 100644 --- a/physics/Radiation/RRTMG/radsw_main.F90 +++ b/physics/Radiation/RRTMG/radsw_main.F90 @@ -90,7 +90,6 @@ ! ! ! external modules referenced: ! ! ! -! 'module physcons' ! ! 'mersenne_twister' ! ! ! ! compilation sequence is: ! @@ -299,12 +298,10 @@ !!!!! end descriptions !!!!! !!!!! ============================================================== !!!!! -!> This module contains the CCPP-compliant NCEP's modifications of the -!! rrtmg-sw radiation code from aer inc. - module rrtmg_sw +!> This module contains the CCPP-compliant NCEP's modifications of the +!! rrtmg-sw radiation code from aer inc. + module rrtmg_sw ! - use physcons, only : con_g, con_cp, con_avgd, con_amd, & - & con_amw, con_amo3 use machine, only : rb => kind_phys, im => kind_io4, & & kind_phys, kind_dbl_prec @@ -345,10 +342,6 @@ module rrtmg_sw real (kind=kind_phys), parameter :: f_zero = 0.0 real (kind=kind_phys), parameter :: f_one = 1.0 -! \name atomic weights for conversion from mass to volume mixing ratios - real (kind=kind_phys), parameter :: amdw = con_amd/con_amw - real (kind=kind_phys), parameter :: amdo3 = con_amd/con_amo3 - ! \name band indices integer, dimension(nblow:nbhgh) :: nspa, nspb ! band index for sfc flux @@ -506,7 +499,9 @@ subroutine rrtmg_sw_run & & HSW0,HSWB,FLXPRF,FDNCMP, & ! --- optional & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & & cld_rwp,cld_ref_rain, cld_swp, cld_ref_snow, & - & cld_od, cld_ssa, cld_asy, errmsg, errflg & + & cld_od, cld_ssa, cld_asy, & + & con_g, con_avgd, con_amd, con_amw, con_amo3, & + & errmsg, errflg & & ) ! ==================== defination of variables ==================== ! @@ -596,7 +591,7 @@ subroutine rrtmg_sw_run & ! iovr_max - choice of cloud-overlap: maximum ! ! iovr_dcorr - choice of cloud-overlap: decorrelation length ! ! iovr_exp - choice of cloud-overlap: exponential ! -! iovr_exprand - choice of cloud-overlap: exponential random ! +! iovr_exprand - choice of cloud-overlap: exponential random ! ! ! ! output variables: ! ! hswc (npts,nlay): total sky heating rates (k/sec or k/day) ! @@ -699,8 +694,8 @@ subroutine rrtmg_sw_run & real (kind=kind_phys), dimension(:,:), intent(in) :: & & plyr, tlyr, qlyr, olyr, dzlyr, delpin - real (kind=kind_phys),dimension(:),intent(in):: sfcalb_nir_dir - real (kind=kind_phys),dimension(:),intent(in):: sfcalb_nir_dif + real (kind=kind_phys),dimension(:),intent(in):: sfcalb_nir_dir + real (kind=kind_phys),dimension(:),intent(in):: sfcalb_nir_dif real (kind=kind_phys),dimension(:),intent(in):: sfcalb_uvis_dir real (kind=kind_phys),dimension(:),intent(in):: sfcalb_uvis_dif @@ -719,6 +714,8 @@ subroutine rrtmg_sw_run & & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & & cld_rwp, cld_ref_rain, cld_swp, cld_ref_snow, & & cld_od, cld_ssa, cld_asy + real(kind=kind_phys), intent(in) :: con_g, con_avgd, con_amd + real(kind=kind_phys), intent(in) :: con_amw, con_amo3 real(kind=kind_phys),dimension(:,:,:),intent(in)::aeraod real(kind=kind_phys),dimension(:,:,:),intent(in)::aerssa @@ -790,6 +787,9 @@ subroutine rrtmg_sw_run & integer :: i, ib, ipt, j1, k, kk, laytrop, mb, ig integer :: inflgsw, iceflgsw, liqflgsw integer :: irng, permuteseed +! \name atomic weights for conversion from mass to volume mixing ratios + real (kind=kind_phys) :: amdw + real (kind=kind_phys) :: amdo3 ! !===> ... begin here ! @@ -797,6 +797,9 @@ subroutine rrtmg_sw_run & errmsg = '' errflg = 0 + ! Set atomic weights + amdw = con_amd/con_amw + amdo3 = con_amd/con_amo3 ! Select cloud liquid and ice optics parameterization options ! For passing in cloud optical properties directly: ! inflgsw = 0 @@ -1389,7 +1392,8 @@ end subroutine rrtmg_sw_run !----------------------------------- subroutine rswinit( me, rad_hr_units, inc_minor_gas, iswcliq, & isubcsw, iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr,& - iovr_exp, iovr_exprand, iswmode, errflg, errmsg ) + iovr_exp, iovr_exprand, iswmode, con_g, con_cp, & + errflg, errmsg ) ! =================== program usage description =================== ! ! ! @@ -1447,6 +1451,7 @@ subroutine rswinit( me, rad_hr_units, inc_minor_gas, iswcliq, & iswmode, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & iovr_exp, iovr_exprand logical, intent(in) :: inc_minor_gas + real(kind=kind_phys), intent(in) :: con_cp, con_g ! --- outputs: character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -1513,7 +1518,7 @@ subroutine rswinit( me, rad_hr_units, inc_minor_gas, iswcliq, & heatfac = con_g * 1.0e-2 / con_cp ! (in k/second) endif -!> - Define exponential lookup tables for transmittance. +!> - Define exponential lookup tables for transmittance. ! tau is computed as a function of the \a tau transition function, and ! transmittance is calculated as a function of tau. all tables ! are computed at intervals of 0.0001. the inverse of the @@ -2153,13 +2158,13 @@ subroutine mcica_subcol & ! For exponential cloud overlap, the correlation is applied across layers ! without regard to the configuration of clear and cloudy layers. -! For exponential-random cloud overlap, a new exponential transition is -! performed within each group of adjacent cloudy layers and blocks of -! cloudy layers with clear layers between them are correlated randomly. +! For exponential-random cloud overlap, a new exponential transition is +! performed within each group of adjacent cloudy layers and blocks of +! cloudy layers with clear layers between them are correlated randomly. ! -! NOTE: The code below is identical for case (4) and (5) because the -! distinction in the vertical correlation between EXP and ER is already -! built into the specification of alpha (in subroutine get_alpha_exper). +! NOTE: The code below is identical for case (4) and (5) because the +! distinction in the vertical correlation between EXP and ER is already +! built into the specification of alpha (in subroutine get_alpha_exper). ! --- setup 2 sets of random numbers @@ -2184,7 +2189,7 @@ subroutine mcica_subcol & enddo ! --- then working upward from the surface: -! if a random number (from an independent set: cdfun2) is smaller than +! if a random number (from an independent set: cdfun2) is smaller than ! alpha, then use the previous layer's number, otherwise use a new random ! number (keep the originally assigned one in cdfunc for that layer). @@ -2674,11 +2679,11 @@ subroutine spcvrtc & zasy3 = 0.75 * zasy1 !> - Perform general two-stream expressions: -!!\n control parameters provided by host-model -!!\n iswmode - control flag for 2-stream transfer schemes -!!\n = 1 delta-eddington (joseph et al., 1976) -!!\n = 2 pifm (zdunkowski et al., 1980) -!!\n = 3 discrete ordinates (liou, 1973) +!!\n control parameters provided by host-model +!!\n iswmode - control flag for 2-stream transfer schemes +!!\n = 1 delta-eddington (joseph et al., 1976) +!!\n = 2 pifm (zdunkowski et al., 1980) +!!\n = 3 discrete ordinates (liou, 1973) if ( iswmode == 1 ) then zgam1 = 1.75 - zssa1 * (f_one + zasy3) zgam2 =-0.25 + zssa1 * (f_one - zasy3) @@ -3269,7 +3274,7 @@ subroutine spcvrtm & ! iswmode - control flag for 2-stream transfer schemes ! ! = 1 delta-eddington (joseph et al., 1976) ! ! = 2 pifm (zdunkowski et al., 1980) ! -! = 3 discrete ordinates (liou, 1973) ! +! = 3 discrete ordinates (liou, 1973) ! ! ! ! output variables: ! ! fxupc - real, tot sky upward flux nlp1*nbdsw ! @@ -3468,10 +3473,10 @@ subroutine spcvrtm & zasy3 = 0.75 * zasy1 !> - Perform general two-stream expressions: -!!\n control parameters provided by host-model -!!\n iswmode - control flag for 2-stream transfer schemes -!!\n = 1 delta-eddington (joseph et al., 1976) -!!\n = 2 pifm (zdunkowski et al., 1980) +!!\n control parameters provided by host-model +!!\n iswmode - control flag for 2-stream transfer schemes +!!\n = 1 delta-eddington (joseph et al., 1976) +!!\n = 2 pifm (zdunkowski et al., 1980) !!\n = 3 discrete ordinates (liou, 1973) if ( iswmode == 1 ) then zgam1 = 1.75 - zssa1 * (f_one + zasy3) @@ -3709,7 +3714,7 @@ subroutine spcvrtm & endif zgam4 = f_one - zgam3 -!> - Compute homogeneous reflectance and transmittance for both convertive +!> - Compute homogeneous reflectance and transmittance for both convertive !! and non-convertive scattering. if ( zssaw >= zcrit ) then ! for conservative scattering diff --git a/physics/Radiation/RRTMG/radsw_main.meta b/physics/Radiation/RRTMG/radsw_main.meta index 55b7c29b3..0ddef91f9 100644 --- a/physics/Radiation/RRTMG/radsw_main.meta +++ b/physics/Radiation/RRTMG/radsw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw type = scheme - dependencies = ../../hooks/machine.F,../mersenne_twister.f,../../hooks/physcons.F90,radsw_datatb.f,radsw_param.f + dependencies = ../../hooks/machine.F,../mersenne_twister.f,radsw_datatb.f,radsw_param.f ######################################################################## [ccpp-arg-table] @@ -497,6 +497,46 @@ type = real kind = kind_phys intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_avgd] + standard_name = avogadro_consant + long_name = Avogadro constant + units = mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amd] + standard_name = molecular_weight_of_dry_air + long_name = molecular weight of dry air + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amw] + standard_name = molecular_weight_of_water_vapor + long_name = molecular weight of water vapor + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amo3] + standard_name = molecular_weight_of_ozone + long_name = molecular weight of ozone + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/Radiation/radiation_surface.f b/physics/Radiation/radiation_surface.f index 3f62b66fc..b7afcdda2 100644 --- a/physics/Radiation/radiation_surface.f +++ b/physics/Radiation/radiation_surface.f @@ -40,7 +40,6 @@ ! external modules referenced: ! ! ! ! 'module machine' in 'machine.f' ! -! 'module physcons' in 'physcons.f' ! ! 'module module_iounitdef' in 'iounitdef.f' ! ! ! ! ! @@ -101,7 +100,7 @@ !!\version NCEP-Radiation_surface v5.1 Nov 2012 !> This module sets up surface albedo for SW radiation and surface -!! emissivity for LW radiation. +!! emissivity for LW radiation. module module_radiation_surface ! use machine, only : kind_phys @@ -428,7 +427,7 @@ subroutine setalb & real (kind=kind_phys), dimension(:), intent(in) :: & & fracl, fraco, fraci real (kind=kind_phys), dimension(:),intent(inout) :: & - & lsmalbdvis, lsmalbdnir, lsmalbivis, lsmalbinir + & lsmalbdvis, lsmalbdnir, lsmalbivis, lsmalbinir logical, dimension(:), intent(in) :: & & icy @@ -539,7 +538,7 @@ subroutine setalb & fsno0 = sncovr(i) ! snow fraction on land - fsno1 = f_one - fsno0 + fsno1 = f_one - fsno0 flnd0 = min(f_one, facsf(i)+facwf(i)) flnd = flnd0 * fsno1 ! snow-free fraction fsno = f_one - flnd ! snow-covered fraction @@ -604,7 +603,7 @@ subroutine setalb & !-- ice albedo !tgs: this part of the code needs the input from the ice - ! model. Otherwise it uses the backup albedo computation + ! model. Otherwise it uses the backup albedo computation ! from ialbflg = 1. if (icy(i)) then !-- Computation of ice albedo @@ -641,7 +640,7 @@ subroutine setalb & asevb_ice = asevd_ice asenb_ice = asend_ice - if (fsno0 > f_zero) then + if (fsno0 > f_zero) then ! Snow on ice dtgd = max(f_zero, min(5.0, (con_ttp-tisfc(i)) )) b1 = 0.03 * dtgd @@ -671,7 +670,7 @@ subroutine setalb & asevb_ice = 0.70 asenb_ice = 0.65 endif ! end icy - + !-- Composite mean surface albedo from land, open water and !-- ice fractions sfcalb(i,1) = min(0.99,max(0.01,lsmalbdnir(i)))*fracl(i) & ! direct beam NIR @@ -726,7 +725,7 @@ end subroutine setalb !! or -pi -> +pi ranges !!\param xlat latitude in radiance, default to pi/2 -> !! -pi/2 range, otherwise see in-line comment -!!\param slmsk landmask: sea/land/ice =0/1/2 +!!\param slmsk landmask: sea/land/ice =0/1/2 !!\param snodl snow depth water equivalent in mm land !!\param snodi snow depth water equivalent in mm ice !!\param sncovr snow cover over land @@ -992,7 +991,7 @@ subroutine setemis & endif ! lsm check endif ! icy - !-- land emissivity + !-- land emissivity !-- from Noah MP or RUC lsms sfcemis_land = semis_lnd(i) ! albedo with snow effect from LSM diff --git a/physics/SFC_Layer/MYNN/module_sf_mynn.F90 b/physics/SFC_Layer/MYNN/module_sf_mynn.F90 index cb066dc31..8df7f585b 100644 --- a/physics/SFC_Layer/MYNN/module_sf_mynn.F90 +++ b/physics/SFC_Layer/MYNN/module_sf_mynn.F90 @@ -63,18 +63,6 @@ MODULE module_sf_mynn !NOTE: This code was primarily tested in combination with the RUC LSM. ! Performance with the Noah (or other) LSM is relatively unknown. !------------------------------------------------------------------- -!Include host model constants - use physcons, only : cp => con_cp, & !=7*Rd/2 - & grav => con_g, & !=9.81 - & Rd => con_rd, & !=287. - & Rv => con_rv, & !=461.6 -! & cpv => con_cvap, & !=4*Rv - & rovcp => con_rocp, & !=Rd/cp - & xlv => con_hvap, & !2.5e6 - & xlf => con_hfus, & !3.5e5 - & ep1 => con_fvirt, & !Rv/Rd - 1 - & ep2 => con_eps !Rd/Rv - !use kind_phys for real-types use machine , only : kind_phys @@ -82,9 +70,19 @@ MODULE module_sf_mynn IMPLICIT NONE !------------------------------------------------------------------- !Drive and/or define more constant: - real(kind_phys), parameter :: ep3 = 1.-ep2 - real(kind_phys), parameter :: g_inv = 1.0/grav - real(kind_phys), parameter :: rvovrd = Rv/Rd + real(kind_phys) :: cp = 1.0E30_kind_phys + real(kind_phys) :: grav = 1.0E30_kind_phys + real(kind_phys) :: Rd = 1.0E30_kind_phys + real(kind_phys) :: Rv = 1.0E30_kind_phys + real(kind_phys) :: rovcp = 1.0E30_kind_phys + real(kind_phys) :: xlv = 1.0E30_kind_phys + real(kind_phys) :: xlf = 1.0E30_kind_phys + real(kind_phys) :: ep1 = 1.0E30_kind_phys + real(kind_phys) :: ep2 = 1.0E30_kind_phys + real(kind_phys) :: ep3 = 1.0E30_kind_phys + real(kind_phys) :: g_inv = 1.0E30_kind_phys + real(kind_phys) :: rvovrd = 1.0E30_kind_phys + real(kind_phys), parameter :: wmin = 0.1 ! Minimum wind speed real(kind_phys), parameter :: karman = 0.4 real(kind_phys), parameter :: SVP1 = 0.6112 @@ -112,6 +110,29 @@ MODULE module_sf_mynn CONTAINS + subroutine sf_mynn_init(con_cp, con_g, con_rd, con_rv, & + con_rocp, con_hvap, con_hfus, con_fvirt, & + con_eps) + real(kind_phys), intent(in) :: con_cp, con_g, con_rd, con_rv + real(kind_phys), intent(in) :: con_rocp, con_hvap, con_hfus, con_fvirt + real(kind_phys), intent(in) :: con_eps +!Include host model constants + cp = con_cp + grav = con_g + Rd = con_rd + Rv = con_rv + rovcp = con_rocp + xlv = con_hvap + xlf = con_hfus + ep1 = con_fvirt + ep2 = con_eps + + ep3 = 1.-ep2 + g_inv = 1.0/grav + rvovrd = Rv/Rd + end subroutine sf_mynn_init + + !------------------------------------------------------------------- !------------------------------------------------------------------- !>\ingroup mynn_sfc @@ -3156,12 +3177,12 @@ SUBROUTINE znot_m_v6(uref, znotm) END SUBROUTINE znot_m_v6 !-------------------------------------------------------------------- !>\ingroup mynn_sfc -!> Calculate scalar roughness over water with input 10-m wind +!> Calculate scalar roughness over water with input 10-m wind !! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm !! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF !! !!\author Bin Liu, NOAA/NCEP/EMC 2017 -! +! ! uref(m/s) : wind speed at 10-m height ! znott(meter): scalar roughness scale over water SUBROUTINE znot_t_v6(uref, znott) @@ -3226,7 +3247,7 @@ END SUBROUTINE znot_t_v6 !! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) !! For high winds, try to fit available observational data !! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed -!! +!! !!\author Bin Liu, NOAA/NCEP/EMC 2018 SUBROUTINE znot_m_v7(uref, znotm) @@ -3275,7 +3296,7 @@ END SUBROUTINE znot_m_v7 !! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm !! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF !! To be compatible with the slightly decreased Cd for higher wind speed -!! +!! !!\author Bin Liu, NOAA/NCEP/EMC 2018 SUBROUTINE znot_t_v7(uref, znott) diff --git a/physics/SFC_Layer/MYNN/mynnsfc_wrapper.F90 b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.F90 index 9239dcf4e..43344947a 100644 --- a/physics/SFC_Layer/MYNN/mynnsfc_wrapper.F90 +++ b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.F90 @@ -19,9 +19,14 @@ MODULE mynnsfc_wrapper !! \htmlinclude mynnsfc_wrapper_init.html !! subroutine mynnsfc_wrapper_init(do_mynnsfclay, & - & errmsg, errflg) + con_cp, con_g, con_rd, con_rv, & + con_rocp, con_hvap, con_hfus, con_fvirt, & + con_eps, errmsg, errflg) logical, intent(in) :: do_mynnsfclay + real(kind_phys), intent(in) :: con_cp, con_g, con_rd, con_rv + real(kind_phys), intent(in) :: con_rocp, con_hvap, con_hfus, con_fvirt + real(kind_phys), intent(in) :: con_eps character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -29,12 +34,17 @@ subroutine mynnsfc_wrapper_init(do_mynnsfclay, & errmsg = '' errflg = 0 + ! Initialize sf_mynn + call sf_mynn_init(con_cp, con_g, con_rd, con_rv, & + con_rocp, con_hvap, con_hfus, con_fvirt, & + con_eps) + ! Consistency checks if (.not. do_mynnsfclay) then write(errmsg,fmt='(*(a))') 'Logic error: do_mynnsfclay = .false.' errflg = 1 return - end if + end if ! initialize tables for psih and psim (stable and unstable) CALL PSI_INIT(psi_opt,errmsg,errflg) @@ -70,6 +80,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) & qsfc_wat, qsfc_lnd, qsfc_ice, & !intent(in) & snowh_lnd, snowh_ice, & !intent(in) + & con_g, con_cp, & !intent(in) & znt_wat, znt_lnd, znt_ice, & !intent(inout) & ust_wat, ust_lnd, ust_ice, & !intent(inout) & cm_wat, cm_lnd, cm_ice, & !intent(inout) @@ -94,8 +105,6 @@ SUBROUTINE mynnsfc_wrapper_run( & ! should be moved to inside the mynn: use machine , only : kind_phys - use physcons, only : cp => con_cp, & - & grav => con_g ! USE module_sf_mynn, only : SFCLAY_mynn !tgs - info on iterations: @@ -111,8 +120,6 @@ SUBROUTINE mynnsfc_wrapper_run( & !------------------------------------------------------------------- implicit none !------------------------------------------------------------------- -! --- derive more constant parameters: - real(kind_phys), parameter :: g_inv=1./grav character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -151,7 +158,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & & snowh_lnd, snowh_ice - + real(kind_phys), intent(in) :: con_cp, con_g real(kind_phys), dimension(:), intent(inout) :: & & znt_wat, znt_lnd, znt_ice, & & ust_wat, ust_lnd, ust_ice, & @@ -186,6 +193,7 @@ SUBROUTINE mynnsfc_wrapper_run( & real(kind_phys), dimension(im,levs) :: & & dz, th, qv + real(kind_phys) :: cp, grav, g_inv !MYNN-1D INTEGER :: k, i @@ -207,6 +215,10 @@ SUBROUTINE mynnsfc_wrapper_run( & errmsg = '' errflg = 0 + cp = con_cp + grav = con_g + g_inv=1./grav + ! if (lprnt) then ! write(0,*)"==============================================" ! write(0,*)"in mynn surface layer wrapper..." @@ -307,7 +319,7 @@ SUBROUTINE mynnsfc_wrapper_run( & z0pert=z0pert,ztpert=ztpert, & !intent(in) redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) itimestep=itimestep,iter=iter,flag_iter=flag_iter, & - flag_restart=flag_restart, & + flag_restart=flag_restart, & wet=wet, dry=dry, icy=icy, & !intent(in) tskin_wat=tskin_wat, tskin_lnd=tskin_lnd, tskin_ice=tskin_ice, & !intent(in) tsurf_wat=tsurf_wat, tsurf_lnd=tsurf_lnd, tsurf_ice=tsurf_ice, & !intent(in) diff --git a/physics/SFC_Layer/MYNN/mynnsfc_wrapper.meta b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.meta index 89bf1d840..9053222ed 100644 --- a/physics/SFC_Layer/MYNN/mynnsfc_wrapper.meta +++ b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mynnsfc_wrapper type = scheme - dependencies = ../../hooks/machine.F,../../hooks/physcons.F90,module_sf_mynn.F90 + dependencies = ../../hooks/machine.F,module_sf_mynn.F90 ######################################################################## [ccpp-arg-table] @@ -14,6 +14,78 @@ dimensions = () type = logical intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rocp] + standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure + long_name = (rd/cp) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -398,6 +470,22 @@ type = real kind = kind_phys intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in [znt_wat] standard_name = surface_roughness_length_over_water long_name = surface roughness length over water (temporary use as interstitial) diff --git a/physics/SFC_Layer/UFS/module_nst_model.f90 b/physics/SFC_Layer/UFS/module_nst_model.f90 index 74c75924b..0331e3c7e 100644 --- a/physics/SFC_Layer/UFS/module_nst_model.f90 +++ b/physics/SFC_Layer/UFS/module_nst_model.f90 @@ -18,7 +18,7 @@ module nst_module use module_nst_parameters , only : eps_sfs, niter_z_w, niter_conv, niter_sfs, ri_c use module_nst_parameters , only : ri_g, omg_m, omg_sh, kw => tc_w, visw, t0k, cp_w use module_nst_parameters , only : z_c_max, z_c_ini, ustar_a_min, delz, exp_const - use module_nst_parameters , only : rad2deg, const_rot, tw_max, sst_max + use module_nst_parameters , only : const_rot, tw_max, sst_max use module_nst_parameters , only : zero, one use module_nst_water_prop , only : sw_rad_skin, sw_ps_9b, sw_ps_9b_aw @@ -34,13 +34,13 @@ module nst_module !>\ingroup gfs_nst_main_mod !! This subroutine contains the module of diurnal thermocline layer model. subroutine dtm_1p(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & - alpha,beta,alon,sinlat,soltim,grav,le,d_conv, & + alpha,beta,alon,sinlat,soltim,grav,le,d_conv,con_pi, & xt,xs,xu,xv,xz,xzts,xtts) integer, intent(in) :: kdt real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& hl_ts,rho,alpha,beta,alon,sinlat,soltim,& - grav,le,d_conv + grav,le,d_conv,con_pi real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts ! local variables @@ -86,7 +86,7 @@ subroutine dtm_1p(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & ! forward the system one time step ! call eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & - beta,alon,sinlat,soltim,grav,le,d_conv, & + beta,alon,sinlat,soltim,grav,le,d_conv,con_pi, & xt,xs,xu,xv,xz,xzts,xtts) endif ! if ( xt == 0 ) then @@ -95,7 +95,7 @@ end subroutine dtm_1p !>\ingroup gfs_nst_main_mod !! This subroutine integrates one time step with modified Euler method. subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & - beta,alon,sinlat,soltim,grav,le,d_conv, & + beta,alon,sinlat,soltim,grav,le,d_conv,con_pi, & xt,xs,xu,xv,xz,xzts,xtts) ! @@ -104,7 +104,7 @@ subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, integer, intent(in) :: kdt real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts, & hl_ts,rho,alpha,beta,alon,sinlat,soltim, & - grav,le,d_conv + grav,le,d_conv,con_pi real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts ! local variables real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0,xzts0,xtts0 @@ -113,6 +113,7 @@ subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, real(kind=kind_phys) :: xt2,xs2,xu2,xv2,xz2,xzts2,xtts2 real(kind=kind_phys) :: dzw,drho,fc real(kind=kind_phys) :: alat,speed + real(kind=kind_phys) :: rad2deg ! logical lprnt ! @@ -157,6 +158,7 @@ subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, xzts0 = xzts speed = max(1.0e-8, xu0*xu0+xv0*xv0) + rad2deg = 180./con_pi alat = asin(sinlat)*rad2deg fc = const_rot*sinlat diff --git a/physics/SFC_Layer/UFS/module_nst_parameters.f90 b/physics/SFC_Layer/UFS/module_nst_parameters.f90 index 984335cc8..3e40ffe81 100644 --- a/physics/SFC_Layer/UFS/module_nst_parameters.f90 +++ b/physics/SFC_Layer/UFS/module_nst_parameters.f90 @@ -14,29 +14,16 @@ module module_nst_parameters use machine, only : kind_phys ! ! air constants and coefficients from the atmospehric model - use physcons, only: & - eps => con_eps & !< con_rd/con_rv (nd) - ,cp_a => con_cp & !< spec heat air @p (j/kg/k) - ,epsm1 => con_epsm1 & !< eps - 1 (nd) - ,hvap => con_hvap & !< lat heat h2o cond (j/kg) - ,sigma_r => con_sbc & !< stefan-boltzmann (w/m2/k4) - ,grav => con_g & !< acceleration due to gravity (kg/m/s^2) - ,omega => con_omega & !< ang vel of earth (1/s) - ,rvrdm1 => con_fvirt & !< con_rv/con_rd-1. (nd) - ,rd => con_rd & !< gas constant air (j/kg/k) - ,rocp => con_rocp & !< r/cp - ,pi => con_pi - implicit none private - public :: sigma_r + ! public :: sigma_r public :: zero, one, half public :: niter_conv, niter_z_w, niter_sfs public :: z_w_max, z_w_min, z_w_ini, z_c_max, z_c_ini, eps_z_w, eps_conv, eps_sfs public :: ri_c, ri_g, omg_m, omg_sh, tc_w, visw, cp_w, t0k, ustar_a_min, delz, exp_const - public :: rad2deg, const_rot, tw_max, sst_max, solar_time_6am, tau_min, wd_max + public :: const_rot, tw_max, sst_max, solar_time_6am, tau_min, wd_max real(kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, half = 0.5_kind_phys ! @@ -79,8 +66,6 @@ module module_nst_parameters ,novalue = 0 & ,smallnumber = 1.e-6 & ,timestep_oc = sec_in_day/8. & !< time step in the ocean model (3 hours) - ,radian = 2.*pi/180. & - ,rad2deg = 180./pi & ,cp_w = 4000. & !< specific heat water (j/kg/k ) ,rho0_w = 1022.0 & !< density water (kg/m3 ) (or 1024.438) ,vis_w = 1.e-6 & !< kinematic viscosity water (m2/s ) diff --git a/physics/SFC_Layer/UFS/sfc_diag.f b/physics/SFC_Layer/UFS/sfc_diag.f index 4c019f433..fbd91ccaa 100644 --- a/physics/SFC_Layer/UFS/sfc_diag.f +++ b/physics/SFC_Layer/UFS/sfc_diag.f @@ -12,7 +12,7 @@ module sfc_diag !> @{ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & lsm,lsm_ruc,grav,cp,eps,epsm1,con_rocp, & - & con_karman, & + & con_karman,con_t0c, & & shflx,cdq,wind, & & usfco,vsfco,use_oceanuv, & & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & @@ -24,7 +24,6 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! use machine , only : kind_phys, kind_dbl_prec use funcphys, only : fpvs - use physcons, only : con_t0c implicit none ! integer, intent(in) :: im, lsm, lsm_ruc, iopt_lake, iopt_lake_clm @@ -34,7 +33,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics logical, intent(in) :: diag_log ! Flag for 2-m log diagnostics under stable conditions real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,con_rocp - real(kind=kind_phys), intent(in) :: con_karman + real(kind=kind_phys), intent(in) :: con_karman, con_t0c real(kind=kind_phys), dimension(:), intent( in) :: & & zf, ps, u1, v1, t1, q1, ust, tskin, & & usfco, vsfco, & diff --git a/physics/SFC_Layer/UFS/sfc_diag.meta b/physics/SFC_Layer/UFS/sfc_diag.meta index e556e03ba..efbeeb793 100644 --- a/physics/SFC_Layer/UFS/sfc_diag.meta +++ b/physics/SFC_Layer/UFS/sfc_diag.meta @@ -2,7 +2,7 @@ name = sfc_diag type = scheme dependencies_path = ../../ - dependencies = tools/funcphys.f90,hooks/machine.F,hooks/physcons.F90 + dependencies = tools/funcphys.f90,hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -92,6 +92,14 @@ dimensions = () type = real intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degrees Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [zf] standard_name = height_above_ground_at_lowest_model_layer long_name = layer 1 height above ground (not MSL) diff --git a/physics/SFC_Layer/UFS/sfc_nst.f90 b/physics/SFC_Layer/UFS/sfc_nst.f90 index eb84aa352..e1c0ec4ef 100644 --- a/physics/SFC_Layer/UFS/sfc_nst.f90 +++ b/physics/SFC_Layer/UFS/sfc_nst.f90 @@ -7,8 +7,8 @@ module sfc_nst use machine , only : kind_phys, kp => kind_phys use funcphys , only : fpvs use module_nst_parameters , only : one, zero, half - use module_nst_parameters , only : t0k, cp_w, omg_m, omg_sh, sigma_r, solar_time_6am, sst_max - use module_nst_parameters , only : ri_c, z_w_max, delz, wd_max, rad2deg, const_rot, tau_min, tw_max + use module_nst_parameters , only : t0k, cp_w, omg_m, omg_sh, solar_time_6am, sst_max + use module_nst_parameters , only : ri_c, z_w_max, delz, wd_max, const_rot, tau_min, tw_max use module_nst_water_prop , only : get_dtzm_point, density, rhocoef, grv, sw_ps_9b use nst_module , only : cool_skin, dtm_1p, cal_w, cal_ttop, convdepth, dtm_1p_fca use nst_module , only : dtm_1p_tla, dtm_1p_mwa, dtm_1p_mda, dtm_1p_mta, dtl_reset @@ -244,6 +244,7 @@ subroutine sfc_nst_run & real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, & ws10cr=30., conlf=7.2e-9, consf=6.4e-8 real (kind=kind_phys) :: windrel + real (kind=kind_phys) :: rad2deg ! !====================================================================================================== ! Initialize CCPP error handling variables @@ -352,6 +353,7 @@ subroutine sfc_nst_run & ! zsea1 = 0.001_kp*real(nstf_name4) zsea2 = 0.001_kp*real(nstf_name5) + rad2deg = 180./pi !> - Call module_nst_water_prop::density() to compute sea water density. !> - Call module_nst_water_prop::rhocoef() to compute thermal expansion @@ -449,7 +451,7 @@ subroutine sfc_nst_run & !> - Call the diurnal thermocline layer model dtm_1p(). call dtm_1p(kdt,timestep,rich,taux,tauy,nswsfc(i), & f_nsol,sss,sep,q_ts,hl_ts,rho_w,alpha,beta,alon, & - sinlat(i),soltim,grav,le,d_conv(i), & + sinlat(i),soltim,grav,le,d_conv(i),pi, & xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) ! if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i) diff --git a/physics/SFC_Models/Lake/Flake/flake_driver.F90 b/physics/SFC_Models/Lake/Flake/flake_driver.F90 index b5d54009a..8a513db77 100644 --- a/physics/SFC_Models/Lake/Flake/flake_driver.F90 +++ b/physics/SFC_Models/Lake/Flake/flake_driver.F90 @@ -28,7 +28,7 @@ SUBROUTINE flake_driver_run ( & lflx, gflx, ustar, qsfc, ch, cm, chh, cmm, & h_ML, t_wML, t_mnw, H_B, T_B, t_bot1, & t_bot2, c_t, T_snow, T_ice, tsurf_ice, & - errmsg, errflg ) + errmsg, errflg ) !============================================================================== ! @@ -42,10 +42,6 @@ SUBROUTINE flake_driver_run ( & ! use flake_parameters use machine , only : kind_phys ! use funcphys, only : fpvs -! use physcons, only : grav => con_g, cp => con_cp, & -! & hvap => con_hvap, rd => con_rd, & -! & eps => con_eps, epsm1 => con_epsm1, & -! & rvrdm1 => con_fvirt !============================================================================== @@ -112,13 +108,13 @@ SUBROUTINE flake_driver_run ( & depth_w , & ! The lake depth [m] fetch_in , & ! Typical wind fetch [m] depth_bs_in , & ! Depth of the thermally active layer of the bottom sediments [m] - T_bs_in , & ! Temperature at the outer edge of + T_bs_in , & ! Temperature at the outer edge of ! the thermally active layer of the bottom sediments [K] par_Coriolis , & ! The Coriolis parameter [s^{-1}] del_time ! The model time step [s] REAL (KIND = kind_phys) :: & - T_snow_in , & ! Temperature at the air-snow interface [K] + T_snow_in , & ! Temperature at the air-snow interface [K] T_ice_in , & ! Temperature at the snow-ice or air-ice interface [K] T_mnw_in , & ! Mean temperature of the water column [K] T_wML_in , & ! Mixed-layer temperature [K] @@ -129,14 +125,14 @@ SUBROUTINE flake_driver_run ( & h_ice_in , & ! Ice thickness [m] h_ML_in , & ! Thickness of the mixed-layer [m] H_B1_in , & ! Thickness of the upper layer of bottom sediments [m] - T_sfc_in , & ! Surface temperature at the previous time step [K] + T_sfc_in , & ! Surface temperature at the previous time step [K] ch_in , & cm_in , & albedo_water , & water_extinc REAL (KIND = kind_phys) :: & - T_snow_out , & ! Temperature at the air-snow interface [K] + T_snow_out , & ! Temperature at the air-snow interface [K] T_ice_out , & ! Temperature at the snow-ice or air-ice interface [K] T_mnw_out , & ! Mean temperature of the water column [K] T_wML_out , & ! Mixed-layer temperature [K] @@ -148,7 +144,7 @@ SUBROUTINE flake_driver_run ( & h_ML_out , & ! Thickness of the mixed-layer [m] H_B1_out , & ! Thickness of the upper layer of bottom sediments [m] T_sfc_out , & ! surface temperature [K] - T_sfc_n , & ! Updated surface temperature [K] + T_sfc_n , & ! Updated surface temperature [K] u_star , & q_sfc , & chh_out , & @@ -160,7 +156,7 @@ SUBROUTINE flake_driver_run ( & Q_LHT_flx , & ! Latent heat flux [W m^{-2}] Q_watvap , & ! Flux of water vapour [kg m^{-2} s^{-1}] Q_gflx , & ! Flux from ice to water [W m^{-2}] - Q_lflx ! latent fluxes [W m^{-2}] + Q_lflx ! latent fluxes [W m^{-2}] REAL (KIND = kind_phys) :: & lake_depth_max, T_bot_2_in, T_bot_2_out, dlat,tb,tr,tt,temp,temp2 @@ -276,7 +272,7 @@ SUBROUTINE flake_driver_run ( & ! w_extinc(i) = 3.0 ! write(0,1002) julian,xlat(i),w_albedo(I),w_extinc(i),elev(i),tsurf(i),T_sfc(i),t_bot1(i) -! write(0,1003) use_lake_model(i),i,lakedepth(i), snwdph(i), hice(i), fice(i) +! write(0,1003) use_lake_model(i),i,lakedepth(i), snwdph(i), hice(i), fice(i) ! write(0,1004) ps(i), wind(i), t1(i), q1(i), dlwflx(i), dswsfc(i), zlvl(i) endif !flag @@ -418,7 +414,7 @@ module flake_driver_post use machine, only: kind_phys implicit none private - public flake_driver_post_init, flake_driver_post_finalize, flake_driver_post_run + public flake_driver_post_init, flake_driver_post_finalize, flake_driver_post_run contains subroutine flake_driver_post_init() @@ -448,7 +444,7 @@ subroutine flake_driver_post_run (im, use_lake_model, h_ML, T_wML, & real (kind=kind_phys),dimension(:),intent(inout) :: & & xz, zm, tref - real (kind=kind_phys),dimension(:),intent(inout) :: tsfco + real (kind=kind_phys),dimension(:),intent(inout) :: tsfco integer, dimension(:), intent(in) :: use_lake_model @@ -471,7 +467,7 @@ subroutine flake_driver_post_run (im, use_lake_model, h_ML, T_wML, & enddo -end subroutine flake_driver_post_run +end subroutine flake_driver_post_run !--------------------------------- end module flake_driver_post diff --git a/physics/SFC_Models/Land/Noah/lsm_noah.f b/physics/SFC_Models/Land/Noah/lsm_noah.f index 9f41b83d0..3cf8c94e7 100644 --- a/physics/SFC_Models/Land/Noah/lsm_noah.f +++ b/physics/SFC_Models/Land/Noah/lsm_noah.f @@ -26,7 +26,7 @@ subroutine lsm_noah_init(lsm, lsm_noah, me, isot, ivegsrc, nlunit, implicit none integer, intent(in) :: lsm - integer, intent(in) :: lsm_noah + integer, intent(in) :: lsm_noah integer, intent(in) :: me, isot, ivegsrc, nlunit @@ -38,7 +38,7 @@ subroutine lsm_noah_init(lsm, lsm_noah, me, isot, ivegsrc, nlunit, ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + ! Consistency checks if (lsm/=lsm_noah) then write(errmsg,'(*(a))') 'Logic error: namelist choice of ', @@ -59,7 +59,7 @@ subroutine lsm_noah_init(lsm, lsm_noah, me, isot, ivegsrc, nlunit, errflg = 1 return end if - + !--- initialize soil vegetation call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) @@ -202,7 +202,7 @@ end subroutine lsm_noah_finalize ! ==================== end of description ===================== ! !>\defgroup Noah_LSM GFS Noah LSM Model -!! This is Noah LSM driver module, with the functionality of +!! This is Noah LSM driver module, with the functionality of !! preparing variables to run Noah LSM gfssflx(), calling Noah LSM and post-processing !! variables for return to the parent model suite including unit conversion, as well !! as diagnotics calculation. @@ -221,7 +221,7 @@ subroutine lsm_noah_run & & bexppert, xlaipert, vegfpert,pertvegf, & ! sfc perts, mgehne & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & & adjvisbmd, adjnirbmd, adjvisdfd, adjnirdfd, rhonewsn1, & - & exticeden, & + & exticeden, con_csol, con_t0c, & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & & canopy, trans, tsurf, zorl, & @@ -253,7 +253,7 @@ subroutine lsm_noah_run & & -1.0_kind_phys, -2.0_kind_phys / ! --- input: - integer, intent(in) :: im, km, isot, ivegsrc + integer, intent(in) :: im, km, isot, ivegsrc real (kind=kind_phys), intent(in) :: grav, cp, hvap, rd, eps, & & epsm1, rvrdm1 real (kind=kind_phys), intent(in) :: pertvegf @@ -273,7 +273,7 @@ subroutine lsm_noah_run & logical, dimension(:), intent(in) :: flag_iter, flag_guess, land logical, intent(in) :: lheatstrg, exticeden - + real (kind=kind_phys), intent(in) :: con_csol, con_t0c ! --- in/out: real (kind=kind_phys), dimension(:), intent(inout) :: weasd, & & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf, zorl @@ -285,17 +285,16 @@ subroutine lsm_noah_run & real (kind=kind_phys), dimension(:), intent(inout) :: sncovr1, & & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2 - real (kind=kind_phys), dimension(:), intent(inout) :: lai, rca real (kind=kind_phys), dimension(:), intent(inout), optional :: & - & wet1 - + & wet1, lai, rca + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), dimension(im) :: rch, rho, & & q0, qs1, theta1, weasd_old, snwdph_old, & - & tprcp_old, srflag_old, tskin_old, canopy_old + & tprcp_old, srflag_old, tskin_old, canopy_old real (kind=kind_phys), dimension(km) :: et, sldpth, stsoil, & & smsoil, slsoil @@ -313,7 +312,7 @@ subroutine lsm_noah_run & & snomlt, sncovr, soilw, soilm, ssoil, tsea, th2, tbot, & & xlai, zlvl, swdn, tem, z0, bexpp, xlaip, vegfp, & & mv, sv, alphav, betav, vegftmp, cpinv, hvapi, elocp, & - & rhonewsn + & rhonewsn integer :: couple, ice, nsoil, nroot, slope, stype, vtype integer :: i, k, iflag ! @@ -418,7 +417,7 @@ subroutine lsm_noah_run & solnet = adjvisbmd(i)*(1-albdvis_lnd(i)) & & +adjnirbmd(i)*(1-albdnir_lnd(i)) & & +adjvisdfd(i)*(1-albivis_lnd(i)) & - & +adjnirdfd(i)*(1-albinir_lnd(i)) + & +adjnirdfd(i)*(1-albinir_lnd(i)) sfcems = sfcemis(i) @@ -523,7 +522,7 @@ subroutine lsm_noah_run & !> - Apply perturbation of soil type b parameter and leave area index. bexpp = bexppert(i) ! sfc perts, mgehne xlaip = xlaipert(i) ! sfc perts, mgehne -!> - New snow depth variables +!> - New snow depth variables rhonewsn = rhonewsn1(i) !> - Call Noah LSM gfssflx(). @@ -535,6 +534,7 @@ subroutine lsm_noah_run & & vtype, stype, slope, shdmin1d, alb, snoalb1d, & & rhonewsn, exticeden, & & bexpp, xlaip, & ! sfc-perts, mgehne + & cp, con_csol, con_t0c, & & lheatstrg, & ! --- input/outputs: & tbot, cmc, tsea, stsoil, smsoil, slsoil, sneqv, chx, cmx, & diff --git a/physics/SFC_Models/Land/Noah/lsm_noah.meta b/physics/SFC_Models/Land/Noah/lsm_noah.meta index 3270c9de6..f5de70619 100644 --- a/physics/SFC_Models/Land/Noah/lsm_noah.meta +++ b/physics/SFC_Models/Land/Noah/lsm_noah.meta @@ -419,7 +419,7 @@ standard_name = magnitude_of_perturbation_of_vegetation_fraction long_name = magnitude of perturbation of vegetation fraction units = frac - dimensions = () + dimensions = () type = real kind = kind_phys intent = in @@ -502,6 +502,22 @@ dimensions = () type = logical intent = in +[con_csol] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degrees Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [weasd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land diff --git a/physics/SFC_Models/Land/Noah/sflx.f b/physics/SFC_Models/Land/Noah/sflx.f index efb2cb91a..5a47b904b 100644 --- a/physics/SFC_Models/Land/Noah/sflx.f +++ b/physics/SFC_Models/Land/Noah/sflx.f @@ -9,7 +9,7 @@ module sflx !! It is a soil/veg/snowpack land-surface model to update soil moisture, soil !! ice, soil temperature, skin temperature, snowpack water content, snowdepth, !! and all terms of the surface energy balance and surface water balance -!! (excluding input atmospheric forcings of downward radiation and +!! (excluding input atmospheric forcings of downward radiation and !! precipitation). !! !! The land-surface model component was substantially upgraded from the Oregon @@ -120,6 +120,7 @@ subroutine gfssflx &! --- input & vegtyp, soiltyp, slopetyp, shdmin, alb, snoalb, & & rhonewsn, exticeden, & & bexpp, xlaip, & ! sfc-perts, mgehne + & con_cp, con_csol, con_t0c, & & lheatstrg, &! --- input/outputs: & tbot, cmc, t1, stc, smc, sh2o, sneqv, ch, cm,z0, &! --- outputs: & nroot, shdfac, snowh, albedo, eta, sheat, ec, & @@ -272,37 +273,27 @@ subroutine gfssflx &! --- input ! use machine , only : kind_phys ! - use physcons, only : con_cp, con_rd, con_t0c, con_g, con_pi, & - & con_cliq, con_csol, con_hvap, con_hfus, & - & con_sbc ! implicit none ! --- constant parameters: -! *** note: some of the constants are different in subprograms and need to -! be consolidated with the standard def in module physcons at sometime -! at the present time, those diverse values are kept temperately to -! provide the same result as the original codes. -- y.t.h. may09 integer, parameter :: nsold = 4 !< max soil layers ! real (kind=kind_phys), parameter :: gs = con_g !< con_g =9.80665 real (kind=kind_phys), parameter :: gs1 = 9.8 !< con_g in sfcdif real (kind=kind_phys), parameter :: gs2 = 9.81 !< con_g in snowpack, frh2o - real (kind=kind_phys), parameter :: tfreez = con_t0c !< con_t0c =273.16 real (kind=kind_phys), parameter :: lsubc = 2.501e+6 !< con_hvap=2.5000e+6 real (kind=kind_phys), parameter :: lsubf = 3.335e5 !< con_hfus=3.3358e+5 real (kind=kind_phys), parameter :: lsubs = 2.83e+6 ! ? in sflx, snopac real (kind=kind_phys), parameter :: elcp = 2.4888e+3 ! ? in penman ! real (kind=kind_phys), parameter :: rd = con_rd ! con_rd =287.05 real (kind=kind_phys), parameter :: rd1 = 287.04 ! con_rd in sflx, penman, canres - real (kind=kind_phys), parameter :: cp = con_cp ! con_cp =1004.6 real (kind=kind_phys), parameter :: cp1 = 1004.5 ! con_cp in sflx, canres real (kind=kind_phys), parameter :: cp2 = 1004.0 ! con_cp in htr ! real (kind=kind_phys), parameter :: cph2o = con_cliq ! con_cliq=4.1855e+3 real (kind=kind_phys), parameter :: cph2o1 = 4.218e+3 ! con_cliq in penman, snopac real (kind=kind_phys), parameter :: cph2o2 = 4.2e6 ! con_cliq in hrt *unit diff! - real (kind=kind_phys), parameter :: cpice = con_csol ! con_csol=2.106e+3 real (kind=kind_phys), parameter :: cpice1 = 2.106e6 ! con_csol in hrt *unit diff! ! real (kind=kind_phys), parameter :: sigma = con_sbc ! con_sbc=5.6704e-8 real (kind=kind_phys), parameter :: sigma1 = 5.67e-8 ! con_sbc in penman, nopac, snopac @@ -321,6 +312,7 @@ subroutine gfssflx &! --- input ! --- input/outputs: real (kind=kind_phys), intent(inout) :: tbot, cmc, t1, sneqv, & & stc(nsoil), smc(nsoil), sh2o(nsoil), ch, cm + real (kind=kind_phys), intent(in) :: con_cp, con_csol, con_t0c ! --- outputs: integer, intent(out) :: nroot @@ -342,9 +334,12 @@ subroutine gfssflx &! --- input & psisat, quartz, rch, refkdt, rr, rgl, rsmax, sndens, & & sncond, sbeta, sn_new, slope, snup, salp, soilwm, soilww, & & t1v, t24, t2v, th2v, topt, tsnow, zbot, z0 - + real (kind=kind_phys) :: shdfac0 real (kind=kind_phys), dimension(nsold) :: rtdis, zsoil + real (kind=kind_phys) :: tfreez + real (kind=kind_phys) :: cp + real (kind=kind_phys) :: cpice logical :: frzgra, snowng @@ -357,6 +352,9 @@ subroutine gfssflx &! --- input errmsg = '' ! --- ... initialization + tfreez = con_t0c !< con_t0c =273.16 + cp = con_cp ! con_cp =1004.6 + cpice = con_csol ! con_csol=2.106e+3 runoff1 = 0.0 runoff2 = 0.0 @@ -597,7 +595,7 @@ subroutine gfssflx &! --- input endif ! end if_snowng_block -!> - Determine snowcover fraction and albedo fraction over sea-ice, +!> - Determine snowcover fraction and albedo fraction over sea-ice, !! glacial-ice, and land. if (ice /= 0) then diff --git a/physics/SFC_Models/Land/RUC/lsm_ruc.F90 b/physics/SFC_Models/Land/RUC/lsm_ruc.F90 index 71264e7db..db1541168 100644 --- a/physics/SFC_Models/Land/RUC/lsm_ruc.F90 +++ b/physics/SFC_Models/Land/RUC/lsm_ruc.F90 @@ -1,4 +1,4 @@ -!>\file lsm_ruc.F90 +!>\file lsm_ruc.F90 !! This file contains the RUC land surface scheme driver. !> This module contain the RUC land surface model driver @@ -9,9 +9,7 @@ module lsm_ruc use namelist_soilveg_ruc use set_soilveg_ruc_mod, only: set_soilveg_ruc use module_soil_pre - use module_sf_ruclsm - - use physcons, only : con_t0c + use module_sf_ruclsm, only: rslf, lsmruc, ruc_lsm_cons_init, ruclsminit implicit none @@ -28,7 +26,7 @@ module lsm_ruc contains -!> This subroutine calls set_soilveg_ruc() to specify vegetation and soil parameters for +!> This subroutine calls set_soilveg_ruc() to specify vegetation and soil parameters for !! a given soil and land-use classification. !! \section arg_table_lsm_ruc_init Argument Table !! \htmlinclude lsm_ruc_init.html @@ -36,7 +34,7 @@ module lsm_ruc subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & lsm_cold_start, flag_init, con_fvirt, con_rd, & im, lsoil_ruc, lsoil, kice, nlev, & ! in - lsm_ruc, lsm, slmsk, stype, vtype, landfrac, & ! in + lsm_ruc, lsm, slmsk, stype, vtype, landfrac, & ! in q1, prsl1, tsfc_lnd, tsfc_ice, tsfc_wat, & ! in tg3, smc, slc, stc, fice, min_seaice, & ! in sncovr_lnd, sncovr_ice, snoalb, & ! in @@ -47,7 +45,10 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & albdvis_lnd,albdnir_lnd,albivis_lnd,albinir_lnd, & ! out albdvis_ice,albdnir_ice,albivis_ice,albinir_ice, & ! out zs, sh2o, smfrkeep, tslb, smois, wetness, & ! out - tsice, pores, resid, errmsg, errflg) + tsice, pores, resid, & ! out + rhowater, con_t0c, con_hfus, con_hvap, & ! in + con_pi, con_rv, con_g, con_csol, con_tice, & ! in + errmsg, errflg) implicit none ! --- in @@ -108,6 +109,18 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & real (kind_phys), dimension(:), intent(out) :: semisbase real (kind_phys), dimension(:), intent(out) :: pores, resid +! --- in + real (kind_phys), intent(in) :: rhowater + real (kind_phys), intent(in) :: con_t0c + real (kind_phys), intent(in) :: con_hfus + real (kind_phys), intent(in) :: con_hvap + real (kind_phys), intent(in) :: con_pi + real (kind_phys), intent(in) :: con_rv + real (kind_phys), intent(in) :: con_g + real (kind_phys), intent(in) :: con_csol + real (kind_phys), intent(in) :: con_tice + + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -120,7 +133,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & ! Initialize CCPP error handling variables errmsg = '' - errflg = 0 + errflg = 0 ! Consistency checks if (lsm/=lsm_ruc) then @@ -144,6 +157,9 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & return end if + call ruc_lsm_cons_init(rhowater, con_t0c, con_hfus, con_hvap, & + con_pi, con_rv, con_g, con_csol, con_tice) + !> - Call rucinit() to initialize soil/ice/water variables if ( debug_print) then @@ -181,7 +197,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & sfalb_lnd_bck(i) = 0.25_kind_phys*(alnsf(i) + alnwf(i) + alvsf(i) + alvwf(i)) & * min(one, facsf(i)+facwf(i)) alb_lnd = sfalb_lnd_bck(i) * (one - sncovr_lnd(i)) & - + snoalb(i) * sncovr_lnd(i) + + snoalb(i) * sncovr_lnd(i) albdvis_lnd(i) = alb_lnd albdnir_lnd(i) = alb_lnd albivis_lnd(i) = alb_lnd @@ -189,7 +205,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & !-- ice semis_ice(i) = 0.97_kind_phys * (one - sncovr_ice(i)) + 0.99_kind_phys * sncovr_ice(i) alb_ice = 0.55_kind_phys * (one - sncovr_ice(i)) + 0.75_kind_phys * sncovr_ice(i) - albdvis_ice(i) = alb_ice + albdvis_ice(i) = alb_ice albdnir_ice(i) = alb_ice albivis_ice(i) = alb_ice albinir_ice(i) = alb_ice @@ -219,7 +235,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & if (lsm_cold_start) then do i = 1, im ! i - horizontal loop do k = 1, min(kice,lsoil_ruc) - ! - at initial time set sea ice T (tsice) + ! - at initial time set sea ice T (tsice) ! equal to TSLB, initialized from the Noah STC variable tsice (i,k) = tslb(i,k) enddo @@ -343,7 +359,7 @@ subroutine lsm_ruc_run & ! inputs & min_lakeice, min_seaice, oceanfrac, rhonewsn1, & ! --- constants & con_cp, con_rd, con_rv, con_g, con_pi, con_hvap, & - & con_hfus, con_fvirt, stbolt, rhoh2o, & + & con_hfus, con_fvirt, con_t0c, stbolt, rhoh2o, & ! --- in/outs for ice and land & semisbase, semis_lnd, semis_ice, sfalb_lnd, sfalb_ice, & & sncovr1_lnd, weasd_lnd, snwdph_lnd, tskin_lnd, & @@ -356,7 +372,7 @@ subroutine lsm_ruc_run & ! inputs & runof, runoff, srunoff, drain, & & cm_lnd, ch_lnd, evbs, evcw, stm, wetness, & & snowfallac_lnd, acsnow_lnd, snowmt_lnd, snohf, & - & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & + & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & ! for ice & sfcqc_ice, sfcqv_ice, & & tsurf_ice, tsnow_ice, z0rl_ice, & @@ -402,6 +418,7 @@ subroutine lsm_ruc_run & ! inputs con_pi, con_rd, & con_hvap, con_hfus, & con_fvirt, stbolt, rhoh2o + real (kind_phys), intent(in) :: con_t0c logical, dimension(:), intent(in) :: flag_iter, flag_guess logical, dimension(:), intent(in) :: land, icy @@ -426,7 +443,7 @@ subroutine lsm_ruc_run & ! inputs & laixy, tsnow_lnd, sfcqv_lnd, sfcqc_lnd, sfcqc_ice, sfcqv_ice,& & tsnow_ice real (kind_phys), dimension(:), intent(inout) :: & - & canopy, trans, smcwlt2, smcref2, & + & canopy, trans, smcwlt2, smcref2, & ! for land & weasd_lnd, snwdph_lnd, tskin_lnd, & & tsurf_lnd, z0rl_lnd, & @@ -569,7 +586,7 @@ subroutine lsm_ruc_run & ! inputs errflg = 0 ipr = 10 - + !-- testptlat = 68.6_kind_phys testptlon = 298.6_kind_phys @@ -624,9 +641,9 @@ subroutine lsm_ruc_run & ! inputs kte = 1 ! mosaic_lu=mosaic_soil=0, set in set_soilveg_ruc.F90 - ! set mosaic_lu=mosaic_soil=1 when fractional land and soil + ! set mosaic_lu=mosaic_soil=1 when fractional land and soil ! categories available - ! for now set fractions of differnet landuse and soil types + ! for now set fractions of differnet landuse and soil types ! in the grid cell to zero @@ -819,7 +836,7 @@ subroutine lsm_ruc_run & ! inputs frpcpn = .false. endif - do j = jms, jme + do j = jms, jme do i = 1, im ! i - horizontal loop orog(i,j) = oro(i) !topography stdev(i,j) = sigma(i) ! st. deviation (m) @@ -881,7 +898,7 @@ subroutine lsm_ruc_run & ! inputs ! all precip input to RUC LSM is in [mm] !prcp(i,j) = rhoh2o * tprcp(i) ! tprcp in [m] - convective plus explicit !raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip - !rainncv(i,j) = rhoh2o * max(rain(i)-rainc(i),0.0) ! total time-step explicit precip + !rainncv(i,j) = rhoh2o * max(rain(i)-rainc(i),0.0) ! total time-step explicit precip !graupelncv(i,j) = rhoh2o * graupel(i) !snowncv(i,j) = rhoh2o * snow(i) prcp(i,j) = rhoh2o * (rainc(i)+rainnc(i)) ! total time-step convective plus explicit [mm] @@ -978,7 +995,7 @@ subroutine lsm_ruc_run & ! inputs qvg_lnd(i,j) = sfcqv_lnd(i) qsfc_lnd(i,j) = sfcqv_lnd(i)/(1.+sfcqv_lnd(i)) qsg_lnd(i,j) = rslf(prsl1(i),tsurf_lnd(i)) - qcg_lnd(i,j) = sfcqc_lnd(i) + qcg_lnd(i,j) = sfcqc_lnd(i) sncovr_lnd(i,j) = sncovr1_lnd(i) if (kdt == 1) then sfcems_lnd(i,j) = semisbase(i) * (one-sncovr_lnd(i,j)) + 0.99_kind_phys * sncovr_lnd(i,j) @@ -1021,7 +1038,7 @@ subroutine lsm_ruc_run & ! inputs solnet_lnd(i,j) = dswsfc(i)*(one-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 IF ( add_fire_heat_flux .and. fire_heat_flux_out(i) > 0) then ! JLS - if (debug_print) then + if (debug_print) then print *,'alb_lnd before fire, xlat/xlon ', alb_lnd(i,j), xlat_d(i),xlon_d(i) print *,'fire_heat_flux_out, frac_grid_burned_out, xlat/xlon ', & fire_heat_flux_out(i),frac_grid_burned_out(i),xlat_d(i),xlon_d(i) @@ -1033,8 +1050,8 @@ subroutine lsm_ruc_run & ! inputs endif ENDIF - cmc(i,j) = canopy(i) ! [mm] - soilt_lnd(i,j) = tsurf_lnd(i) + cmc(i,j) = canopy(i) ! [mm] + soilt_lnd(i,j) = tsurf_lnd(i) ! sanity check for snow temperature tsnow if (tsnow_lnd(i) > 200._kind_phys .and. tsnow_lnd(i) < con_t0c) then soilt1_lnd(i,j) = tsnow_lnd(i) @@ -1168,7 +1185,7 @@ subroutine lsm_ruc_run & ! inputs 'sfcems_lnd',sfcems_lnd(i,j),'flhc_lnd',flhc_lnd(i,j), & 'flqc_lnd',flqc_lnd(i,j),'wet',wet(i,j),'cmc',cmc(i,j), & 'qcg_lnd',qcg_lnd(i,j),'dew',dew_lnd(i,j), & - 'znt_lnd',znt_lnd(i,j),'shdfac',shdfac(i,j), & + 'znt_lnd',znt_lnd(i,j),'shdfac',shdfac(i,j), & 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & 'smsoil1',smsoil(i,1,j),'slsoil',slsoil(i,1,j), & 'keepfrsoil',keepfrsoil(i,1,j), & @@ -1254,7 +1271,7 @@ subroutine lsm_ruc_run & ! inputs 'snfallac(i,j) =',snfallac_lnd(i,j), & 'acsn_lnd(i,j) =',acsn_lnd(i,j), & 'snomlt(i,j) =',snomlt_lnd(i,j),'xlai(i,j) =',xlai(i,j) - endif + endif endif @@ -1330,16 +1347,16 @@ subroutine lsm_ruc_run & ! inputs canopy(i) = cmc(i,j) ! mm weasd_lnd(i) = sneqv_lnd(i,j) ! mm sncovr1_lnd(i) = sncovr_lnd(i,j) - ! ---- ... outside RUC LSM, roughness uses cm as unit + ! ---- ... outside RUC LSM, roughness uses cm as unit ! (update after snow's effect) z0rl_lnd(i) = znt_lnd(i,j)*100._kind_phys !-- semis_lnd is with snow effect semis_lnd(i) = sfcems_lnd(i,j) !-- semisbas is without snow effect, but can have vegetation mosaic effect - semisbase(i) = semis_bck(i,j) + semisbase(i) = semis_bck(i,j) !-- sfalb_lnd has snow effect sfalb_lnd(i) = alb_lnd(i,j) - !-- fill in albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, + !-- fill in albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_lnd(i) = sfalb_lnd(i) albdnir_lnd(i) = sfalb_lnd(i) albivis_lnd(i) = sfalb_lnd(i) @@ -1400,7 +1417,7 @@ subroutine lsm_ruc_run & ! inputs sfcems_ice(i,j) = semis_ice(i) endif cmc(i,j) = canopy(i) ! [mm] - soilt_ice(i,j) = tsurf_ice(i) + soilt_ice(i,j) = tsurf_ice(i) if (tsnow_ice(i) > 150._kind_phys .and. tsnow_ice(i) < con_t0c) then soilt1_ice(i,j) = tsnow_ice(i) else @@ -1436,7 +1453,7 @@ subroutine lsm_ruc_run & ! inputs !> -- sanity checks on sneqv and snowh if (sneqv_ice(i,j) /= zero .and. snowh_ice(i,j) == zero) then - snowh_ice(i,j) = 0.003_kind_phys * sneqv_ice(i,j) ! snow density ~300 kg m-3 + snowh_ice(i,j) = 0.003_kind_phys * sneqv_ice(i,j) ! snow density ~300 kg m-3 endif if (snowh_ice(i,j) /= zero .and. sneqv_ice(i,j) == zero) then @@ -1525,7 +1542,7 @@ subroutine lsm_ruc_run & ! inputs rhosnf(i) = rhosnfr(i,j) ! kg m-3 snowfallac_ice(i) = snfallac_ice(i,j) ! kg m-2 - acsnow_ice(i) = acsn_ice(i,j) ! kg m-2 + acsnow_ice(i) = acsn_ice(i,j) ! kg m-2 snowmt_ice(i) = snomlt_ice(i,j) ! kg m-2 ! --- ... unit conversion (from m to mm) snwdph_ice(i) = snowh_ice(i,j) * rhoh2o @@ -1533,7 +1550,7 @@ subroutine lsm_ruc_run & ! inputs sncovr1_ice(i) = sncovr_ice(i,j) z0rl_ice(i) = znt_ice(i,j)*100._kind_phys ! cm !-- semis_ice is with snow effect - semis_ice(i) = sfcems_ice(i,j) + semis_ice(i) = sfcems_ice(i,j) !-- sfalb_ice is with snow effect sfalb_ice(i) = alb_ice(i,j) !-- albdvis_ice,albdnir_ice,albivis_ice,albinir_ice @@ -1633,7 +1650,7 @@ end subroutine lsm_ruc_run subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in nlev, me, master, lsm_ruc, lsm, slmsk, & ! in stype, vtype, landfrac, fice, & ! in - min_seaice, tskin_lnd, tskin_wat, tg3, & ! in + min_seaice, tskin_lnd, tskin_wat, tg3, & ! in zs, dzs, smc, slc, stc, & ! in sh2o, smfrkeep, tslb, smois, & ! out wetness, errmsg, errflg) @@ -1689,7 +1706,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in real (kind_phys), dimension( 1:im , 1:1 ) :: tbot real (kind_phys), dimension( 1:im , 1:1 ) :: smtotn real (kind_phys), dimension( 1:im , 1:1 ) :: smtotr - real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumsm + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumsm real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumt real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: smfr real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soilm @@ -1795,7 +1812,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in write (0,*)'tskin_wat(ipr) =', tskin_wat(ipr) write (0,*)'vtype(ipr) =', ipr, vtype(ipr) write (0,*)'stype(ipr) =', ipr, stype(ipr) - write (0,*)'its,ite,jts,jte =', its,ite,jts,jte + write (0,*)'its,ite,jts,jte =', its,ite,jts,jte endif @@ -1806,8 +1823,8 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in tbot(i,j) = tg3(i) ivgtyp(i,j) = vtype(i) isltyp(i,j) = stype(i) - if(isltyp(i,j)==0) isltyp(i,j)=14 - if(ivgtyp(i,j)==0) ivgtyp(i,j)=17 + if(isltyp(i,j)==0) isltyp(i,j)=14 + if(ivgtyp(i,j)==0) ivgtyp(i,j)=17 if (landfrac(i) > zero .or. fice(i) > zero) then !-- land or ice tsk(i,j) = tskin_lnd(i) @@ -1929,7 +1946,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in do k=1,lsoil_ruc -1 smtotr(i,j)=smtotr(i,j) + soilm(i,k,j) *dzs(k) enddo - ! Noah soil moisture bucket + ! Noah soil moisture bucket smtotn(i,j)=smc(i,1)*0.1_kind_phys + smc(i,2)*0.2_kind_phys + smc(i,3)*0.7_kind_phys + smc(i,4)*one if(debug_print) then @@ -2008,7 +2025,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in tslb(i,k) = soiltemp(i,k,j) sh2o(i,k) = soilh2o(i,k,j) smfrkeep(i,k) = smfr(i,k,j) - enddo + enddo enddo enddo diff --git a/physics/SFC_Models/Land/RUC/lsm_ruc.meta b/physics/SFC_Models/Land/RUC/lsm_ruc.meta index bc4d358e3..88eaba562 100644 --- a/physics/SFC_Models/Land/RUC/lsm_ruc.meta +++ b/physics/SFC_Models/Land/RUC/lsm_ruc.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = lsm_ruc type = scheme - dependencies = ../../../hooks/machine.F,../../../hooks/physcons.F90 + dependencies = ../../../hooks/machine.F dependencies = module_sf_ruclsm.F90,module_soil_pre.F90,namelist_soilveg_ruc.F90,set_soilveg_ruc.F90 ######################################################################## @@ -496,6 +496,78 @@ type = real intent = out kind = kind_phys +[rhowater] + standard_name = fresh_liquid_water_density_at_0c + long_name = density of liquid water + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degrees Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of vaporization/sublimation (hvap) + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_csol] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_tice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1106,6 +1178,14 @@ type = real kind = kind_phys intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degrees Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [stbolt] standard_name = stefan_boltzmann_constant long_name = Stefan-Boltzmann constant @@ -1132,7 +1212,7 @@ intent = inout [semis_lnd] standard_name = surface_longwave_emissivity_over_land - long_name = surface lw emissivity in fraction over land + long_name = surface lw emissivity in fraction over land units = frac dimensions = (horizontal_loop_extent) type = real diff --git a/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 b/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 index aa4f34d1f..a319fc900 100644 --- a/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 +++ b/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 @@ -2,7 +2,7 @@ !! This file is the entity of NOAA/ESRL/GSD RUC LSM Model(WRF version 4.0). !>\ingroup lsm_ruc_group -!! This module contains the entity of the RUC LSM model, which is a +!! This module contains the entity of the RUC LSM model, which is a !! soil/veg/snowpack and ice/snowpack/land-surface model to update soil !! moisture, soil temperature, skin temperature, snowpack water content, snowdepth, !! and all terms of the surface energy balance and surface water balance. @@ -10,24 +10,25 @@ MODULE module_sf_ruclsm use machine , only : kind_phys, kind_dbl_prec use namelist_soilveg_ruc - use physcons, only : rhowater, con_t0c, con_hfus, con_hvap, & - con_pi, con_rv, con_g, con_csol, con_tice implicit none private !private qsn - public :: lsmruc, ruclsminit, rslf + public :: lsmruc, ruclsminit, rslf, ruc_lsm_cons_init + real (kind_phys) :: con_hfus = 1.0E30_kind_phys + real (kind_phys) :: rhowater = 1.0E30_kind_phys + real (kind_phys) :: con_tice = 1.0E30_kind_phys !> CONSTANT PARAMETERS !! @{ - real (kind_phys), parameter :: tfrz = con_t0c - real (kind_phys), parameter :: xls = con_hvap + con_hfus - real (kind_phys), parameter :: piconst = con_pi - real (kind_phys), parameter :: r_v = con_rv - real (kind_phys), parameter :: grav = con_g - real (kind_phys), parameter :: sheatice = con_csol + real (kind_phys) :: tfrz = 1.0E30_kind_phys + real (kind_phys) :: xls = 1.0E30_kind_phys + real (kind_phys) :: piconst = 1.0E30_kind_phys + real (kind_phys) :: r_v = 1.0E30_kind_phys + real (kind_phys) :: grav = 1.0E30_kind_phys + real (kind_phys) :: sheatice = 1.0E30_kind_phys real (kind_phys), parameter :: rhoice = 917._kind_phys ! ice density real (kind_phys), parameter :: sheatsn = 2090._kind_phys ! snow heat capacity @@ -79,10 +80,35 @@ MODULE module_sf_ruclsm CONTAINS + subroutine ruc_lsm_cons_init(rhowater_in, con_t0c, con_hfus_in, con_hvap, & + con_pi, con_rv, con_g, con_csol, con_tice_in ) + real (kind_phys), intent(in) :: rhowater_in + real (kind_phys), intent(in) :: con_t0c + real (kind_phys), intent(in) :: con_hfus_in + real (kind_phys), intent(in) :: con_hvap + real (kind_phys), intent(in) :: con_pi + real (kind_phys), intent(in) :: con_rv + real (kind_phys), intent(in) :: con_g + real (kind_phys), intent(in) :: con_csol + real (kind_phys), intent(in) :: con_tice_in + + ! set module level variables + con_hfus = con_hfus_in + rhowater = rhowater_in + con_tice = con_tice_in + tfrz = con_t0c + xls = con_hvap + con_hfus + piconst = con_pi + r_v = con_rv + grav = con_g + sheatice = con_csol + end subroutine ruc_lsm_cons_init + + !----------------------------------------------------------------- !>\ingroup lsm_ruc_group -!> The RUN LSM model is described in Smirnova et al.(1997) -!! \cite Smirnova_1997 and Smirnova et al.(2000) \cite Smirnova_2000 +!> The RUN LSM model is described in Smirnova et al.(1997) +!! \cite Smirnova_1997 and Smirnova et al.(2000) \cite Smirnova_2000 !>\section gen_lsmruc RUC LSM General Algorithm !! @{ SUBROUTINE LSMRUC(xlat,xlon, & @@ -95,9 +121,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & FLQC,FLHC,rhonewsn_ex,mosaic_lu, & mosaic_soil,isncond_opt,isncovr_opt, & MAVAIL,CANWAT,VEGFRA, & - ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, & + ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, & landusef, nlcat, soilctop, nscat, & - smcwlt, smcref, & + smcwlt, smcref, & QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & TBOT,IVGTYP,ISLTYP,XLAND, & ISWATER,ISICE,XICE,XICE_THRESHOLD, & @@ -118,12 +144,12 @@ SUBROUTINE LSMRUC(xlat,xlon, & !----------------------------------------------------------------- ! ! The RUC LSM model is described in: -! Smirnova, T.G., J.M. Brown, and S.G. Benjamin, 1997: -! Performance of different soil model configurations in simulating -! ground surface temperature and surface fluxes. +! Smirnova, T.G., J.M. Brown, and S.G. Benjamin, 1997: +! Performance of different soil model configurations in simulating +! ground surface temperature and surface fluxes. ! Mon. Wea. Rev. 125, 1870-1884. -! Smirnova, T.G., J.M. Brown, and D. Kim, 2000: Parameterization of -! cold-season processes in the MAPS land-surface scheme. +! Smirnova, T.G., J.M. Brown, and D. Kim, 2000: Parameterization of +! cold-season processes in the MAPS land-surface scheme. ! J. Geophys. Res. 105, 4077-4086. !----------------------------------------------------------------- !-- DT time step (second) @@ -150,7 +176,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !-- GSW absorbed short wave flux at ground surface (W/m^2) !-- EMISS surface emissivity (between 0 and 1) ! FLQC - surface exchange coefficient for moisture (kg/m^2/s) -! FLHC - surface exchange coefficient for heat [W/m^2/s/degreeK] +! FLHC - surface exchange coefficient for heat [W/m^2/s/degreeK] ! SFCEXC - surface exchange coefficient for heat [m/s] ! CANWAT - CANOPY MOISTURE CONTENT (mm) ! VEGFRA - vegetation fraction (between 0 and 100) @@ -177,10 +203,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! ACRUNOFF - run-total surface runoff [mm] ! SFCEVP - total time-step evaporation in [kg/m^2] ! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface) -! SNOWFALLAC - run-total snowfall accumulation [mm] -! ACSNOW - run-toral SWE of snowfall [mm] +! SNOWFALLAC - run-total snowfall accumulation [mm] +! ACSNOW - run-toral SWE of snowfall [mm] !-- CHKLOWQ - is either 0 or 1 (so far set equal to 1). -!-- used only in MYJPBL. +!-- used only in MYJPBL. !-- tice - sea ice temperture (C) !-- rhosice - sea ice density (kg m^-3) !-- capice - sea ice volumetric heat capacity (J/m^3/K) @@ -199,7 +225,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys), INTENT(IN ) :: xlat,xlon real (kind_phys), INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden - INTEGER, INTENT(IN ) :: NLCAT, NSCAT + INTEGER, INTENT(IN ) :: NLCAT, NSCAT INTEGER, INTENT(IN ) :: mosaic_lu,mosaic_soil INTEGER, INTENT(IN ) :: isncond_opt,isncovr_opt INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & @@ -260,7 +286,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SMCREF, & EMISS, & EMISBCK, & - MAVAIL, & + MAVAIL, & SFCEXC, & Z0 , & ZNT @@ -277,7 +303,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & XICE_threshold - + real (kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & INTENT(INOUT) :: SOILMOIS,SH2O,TSO @@ -307,7 +333,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SOILT1, & TSNAV - real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: SMAVAIL, & SMMAX @@ -384,14 +410,14 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys), DIMENSION(1:5001) :: TBQ - real (kind_phys), DIMENSION( 1:nsl ) :: SOILM1D, & + real (kind_phys), DIMENSION( 1:nsl ) :: SOILM1D, & TSO1D, & SOILICE, & SOILIQW, & SMFRKEEP real (kind_phys), DIMENSION( 1:nsl ) :: KEEPFR - + real (kind_phys), DIMENSION( 1:nlcat ) :: lufrac real (kind_phys), DIMENSION( 1:nscat ) :: soilfrac @@ -426,7 +452,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys) :: meltfactor, ac,as, wb,rovcp INTEGER :: NROOT INTEGER :: ILAND,ISOIL,IFOREST - + INTEGER :: I,J,K,NZS,NZS1,NDDZS INTEGER :: k1,k2 logical :: debug_print @@ -438,7 +464,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & integer, intent(out) :: errflg !----------------------------------------------------------------- -! +! ! Initialize error-handling errflg = 0 errmsg = '' @@ -451,8 +477,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & NDDZS=2*(nzs-2) !-- - testptlat = 35.55 !48.7074_kind_phys !39.958 !42.05 !39.0 !74.12 !29.5 - testptlon = 278.66 !289.03_kind_phys !271.622 !286.75 !280.6 !164.0 !283.0 + testptlat = 35.55 !48.7074_kind_phys !39.958 !42.05 !39.0 !74.12 !29.5 + testptlon = 278.66 !289.03_kind_phys !271.622 !286.75 !280.6 !164.0 !283.0 !-- @@ -506,7 +532,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & patmb=P8w(i,kms,j)*1.e-2_kind_phys QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATMB - + if((qcg(i,j) < zero) .or. (qcg(i,j) > 0.1_kind_phys)) then qcg (i,j) = qc3d(i,1,j) if (debug_print ) then @@ -547,11 +573,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & smtotold(i,j)=zero canwatold(i,j)=zero -!> - For RUC LSM CHKLOWQ needed for MYJPBL should +!> - For RUC LSM CHKLOWQ needed for MYJPBL should !! 1 because is actual specific humidity at the surface, and !! not the saturation value chklowq(i,j) = one - infiltr(i,j) = zero + infiltr(i,j) = zero snoh (i,j) = zero edir (i,j) = zero ec (i,j) = zero @@ -604,8 +630,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & QVATM = QV3D(i,kms,j) QCATM = QC3D(i,kms,j) PATM = P8w(i,kms,j)*1.e-5_kind_phys -!> - Z3D(1) is thickness between first full sigma level and the surface, -!! but first mass level is at the half of the first sigma level +!> - Z3D(1) is thickness between first full sigma level and the surface, +!! but first mass level is at the half of the first sigma level !! (u and v are also at the half of first sigma level) CONFLX = Z3D(i,kms,j)*0.5_kind_phys RHO = RHO3D(I,kms,J) @@ -647,14 +673,14 @@ SUBROUTINE LSMRUC(xlat,xlon, & ELSE ! .not. FRPCPN if (tabs.le.tfrz) then - PRCPMS = zero + PRCPMS = zero NEWSNMS = RAINBL(i,j)/DT*1.e-3_kind_phys !> - If here no info about constituents of frozen precipitation, !! suppose it is all snow - snowrat = one + snowrat = one else PRCPMS = RAINBL(i,j)/DT*1.e-3_kind_phys - NEWSNMS = zero + NEWSNMS = zero endif ENDIF @@ -751,7 +777,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif endif ENDIF - + !> - Call soilvegin() to initialize soil and surface properties !-- land or ice CALL SOILVEGIN ( debug_print, mosaic_lu, mosaic_soil, & @@ -788,7 +814,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !---- all vegetation types except evergreen and mixed forests !18apr08 - define meltfactor for Egglston melting limit: ! for open areas factor is 2, and for forests - factor is 0.85 -! This will make limit on snow melting smaller and let snow stay +! This will make limit on snow melting smaller and let snow stay ! longer in the forests. meltfactor = 2.0_kind_phys @@ -802,8 +828,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & !---- evergreen and mixed forests !18apr08 - define meltfactor ! meltfactor = 1.5 -! 28 March 11 - Previously used value of metfactor= 1.5 needs to be further reduced -! to compensate for low snow albedos in the forested areas. +! 28 March 11 - Previously used value of metfactor= 1.5 needs to be further reduced +! to compensate for low snow albedos in the forested areas. ! Melting rate in forests will reduce. meltfactor = 0.85_kind_phys @@ -829,7 +855,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & ENDIF IF((XLAND(I,J)-1.5).GE.0._kind_phys)THEN -!-- Water +!-- Water SMAVAIL(I,J)= one SMMAX(I,J)= one SNOW(I,J) = zero @@ -850,14 +876,14 @@ SUBROUTINE LSMRUC(xlat,xlon, & DO K=1,NZS SOILMOIS(I,K,J)=one - SH2O (I,K,J)=one + SH2O (I,K,J)=one TSO(I,K,J)= SOILT(I,J) ENDDO IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then - PRINT*,' water point' + PRINT*,' water point' print*,' lat,lon=',xlat,xlon,'SOILT=', SOILT(i,j) endif ENDIF @@ -874,7 +900,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & IF(SEAICE(I,J).GT.0.5_kind_phys)THEN !-- Sea-ice case IF (debug_print ) THEN - if (abs(xlat-testptlat).lt.0.2 .and. & + if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then PRINT*,' sea-ice at water point' print*,' lat,lon=',xlat,xlon @@ -888,7 +914,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif ZNT(I,J) = 0.011_kind_phys ! in FV3 albedo and emiss are defined for ice - emissl(i,j) = emisbck(i,j) ! no snow impact, old 0.98 used in WRF + emissl(i,j) = emisbck(i,j) ! no snow impact, old 0.98 used in WRF dqm = one ref = one qmin = zero @@ -916,8 +942,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & soilm1d (k) = min(max(zero,soilmois(i,k,j)-qmin),dqm) tso1d (k) = tso(i,k,j) soiliqw (k) = min(max(zero,sh2o(i,k,j)-qmin),soilm1d(k)) - soilice (k) =(soilm1d (k) - soiliqw (k))/0.9_kind_phys - ENDDO + soilice (k) =(soilm1d (k) - soiliqw (k))/0.9_kind_phys + ENDDO do k=1,nzs smfrkeep(k) = smfr3d(i,k,j) @@ -932,7 +958,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & print*,' lat,lon=',xlat,xlon print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO - print *,'CONFLX =',CONFLX + print *,'CONFLX =',CONFLX print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR endif ENDIF @@ -990,11 +1016,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & runoff2(I,J),soilice,soiliqw,infiltrp,smf(i,j)) !----------------------------------------------------------------- -! Fraction of cropland category in the grid box should not have soil moisture below +! Fraction of cropland category in the grid box should not have soil moisture below ! wilting point during the growing season. ! Let's keep soil moisture 5% above wilting point for the crop fraction of grid box. ! This change violates LSM moisture budget, but -! can be considered as a compensation for irrigation not included into LSM. +! can be considered as a compensation for irrigation not included into LSM. ! "Irigation" could be applied when landuse fractional information ! is available and mosaic_lu=1. if(mosaic_lu == 1) then @@ -1008,7 +1034,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif if((ivgtyp(i,j) == natural .or. ivgtyp(i,j) == crop) .and. factor > 0.75) then - ! cropland or grassland, apply irrigation during the growing seaspon when fraction + ! cropland or grassland, apply irrigation during the growing seaspon when fraction ! of greenness is > 0.75. do k=1,nroot @@ -1019,7 +1045,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.1 .and. & abs(xlon-testptlon).lt.0.1)then - print * ,'Soil moisture is below wilting in cropland areas at time step',ktau + print * ,'Soil moisture is below wilting in cropland areas at time step',ktau print * ,' lat,lon=',xlat,xlon print * ,' lufrac=',lufrac,'factor=',factor & ,'lai,ivgtyp,lufrac(crop),k,soilm1d(k),cropfr,wilt,cropsm,newsm,', & @@ -1028,7 +1054,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & ENDIF soilm1d(k) = newsm IF (debug_print ) THEN - if (abs(xlat-testptlat).lt.0.1 .and. & + if (abs(xlat-testptlat).lt.0.1 .and. & abs(xlon-testptlon).lt.0.1)then print*,' lat,lon=',xlat,xlon print * ,'Added soil water to cropland areas, k,soilm1d(k)',k,soilm1d(k) @@ -1102,7 +1128,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & if(snow(i,j)==zero) EMISSL(i,j) = EMISBCK(i,j) EMISS (I,J) = EMISSL(I,J) ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m - !-- 17 may 2024 - cap snow for points at high elevations where all year round skin temperatures are close to 0 C + !-- 17 may 2024 - cap snow for points at high elevations where all year round skin temperatures are close to 0 C !-- Snow density for these points will be 3000/7.5=400 [kg/m^3] SNOW (i,j) = min(3._kind_phys,SNWE)*1000._kind_phys ! cap to be < 3 m SNOWH (I,J) = min(7.5_kind_phys,SNHEI) ! cap to be < 7.5 m @@ -1115,7 +1141,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif INFILTR(I,J) = INFILTRP - MAVAIL (i,j) = LMAVAIL(I,J) + MAVAIL (i,j) = LMAVAIL(I,J) IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) @@ -1201,9 +1227,9 @@ END SUBROUTINE LSMRUC !>\ingroup lsm_ruc_group !! This subroutine solves energy and moisture budgets. -!! - It computes density of frozen precipitation from empirical +!! - It computes density of frozen precipitation from empirical !! dependence on temperature at the first atmospheric level. -!! - Computes amount of liquid and frozen precipitation intercepted by +!! - Computes amount of liquid and frozen precipitation intercepted by !! the vegetation canopy. !! - In there is snow on the ground, the snow fraction is below 0.75, !! the snow "mosaic" approach is turned on. @@ -1267,9 +1293,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia RHO, & QKMS, & TKMS, & - fire_heat_flux - LOGICAL, INTENT(IN ) :: add_fire_heat_flux - + fire_heat_flux + LOGICAL, INTENT(IN ) :: add_fire_heat_flux + INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables real (kind_phys) , & @@ -1307,7 +1333,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & - DTDZS2 + DTDZS2 real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS @@ -1318,7 +1344,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !--- input/output variables !-------- 3-d soil moisture and temperature real (kind_phys), DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: TS1D, & + INTENT(INOUT) :: TS1D, & SOILM1D, & SMFRKEEP real (kind_phys), DIMENSION( 1:nzs ) , & @@ -1326,7 +1352,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia real (kind_phys), DIMENSION(1:NZS),INTENT(INOUT) :: SOILICE, & SOILIQW - + INTEGER, INTENT(INOUT) :: ILAND,ISOIL INTEGER :: ILANDs @@ -1356,7 +1382,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia HFX, & fltot, & smf, & - S, & + S, & RUNOFF1, & RUNOFF2, & ACSNOW, & @@ -1380,7 +1406,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia TS1DS, & SOILM1DS, & SMFRKEEPS, & - SOILIQWS, & + SOILIQWS, & SOILICES, & KEEPFRS !-------- 1-d variables @@ -1406,10 +1432,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SS, & SOILTs - - - real (kind_phys), INTENT(INOUT) :: RSM, & + + + real (kind_phys), INTENT(INOUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables @@ -1430,8 +1456,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia real :: interw, intersn, infwater, intwratio !----------------------------------------------------------------- - integer, parameter :: ilsnow=99 - + integer, parameter :: ilsnow=99 + IF (debug_print ) THEN print *,' in SFCTMP',i,j,nzs,nddzs,nroot, & SNWE,RHOSN,SNOM,SMELT,TS1D @@ -1529,7 +1555,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia 777 continue endif - !-- snow_mosaic from the previous time step + !-- snow_mosaic from the previous time step if(snowfrac < 0.75_kind_phys) snow_mosaic = one newsn=newsnms*delt @@ -1579,7 +1605,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia end if !*** Define average snow density of the snow pack considering -!*** the amount of fresh snow (eq. 9 in Koren et al.(1999) +!*** the amount of fresh snow (eq. 9 in Koren et al.(1999) !*** without snow melt ) xsn=(rhosn*snwe+rhonewsn*newsn)/ & (snwe+newsn) @@ -1592,7 +1618,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! RAINF is a flag used for calculation of rain water ! heat content contribution into heat budget equation. Rain's temperature ! is set equal to air temperature at the first atmospheric -! level. +! level. RAINF=one ENDIF @@ -1694,7 +1720,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- mountains to 0.85 (based on Swiss weather model over the Alps) if(hgt > 2500._kind_phys .and. ivgtyp == glacier) snowfrac=min(0.85_kind_phys,snowfrac) - !24nov15 - SNOWFRAC for urban category < 0.75 + !24nov15 - SNOWFRAC for urban category < 0.75 if(ivgtyp == urban) snowfrac=min(0.75_kind_phys,snowfrac) if(snowfrac < 0.75_kind_phys) snow_mosaic = one @@ -1732,7 +1758,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- ALB dependence on snow depth ! ALB_SNOW across Canada's forested areas is very low - 0.27-0.35, this ! causes significant warm biases. Limiting ALB in these areas to be higher than 0.4 -! hwlps with these biases.. +! hwlps with these biases.. if( snow_mosaic == one) then ALBsn=alb_snow if(KEEP_SNOW_ALBEDO > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then @@ -1812,7 +1838,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ENDIF - if (snow_mosaic==one) then + if (snow_mosaic==one) then !may 2014 - treat separately snow-free and snow-covered areas if(SEAICE .LT. 0.5_kind_phys) then @@ -1854,7 +1880,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia smelt=zero runoff1s=zero runoff2s=zero - + ilands = ivgtyp CALL SOIL(debug_print,xlat, xlon, testptlat, testptlon,& @@ -1863,7 +1889,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin, & EMISS_snowfree,RNET,QKMS,TKMS,PC,csts,dripliq, & infwater,rho,vegfrac,lai,myj, & -!--- soil fixed fields +!--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt, & psis,bclh,ksat,sat,cn, & zsmain,zshalf,DTDZS,DTDZS2,tbq, & @@ -1901,7 +1927,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia smelt=zero runoff1s=zero runoff2s=zero - + CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & @@ -1934,7 +1960,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif ! seaice < 0.5 endif ! snow_mosaic=1. - + !--- recompute absorbed solar radiation and net radiation !--- for updated value of snow albedo - ALB gswnew=GSWin*(one-alb) @@ -1976,7 +2002,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia MYJ, & !--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & - sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & + sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & !--- constants lv,CP,rovcp,G0,cw,stbolt,tabs, & KQWRTZ,KICE,KWT, & @@ -1996,25 +2022,25 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif CALL SNOWSEAICE (debug_print,xlat,xlon, & - i,j,isoil,delt,ktau,conflx,nzs,nddzs, & + i,j,isoil,delt,ktau,conflx,nzs,nddzs, & isncond_opt,isncovr_opt, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new - ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & - RHOSN,PATM,QVATM,QCATM, & - GLW,GSWnew,EMISS,RNET, & - QKMS,TKMS,RHO,myj, & + ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & + RHOSN,PATM,QVATM,QCATM, & + GLW,GSWnew,EMISS,RNET, & + QKMS,TKMS,RHO,myj, & !--- sea ice parameters ALB,ZNT, & - tice,rhosice,capice,thdifice, & - zsmain,zshalf,DTDZS,DTDZS2,tbq, & + tice,rhosice,capice,thdifice, & + zsmain,zshalf,DTDZS,DTDZS2,tbq, & !--- constants - lv,CP,rovcp,cw,stbolt,tabs, & + lv,CP,rovcp,cw,stbolt,tabs, & !--- output variables - ilnb,snweprint,snheiprint,rsm,ts1d, & - dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & - SMELT,SNOH,SNFLX,SNOM,eeta, & - qfx,hfx,s,sublim,prcpl,fltot & - ) + ilnb,snweprint,snheiprint,rsm,ts1d, & + dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & + SMELT,SNOH,SNFLX,SNOM,eeta, & + qfx,hfx,s,sublim,prcpl,fltot & + ) edir1 = eeta*1.e-3_kind_phys ec1 = zero ett1 = zero @@ -2128,13 +2154,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia IF (debug_print ) THEN print *,'SOILT combined on ice', soilt ENDIF - endif + endif endif ! snow_mosaic = 1. - + !-- 13 jan 2022 ! update snow fraction after melting (Swenson, S.C. and Lawrence, 2012, - ! JGR, DOI:10.1029/2012MS000165 - ! + ! JGR, DOI:10.1029/2012MS000165 + ! !if (snwe > 0.) then ! if(smelt > 0.) then !update snow fraction after melting @@ -2152,7 +2178,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !else ! snowfrac = 0. !endif - ! + ! !-- The NY07 parameterization gives more realistic snow cover fraction ! than SL12 !-- 13 Jan 2022 @@ -2193,7 +2219,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of ! snow cover fractions on the 3-km scale. ! This factor is scale dependent. - snowfrac = tanh( snhei/(10._kind_phys * facsnf *(rhosn/rhonewsn)**m)) + snowfrac = tanh( snhei/(10._kind_phys * facsnf *(rhosn/rhonewsn)**m)) endif !-- due to steep slopes and blown snow, limit snow fraction in the @@ -2251,7 +2277,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin, & EMISS,RNET,QKMS,TKMS,PC,cst,drip,infwater, & rho,vegfrac,lai,myj, & -!--- soil fixed fields +!--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt, & psis,bclh,ksat,sat,cn, & zsmain,zshalf,DTDZS,DTDZS2,tbq, & @@ -2355,7 +2381,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& soiliqw,infiltrp,smf) !************************************************************* -! Energy and moisture budget for vegetated surfaces +! Energy and moisture budget for vegetated surfaces ! without snow, heat diffusion and Richards eqns. in ! soil ! @@ -2573,7 +2599,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& RAS=RHO*1.E-3_kind_phys ! rho/rhowater RIW=rhoice*1.e-3_kind_phys ! rhoice/rhowater -!--- Computation of volumetric content of ice in soil +!--- Computation of volumetric content of ice in soil DO K=1,NZS !- main levels @@ -2659,8 +2685,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& thdif,diffu,hydro,cap) !******************************************************************** -!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW - +!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW + FQ=QKMS Q1=-QKMS*RAS*(QVATM - QSG) @@ -2716,7 +2742,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& ! fc=max(qmin,ref*0.5) ! used prior to 20jun18 change ! Switch from ref*0.5 to ref*0.25 will reduce soil resistance, increase direct ! evaporation, effects sparsely vegetated areas--> cooler during the day -! fc=max(qmin,ref*0.25) ! +! fc=max(qmin,ref*0.25) ! ! For now we'll go back to ref*0.5 ! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct ! evaporation. Therefore , it is replaced with ref*0.7. @@ -2746,7 +2772,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& PRCPMS,RAINF, & PATM,TABS,QVATM,QCATM,EMISS,RNET, & QKMS,TKMS,PC,rho,vegfrac, lai, & - thdif,cap,drycan,wetcan, & + thdif,cap,drycan,wetcan, & transum,dew,mavail,soilres,alfa, & !--- soil fixed fields dqm,qmin,bclh,zsmain,zshalf,DTDZS,tbq, & @@ -2787,7 +2813,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& tln=log(tso(k)/tfrz) if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/grav/psis) & + (tso(k)-tfrz)/tso(k)/grav/psis) & **(-one/bclh)-qmin soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -2805,7 +2831,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& ENDDO !************************************************************************* -! SOILMOIST solves moisture budget (Smirnova et al., 1996, EQ.22,28) +! SOILMOIST solves moisture budget (Smirnova et al., 1996, EQ.22,28) ! and Richards eqn. !************************************************************************* CALL SOILMOIST (debug_print, & @@ -2821,7 +2847,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& !-- output SOILMOIS,SOILIQW,MAVAIL,RUNOFF1, & RUNOFF2,INFILTRP) - + !--- KEEPFR is 1 when the temperature and moisture in soil !--- are both increasing. In this case soil ice should not !--- be increasing according to the freezing curve. @@ -2830,7 +2856,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& !--- changed, and phase changes are not affecting the heat !--- transfer. This situation may happen when it rains on the !--- frozen soil. - + do k=1,nzs if (soilice(k).gt.zero) then if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then @@ -2841,7 +2867,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& endif enddo -!--- THE DIAGNOSTICS OF SURFACE FLUXES +!--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*SOILTold*SOILTold*SOILTold UPFLUX = T3 * 0.5_kind_phys*(SOILTold+SOILT) @@ -3039,7 +3065,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & TABS, T3, UPFLUX, XINET real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & - epot,fltot,ft,fq,hft,ras,cvw + epot,fltot,ft,fq,hft,ras,cvw real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & @@ -3141,7 +3167,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW DEW=zero -!--- THE DIAGNOSTICS OF SURFACE FLUXES +!--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*TN*TN*TN UPFLUX = T3 *0.5_kind_phys*(TN+SOILT) XINET = EMISS*(GLW-UPFLUX) @@ -3216,7 +3242,7 @@ END SUBROUTINE SICE !>\ingroup lsm_ruc_group !! This subroutine is called for snow covered areas of land. It -!! solves energy and moisture budgets on the surface of snow, and +!! solves energy and moisture budgets on the surface of snow, and !! on the interface of snow and soil. It computes skin temperature, !! snow temperature, snow depth and snow melt. SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & @@ -3361,10 +3387,10 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & real (kind_phys), INTENT(IN ) :: CN, & CW, & XLV, & - G0_P, & + G0_P, & KQWRTZ, & KICE, & - KWT + KWT real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & @@ -3491,7 +3517,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & IF (debug_print ) THEN print *,'DELTSN is changed,deltsn,snhei,snth',i,j,deltsn,snhei,snth ENDIF - ENDIF + ENDIF CI=RHOICE*sheatice RAS=RHO*1.E-3_kind_dbl_prec ! rho/rhowater @@ -3514,7 +3540,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & tranf (k)=zero detal (k)=zero told (k)=zero - smold (k)=zero + smold (k)=zero ENDDO snweprint=zero @@ -3610,16 +3636,16 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & soilmois,soiliqw,soilice, & soilmoism,soiliqwm,soilicem, & !--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & + QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & !--- constants riw,xlmelt,CP,G0_P,cvw,ci, & kqwrtz,kice,kwt, & !--- output variables thdif,diffu,hydro,cap) -!******************************************************************** -!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW - +!******************************************************************** +!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW + SMELT=zero H=MAVAIL ! =1. if snowfrac=1 @@ -3627,11 +3653,11 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- If vegfrac.ne.0. then part of falling snow can be -!--- intercepted by the canopy. +!--- intercepted by the canopy. DEW=zero UMVEG=one-vegfrac - EPOT = -FQ*(QVATM-QSG) + EPOT = -FQ*(QVATM-QSG) IF (debug_print ) THEN print *,'SNWE after subtracting intercepted snow - snwe=',snwe,vegfrac,cst @@ -3643,7 +3669,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ! check if all snow can evaporate during DT BETA=one EPDT = EPOT * RAS *DELT - IF(EPDT > zero .and. SNWEPR.LE.EPDT) THEN + IF(EPDT > zero .and. SNWEPR.LE.EPDT) THEN BETA=SNWEPR/EPDT SNWE=zero ENDIF @@ -3659,7 +3685,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- input variables nzs,nroot,soiliqw,tabs,lai,gswin, & !--- soil fixed fields - dqm,qmin,ref,wilt,zshalf,pc,iland, & + dqm,qmin,ref,wilt,zshalf,pc,iland, & !--- output variables tranf,transum) @@ -3763,8 +3789,8 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & DQM,QMIN,REF,KSAT,RAS,INFMAX, & !-- output SOILMOIS,SOILIQW,MAVAIL,RUNOFF1, & - RUNOFF2,infiltrp) - + RUNOFF2,infiltrp) + ! endif !-- Restore land-use parameters if all snow is melted @@ -3798,13 +3824,13 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & T3 = STBOLT*SOILTold*SOILTold*SOILTold UPFLUX = T3 *0.5_kind_phys*(SOILTold+SOILT) - XINET = EMISS*(GLW-UPFLUX) + XINET = EMISS*(GLW-UPFLUX) HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001_kind_phys/Patm)**ROVCP IF (debug_print ) THEN print *,'potential temp HFX',hfx ENDIF - HFT=-TKMS*CP*RHO*(TABS-SOILT) + HFT=-TKMS*CP*RHO*(TABS-SOILT) IF (debug_print ) THEN print *,'abs temp HFX',hft ENDIF @@ -3888,8 +3914,8 @@ END SUBROUTINE SNOWSOIL !>\ingroup lsm_ruc_group !! This subroutine is called for sea ice with accumulated snow on -!! its surface. It solves energy budget on the snow interface with -!! atmosphere and snow interface with ice. It calculates skin +!! its surface. It solves energy budget on the snow interface with +!! atmosphere and snow interface with ice. It calculates skin !! temperature, snow and ice temperatures, snow depth and snow melt. SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & @@ -3909,7 +3935,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & qfx,hfx,s,sublim,prcpl,fltot & ) !*************************************************************** -! Solving energy budget for snow on sea ice and heat diffusion +! Solving energy budget for snow on sea ice and heat diffusion ! eqns. in snow and sea ice !*************************************************************** @@ -4087,12 +4113,12 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & endif if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 4.431718e-7_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -4241,7 +4267,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ENDIF !************************************************************************ -!--- THE HEAT BALANCE EQUATION +!--- THE HEAT BALANCE EQUATION !18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes nmelt=0 SNOH=zero @@ -4262,7 +4288,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & R7=R6/TN D11=RNET+R6 - IF(SNHEI.GE.SNTH) THEN + IF(SNHEI.GE.SNTH) THEN if(snhei.le.DELTSN+SNTH) then !--- 1-layer snow D1SN = cotso(NZS) @@ -4539,10 +4565,10 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys endif - + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. @@ -4634,7 +4660,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & IF (debug_print ) THEN print *,'SNOW is thin, snflx',i,j,snflx ENDIF - ELSE + ELSE SNFLX=D9SN*(SOILT-TSOB) IF (debug_print ) THEN print *,'SNOW is GONE, snflx',i,j,snflx @@ -4701,13 +4727,13 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon,testptlat,testptlon,& TSO,SOILT,QVG,QSG,QCG,X) !---output variables !************************************************************* -! Energy budget equation and heat diffusion eqn are +! Energy budget equation and heat diffusion eqn are ! solved here and ! ! DELT - time step (s) ! ktau - number of time step ! CONFLX - depth of constant flux layer (m) -! IME, JME, KME, NZS - dimensions of the domain +! IME, JME, KME, NZS - dimensions of the domain ! NROOT - number of levels within the root zone ! PRCPMS - precipitation rate in m/s ! COTSO, RHTSO - coefficients for implicit solution of @@ -4733,7 +4759,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon,testptlat,testptlon,& ! transpiration may take place (0-1) ! WETCAN - fraction of vegetated area covered by canopy ! water (0-1) -! TRANSUM - transpiration function integrated over the +! TRANSUM - transpiration function integrated over the ! rooting zone (m) ! DEW - dew in kg/m^2s ! MAVAIL - fraction of maximum soil moisture in the top @@ -4770,11 +4796,11 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon,testptlat,testptlon,& INTENT(IN ) :: & EMISS, & RHO, & - RNET, & + RNET, & PC, & VEGFRAC, & LAI, & - DEW, & + DEW, & QKMS, & TKMS @@ -4900,7 +4926,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon,testptlat,testptlon,& CC=C*XLV/TDENOM AA=XLV*(FKQ*UMVEG+R210)/TDENOM BB=(D10*TABS+R21*TN+XLV*(QVATM* & - (FKQ*UMVEG+C) & + (FKQ*UMVEG+C) & +R210*QVG)+D11+D9*(D2+R22*TN) & +RAINF*CVW*PRCPMS*max(tfrz,TABS) & )/TDENOM @@ -4939,7 +4965,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon,testptlat,testptlon,& QSG=QS1 QVG=Q1 ! if( QS1>QVATM .and. QVATM > QVG) then - ! very dry soil + ! very dry soil ! print *,'very dry soils mavail,qvg,qs1,qvatm,ts1',i,j,mavail,qvg,qs1,qvatm,ts1 ! QVG = QVATM ! endif @@ -4965,7 +4991,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon,testptlat,testptlon,& END DO X= (cp*rho*r211+rhcs*zsmain(2)*0.5_kind_phys/delt)*(SOILT-TN) + & - XLV*rho*r211*(QVG-QGOLD) + XLV*rho*r211*(QVG-QGOLD) IF (debug_print ) THEN print*,'SOILTEMP storage, i,j,x,soilt,tn,qvg,qvgold', & @@ -4987,7 +5013,7 @@ END SUBROUTINE SOILTEMP !-------------------------------------------------------------------- !>\ingroup lsm_ruc_group -!> This subroutine solves energy bugdget equation and heat diffusion +!> This subroutine solves energy bugdget equation and heat diffusion !! equation to obtain snow and soil temperatures. SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & testptlat,testptlon,i,j,iland,isoil, & !--- input variables @@ -5009,13 +5035,13 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & SMELT,SNOH,SNFLX,S,ILNB,X) !******************************************************************** -! Energy budget equation and heat diffusion eqn are +! Energy budget equation and heat diffusion eqn are ! solved here to obtain snow and soil temperatures ! ! DELT - time step (s) ! ktau - number of time step ! CONFLX - depth of constant flux layer (m) -! IME, JME, KME, NZS - dimensions of the domain +! IME, JME, KME, NZS - dimensions of the domain ! NROOT - number of levels within the root zone ! PRCPMS - precipitation rate in m/s ! COTSO, RHTSO - coefficients for implicit solution of @@ -5038,10 +5064,10 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ! VEGFRAC - greeness fraction (0-1) ! CAP - volumetric heat capacity (J/m^3/K) ! DRYCAN - dry fraction of vegetated area where -! transpiration may take place (0-1) +! transpiration may take place (0-1) ! WETCAN - fraction of vegetated area covered by canopy ! water (0-1) -! TRANSUM - transpiration function integrated over the +! TRANSUM - transpiration function integrated over the ! rooting zone (m) ! DEW - dew in kg/m^2/s ! MAVAIL - fraction of maximum soil moisture in the top @@ -5068,7 +5094,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & - testptlat,testptlon , & + testptlat,testptlon , & rhonewsn,meltfactor,xlat,xlon,snhei_crit real :: rhonewcsn @@ -5107,7 +5133,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ZSHALF, & THDIF, & CAP, & - TRANF + TRANF real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS @@ -5141,7 +5167,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & SOILT1, & TSNAV - real (kind_phys), INTENT(INOUT) :: DRYCAN, WETCAN + real (kind_phys), INTENT(INOUT) :: DRYCAN, WETCAN real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & @@ -5157,7 +5183,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - real (kind_phys) :: t3,upflux,xinet,ras, & + real (kind_phys) :: t3,upflux,xinet,ras, & xlmelt,rhocsn,thdifsn, & beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn @@ -5167,7 +5193,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & TDENOM,C,CC,AA1,RHCS,H1, & tsob, snprim, sh1, sh2, & smeltg,snohg,snodif,soh, & - CMC2MS,TNOLD,QGOLD,SNOHGNEW + CMC2MS,TNOLD,QGOLD,SNOHGNEW real (kind_phys), DIMENSION(1:NZS) :: transp,cotso,rhtso real (kind_phys) :: edir1, & @@ -5196,7 +5222,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & enddo IF (debug_print ) THEN -print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt +print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt ENDIF XLMELT=con_hfus RHOCSN=sheatsn* RHOSN @@ -5222,8 +5248,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & endif if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. @@ -5501,7 +5527,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(nmelt==1 .and. snowfrac==one .and. snwe > zero .and. SOILT > tfrz) then !--7feb22 on the second iteration when SNOH is known and snwe > 0. after melting, !-- check if the snow skin temperature is = zero .and. SNHEI < SNTH) THEN -! blended +! blended TSO(2)=rhtso(NZS1)+cotso(NZS1)*SOILT tso(1)=(tso(2)+(soilt-tso(2))*fso) SOILT1=TSO(1) @@ -5618,7 +5644,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & EC1 = Q1 * WETCAN * vegfrac CMC2MS=CST/DELT*RAS EETA = (EDIR1 + EC1 + ETT1)*rhowater -! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ +! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= XLVM * EETA ENDIF @@ -5643,9 +5669,9 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ENDIF !-- SNOH is energy flux of snow phase change - SNOH=RNET-QFX -HFX - SOH - X & + SNOH=RNET-QFX -HFX - SOH - X & +RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-soiltfrac) & - +RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac) + +RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac) SNOH=AMAX1(0.,SNOH) !-- SMELT is speed of melting in M/S SMELT= SNOH /XLMELT*1.E-3_kind_phys @@ -5670,7 +5696,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- 22apr22 Do not limit snow melting for hail (rhonewsn > 450), or dense snow !-- (rhosn > 350.) with very warm surface temperatures (>10C) if( (rhosn < 350._kind_phys .or. (newsnow > zero .and. rhonewsn < 450._kind_phys)) .and. soilt < 283._kind_phys ) then - SMELT= amin1 (smelt, delt/60._kind_phys*5.6E-8_kind_phys*meltfactor*max(one,(soilt-tfrz))) + SMELT= amin1 (smelt, delt/60._kind_phys*5.6E-8_kind_phys*meltfactor*max(one,(soilt-tfrz))) IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'3- SMELT',xlat,xlon,smelt,rhosn,rhonewsn,xlat,xlon @@ -5753,8 +5779,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ENDIF -!18apr08 - if snow melt occurred then go into iteration for energy budget -! solution +!18apr08 - if snow melt occurred then go into iteration for energy budget +! solution if(nmelt.eq.1) goto 212 ! second interation 220 continue @@ -5796,8 +5822,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & endif if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. @@ -5811,7 +5837,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'END SNOWTEMP - thdifsn',xlat,xlon,thdifsn print *,'END SNOWTEMP - 0.265/rhocsn',0.265/rhocsn endif - endif + endif endif !--- Compute flux in the top snow layer @@ -5889,7 +5915,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & SNHEI=SNWE * rhowater / RHOSN !-- add up all snow melt SMELT = SMELT + SMELTG - + if(snhei > zero) TSO(1) = soiltfrac IF (debug_print ) THEN @@ -5958,8 +5984,8 @@ SUBROUTINE SOILMOIST ( debug_print, & SOILMOIS,SOILIQW,MAVAIL,RUNOFF,RUNOFF2,INFILTRP) !--- output !************************************************************************* ! moisture balance equation and Richards eqn. -! are solved here -! +! are solved here +! ! DELT - time step (s) ! IME,JME,NZS - dimensions of soil domain ! ZSMAIN - main levels in soil (m) @@ -5985,7 +6011,7 @@ SUBROUTINE SOILMOIST ( debug_print, & ! VEGFRAC - greeness fraction (0-1) ! RAS - ration of air density to soil density ! INFMAX - maximum infiltration rate (kg/m^2/s) -! +! ! SOILMOIS - volumetric soil moisture, 6 levels (m^3/m^3) ! MAVAIL - fraction of maximum soil moisture in the top ! layer (0-1) @@ -6021,12 +6047,12 @@ SUBROUTINE SOILMOIST ( debug_print, & QKMS,VEGFRAC,DRIP,PRCP , & DEW,SMELT,SNOWFRAC , & DQM,QMIN,REF,KSAT,RAS,RIW,SOILRES - + ! output real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: SOILMOIS,SOILIQW - + real (kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & INFMAX @@ -6047,7 +6073,7 @@ SUBROUTINE SOILMOIST ( debug_print, & !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR SOILMOIS !****************************************************************************** - NZS1=NZS-1 + NZS1=NZS-1 NZS2=NZS-2 118 format(6(10Pf23.19)) @@ -6056,7 +6082,7 @@ SUBROUTINE SOILMOIST ( debug_print, & cosmc(k)=zero rhsmc(k)=zero enddo - + DID=(ZSMAIN(NZS)-ZSHALF(NZS)) X1=ZSMAIN(NZS)-ZSMAIN(NZS1) @@ -6114,12 +6140,12 @@ SUBROUTINE SOILMOIST ( debug_print, & R1=COSMC(NZS1) R2= RHSMC(NZS1) R3=DIFFU(1)/DZS - R4=R3+HYDRO(1)*.5_kind_phys + R4=R3+HYDRO(1)*.5_kind_phys R5=R3-HYDRO(2)*.5_kind_phys R6=QKMS*RAS !-- Total liquid water available on the top of soil domain !-- Without snow - 3 sources of water: precipitation, -!-- water dripping from the canopy and dew +!-- water dripping from the canopy and dew !-- With snow - only one source of water - snow melt 191 format (f23.19) @@ -6266,7 +6292,7 @@ SUBROUTINE SOILMOIST ( debug_print, & print *,'COSMC,RHSMC',COSMC,RHSMC endif ENDIF -!--- FINAL SOLUTION FOR SOILMOIS +!--- FINAL SOLUTION FOR SOILMOIS ! DO K=2,NZS1 DO K=2,NZS KK=NZS-K+1 @@ -6294,7 +6320,7 @@ SUBROUTINE SOILMOIST ( debug_print, & abs(xlon-testptlon).lt.0.05)then print *,'xlat,xlon=',xlat,xlon print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw - endif + endif ENDIF MAVAIL=max(.00001_kind_phys,min(one,(SOILMOIS(1)/(REF-QMIN)*(one-snowfrac)+one*snowfrac))) @@ -6303,7 +6329,7 @@ END SUBROUTINE SOILMOIST !------------------------------------------------------------------- !>\ingroup lsm_ruc_group -!! This subroutine computes thermal diffusivity, and diffusional and +!! This subroutine computes thermal diffusivity, and diffusional and !! hydraulic condeuctivities in soil. SUBROUTINE SOILPROP( debug_print, & xlat, xlon, testptlat, testptlon, & @@ -6348,7 +6374,7 @@ SUBROUTINE SOILPROP( debug_print, & DQM, & KSAT, & PSIS, & - QWRTZ, & + QWRTZ, & QMIN real (kind_phys), DIMENSION( 1:nzs ) , & @@ -6358,7 +6384,7 @@ SUBROUTINE SOILPROP( debug_print, & real (kind_phys), INTENT(IN ) :: CP, & CVW, & - RIW, & + RIW, & kqwrtz, & kice, & kwt, & @@ -6384,8 +6410,8 @@ SUBROUTINE SOILPROP( debug_print, & INTEGER :: nzs1,k !-- for Johansen thermal conductivity - real (kind_phys) :: kzero,gamd,kdry,kas,x5,sr,ke - + real (kind_phys) :: kzero,gamd,kdry,kas,x5,sr,ke + nzs1=nzs-1 @@ -6430,7 +6456,7 @@ SUBROUTINE SOILPROP( debug_print, & END IF IF(soilicem(k).NE.zero.AND.TN.LT.zero) then -!--- DETAL is taking care of energy spent on freezing or released from +!--- DETAL is taking care of energy spent on freezing or released from ! melting of soil water DETAL(K)=tfrz*X2/(TAV(K)*TAV(K))* & @@ -6468,7 +6494,7 @@ SUBROUTINE SOILPROP( debug_print, & if((ws-a).lt.0.12_kind_phys)then diffu(K)=zero else - H=max(zero,(soilmoism(K)+qmin-a)/(max(1.e-8_kind_phys,(ws-a)))) + H=max(zero,(soilmoism(K)+qmin-a)/(max(1.e-8_kind_phys,(ws-a)))) facd=one if(a.ne.zero)facd=one-a/max(1.e-8_kind_phys,soilmoism(K)) ame=max(1.e-8_kind_phys,ws-riw*soilicem(K)) @@ -6498,7 +6524,7 @@ SUBROUTINE SOILPROP( debug_print, & fach=one-riw*soilice(k)/max(1.e-8_kind_phys,soilmois(k)) am=max(1.e-8_kind_phys,ws-riw*soilice(k)) !--- HYDRO is hydraulic conductivity of soil water - hydro(K)=min(KSAT,KSAT/am* & + hydro(K)=min(KSAT,KSAT/am* & (soiliqw(K)/am) & **(2._kind_phys*BCLH+2._kind_phys) & * fach) @@ -6554,9 +6580,9 @@ SUBROUTINE TRANSF( debug_print, & real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & ZSHALF -!-- output +!-- output real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF - real (kind_phys), INTENT(OUT) :: TRANSUM + real (kind_phys), INTENT(OUT) :: TRANSUM !-- local variables real (kind_phys) :: totliq, did @@ -6597,7 +6623,7 @@ SUBROUTINE TRANSF( debug_print, & TRANF(1)=zero ELSE TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID - ENDIF + ENDIF !-- uncomment next line for non-linear root distribution !TRANF(1)=part(1) @@ -6673,7 +6699,7 @@ SUBROUTINE TRANSF( debug_print, & ! else ! fsol=cmin/cmax ! endif -! totcnd = max(lai/rstbl(iland), pctot * ftem * f1) +! totcnd = max(lai/rstbl(iland), pctot * ftem * f1) ! Mahrer & Avissar (1982), Avissar et al. (1985) if (GSWin < rgltbl(iland)) then fsol = one / (one + exp(-0.034_kind_phys * (GSWin - 3.5_kind_phys))) @@ -6714,7 +6740,7 @@ END SUBROUTINE TRANSF !>\ingroup lsm_ruc_group !> This subroutine finds the solution of energy budget at the surface -!! from the pre-computed table of saturated water vapor mixing ratio +!! from the pre-computed table of saturated water vapor mixing ratio !! and estimated surface temperature. SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) !-------------------------------------------------------------- @@ -6973,7 +6999,7 @@ SUBROUTINE SOILVEGIN ( debug_print,mosaic_lu,mosaic_soil, & .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95, & .85,.85,.90 / !-- Roughness length is changed for forests and some others - DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & + DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05, & .01,.15,.01 / @@ -7068,7 +7094,7 @@ SUBROUTINE SOILVEGIN ( debug_print,mosaic_lu,mosaic_soil, & LAItoday(k) = LAITBL(K) - deltalai(k) * factor if(IFORTBL(k) == 7) then -!-- seasonal change of roughness length for crops +!-- seasonal change of roughness length for crops ZNTtoday(k) = Z0TBL(K) - 0.125_kind_phys * factor else ZNTtoday(k) = Z0TBL(K) @@ -7130,7 +7156,7 @@ SUBROUTINE SOILVEGIN ( debug_print,mosaic_lu,mosaic_soil, & MSNF = MSNF /AREA FACSNF= FACSNF /AREA - IF (debug_print ) THEN + IF (debug_print ) THEN print *,'mosaic=',j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),EMISS,ZNT,ZNT1,LAI,PC ENDIF @@ -7287,7 +7313,7 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & IF ( errflag .EQ. 1 ) THEN print *,& "module_sf_ruclsm.F: lsminit: out of range value "// & - "of ISLTYP. Is this field in the input?" + "of ISLTYP. Is this field in the input?" ENDIF DO J=jts,jtf @@ -7296,7 +7322,7 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & ! in Zobler classification isltyp=0 for water. Statsgo classification ! has isltyp=14 for water if (isltyp(i,j) == 0) isltyp(i,j)=14 - + if(landfrac(i) > zero ) then !-- land !-- Computate volumetric content of ice in soil @@ -7313,7 +7339,7 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & DO L=1,NZS !-- for land points initialize soil ice tln=log(TSLB(i,l,j)/tfrz) - + if(tln.lt.zero) then soiliqw(l)=(dqm+qmin)*(XLMELT* & (tslb(i,l,j)-tfrz)/tslb(i,l,j)/grav/psis) & @@ -7322,7 +7348,7 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & soiliqw(l)=min(soiliqw(l),smois(i,l,j)) sh2o(i,l,j)=soiliqw(l) smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW - + else smfr3d(i,l,j)=zero sh2o(i,l,j)=smois(i,l,j) @@ -7336,7 +7362,7 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & smfr3d(i,l,j)=one sh2o(i,l,j)=zero ENDDO - + else !-- water ISLTYP=14 mavail(i,j) = one @@ -7394,8 +7420,8 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) ! LAI: Leaf area index (dimensionless) ! MAXALB: Upper bound on maximum albedo over deep snow ! -!-----READ IN VEGETAION PROPERTIES FROM VEGPARM.TBL -! +!-----READ IN VEGETAION PROPERTIES FROM VEGPARM.TBL +! ! IF ( wrf_dm_on_monitor() ) THEN @@ -7414,7 +7440,7 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) !sms$serial begin READ (19,'(A)') vege_parm_string !sms$serial end - outer : DO + outer : DO !sms$serial begin READ (19,2000,END=2002)LUTYPE READ (19,*)LUCATS,IINDEX @@ -7499,7 +7525,7 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) ENDIF !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL -! +! ! IF ( wrf_dm_on_monitor() ) THEN OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) IF(ierr .NE. OPEN_OK ) THEN @@ -7564,14 +7590,14 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) CLOSE (19) IF(LUMATCH.EQ.0)THEN - print *, 'SOIl TEXTURE IN INPUT FILE DOES NOT ' - print *, 'MATCH SOILPARM TABLE' - print *, 'INCONSISTENT OR MISSING SOILPARM FILE' + print *, 'SOIl TEXTURE IN INPUT FILE DOES NOT ' + print *, 'MATCH SOILPARM TABLE' + print *, 'INCONSISTENT OR MISSING SOILPARM FILE' ENDIF ! -!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL -! +!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL +! OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) IF(ierr .NE. OPEN_OK ) THEN print *,& @@ -7703,7 +7729,7 @@ END SUBROUTINE SOILIN !+---+-----------------------------------------------------------------+ !>\ingroup lsm_ruc_group -!> This function calculates the liquid saturation vapor mixing ratio as +!> This function calculates the liquid saturation vapor mixing ratio as !! a function of temperature and pressure (from Thompson scheme). real (kind_phys) FUNCTION RSLF(P,T) diff --git a/physics/SFC_Models/SeaIce/CICE/sfc_cice.f b/physics/SFC_Models/SeaIce/CICE/sfc_cice.f index 3147c0aa1..d6da62a54 100644 --- a/physics/SFC_Models/SeaIce/CICE/sfc_cice.f +++ b/physics/SFC_Models/SeaIce/CICE/sfc_cice.f @@ -2,8 +2,8 @@ !! This file contains the sfc_sice for coupling to CICE !> This module contains the CCPP-compliant GFS sea ice post -!! interstitial codes, which returns updated ice thickness and -!! concentration to global arrays where there is no ice, and +!! interstitial codes, which returns updated ice thickness and +!! concentration to global arrays where there is no ice, and !! set temperature to surface skin temperature. !> This module contains the CCPP-compliant GFS sea ice scheme. @@ -16,8 +16,6 @@ module sfc_cice !! \htmlinclude sfc_cice_run.html !! -!! use physcons, only : hvap => con_hvap, cp => con_cp, & -!! & rvrdm1 => con_fvirt, rd => con_rd ! !----------------------------------- subroutine sfc_cice_run & @@ -91,8 +89,8 @@ subroutine sfc_cice_run & real (kind=kind_phys), dimension(:), intent(in) :: & & t1, q1, cm, ch, prsl1, wind real (kind=kind_phys), dimension(:), intent(in) :: & - & snowd - + & snowd + real (kind=kind_phys), dimension(:), intent(in) :: & & dqsfc, dtsfc, dusfc, dvsfc logical, dimension(:), intent(in) :: flag_cice, flag_iter @@ -147,7 +145,7 @@ subroutine sfc_cice_run & ep(i) = evap(i) endif enddo - + return !----------------------------------- end subroutine sfc_cice_run diff --git a/physics/docs/ccppsrw_doxyfile b/physics/docs/ccppsrw_doxyfile index 8cca33ab8..0af73ed72 100644 --- a/physics/docs/ccppsrw_doxyfile +++ b/physics/docs/ccppsrw_doxyfile @@ -1018,7 +1018,7 @@ INPUT = pdftxt/SRW_mainpage.txt \ pdftxt/THOMPSON.txt \ pdftxt/suite_input.nml.txt \ pdftxt/CLM_LAKE.txt \ - pdftxt/acronyms.txt \ + pdftxt/acronyms.txt \ ../MP \ ../CONV \ ../GWD \ @@ -1027,7 +1027,7 @@ INPUT = pdftxt/SRW_mainpage.txt \ ../SFC_Models \ ../photochem \ ../smoke_dust \ - ../Radiation \ + ../Radiation \ ../Interstitials/UFS_SCM_NEPTUNE @@ -1092,7 +1092,7 @@ RECURSIVE = YES EXCLUDE = ../Radiation/RRTMGP/rte-rrtmgp \ ../Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.F90 \ ../MP/Morrison_Gettelman \ - ../MP/Ferrier_Aligo \ + ../MP/Ferrier_Aligo \ ../MP/Zhao_Carr \ ../PBL/MYJ \ ../MP/GFDL/GFDL_parse_tracers.F90 \ @@ -1418,6 +1418,7 @@ HTML_HEADER = _doxygen/header.html # This tag requires that the tag GENERATE_HTML is set to YES. HTML_FOOTER = _doxygen/footer.html +<<<<<<< HEAD # The HTML_STYLESHEET tag can be used to specify a user-defined cascading style # sheet that is used by each HTML page. It can be used to fine-tune the look of @@ -1460,6 +1461,13 @@ HTML_EXTRA_STYLESHEET = _doxygen/doxygen-awesome.css \ # files will be copied as-is; there are no commands or markers available. # This tag requires that the tag GENERATE_HTML is set to YES. +======= +HTML_STYLESHEET = +HTML_EXTRA_STYLESHEET = _doxygen/doxygen-awesome.css \ + _doxygen/doxygen-awesome-sidebar-only.css \ + _doxygen/doxygen-awesome-sidebar-only-darkmode-toggle.css \ + _doxygen/doxygen-awesome-ccpp.css +>>>>>>> d9e7a242 (Physcons removal, documentation and comments cleanup) HTML_EXTRA_FILES = _doxygen/doxygen-awesome-darkmode-toggle.js \ _doxygen/doxygen-awesome-ccpp.js @@ -2615,6 +2623,7 @@ HAVE_DOT = YES # This tag requires that the tag HAVE_DOT is set to YES. DOT_NUM_THREADS = 0 +<<<<<<< HEAD # DOT_COMMON_ATTR is common attributes for nodes, edges and labels of # subgraphs. When you want a differently looking font in the dot files that @@ -2650,6 +2659,10 @@ DOT_NODE_ATTR = "shape=box,height=0.2,width=0.4" # DOT_COMMON_ATTR and others dot attributes. # This tag requires that the tag HAVE_DOT is set to YES. +======= +DOT_FONTNAME = Source Sans Pro +DOT_FONTSIZE = +>>>>>>> d9e7a242 (Physcons removal, documentation and comments cleanup) DOT_FONTPATH = # If the CLASS_GRAPH tag is set to YES or GRAPH or BUILTIN then Doxygen will diff --git a/physics/hooks/physcons.F90 b/physics/hooks/physcons.F90 deleted file mode 100644 index b368f1e6d..000000000 --- a/physics/hooks/physcons.F90 +++ /dev/null @@ -1,170 +0,0 @@ -!> \file physcons.F90 -!! This file contains module physcons - -! ========================================================== !!!!! -! module 'physcons' description !!!!! -! ========================================================== !!!!! -! ! -! this module contains some the most frequently used math and ! -! physics constatns for gcm models. ! -! ! -! references: ! -! as set in NMC handbook from Smithsonian tables. ! -! ! -! modification history: ! -! ! -! 1990-04-30 g and rd are made consistent with NWS usage ! -! 2001-10-22 g made consistent with SI usage ! -! 2005-04-13 added molecular weights for gases - y-t hou ! -! 2013-07-12 added temperature for homogen. nuc. for ice. - R.sun ! -! ! -! external modules referenced: ! -! ! -! 'module machine' in 'machine.f' ! -! ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - -!> \defgroup physcons GFS Physics Constants Module -!> This module contains some of the most frequently used math and physics -!! constants for GCM models. - -!> This module contains some of the most frequently used math and physics -!! constants for GCM models. - module physcons -! - use machine, only: kind_phys, kind_dyn -! - implicit none -! - public - -!> \name Math constants -! real(kind=kind_phys),parameter:: con_pi =3.1415926535897931 !< pi - real(kind=kind_phys),parameter:: con_pi =4.0d0*atan(1.0d0) !< pi - real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0_kind_phys !< square root of 2 - real(kind=kind_phys),parameter:: con_sqrt3 =1.732051e+0_kind_phys !< quare root of 3 - -!> \name Geophysics/Astronomy constants - real(kind=kind_phys),parameter:: con_rerth =6.3712e+6_kind_phys !< radius of earth (\f$m\f$) - real(kind=kind_phys),parameter:: con_g =9.80665e+0_kind_phys !< gravity (\f$m/s^{2}\f$) - real(kind=kind_phys),parameter:: con_omega =7.2921e-5_kind_phys !< ang vel of earth (\f$s^{-1}\f$) - real(kind=kind_phys),parameter:: con_p0 =1.01325e5_kind_phys !< standard atmospheric pressure (\f$Pa\f$) -! real(kind=kind_phys),parameter:: con_solr =1.36822e+3_kind_phys ! solar constant (W/m2)-aer(2001) - real(kind=kind_phys),parameter:: con_solr_2002 =1.3660e+3_kind_phys !< solar constant (\f$W/m^{2}\f$)-Liu(2002) - real(kind=kind_phys),parameter:: con_solr_2008 =1.3608e+3_kind_phys !< solar constant (\f$W/m^{2}\f$)-nasa-sorce Tim(2008) -! real(kind=kind_phys),parameter:: con_solr =1.36742732e+3_kind_phys ! solar constant (W/m2)-gfdl(1989) - OPR as of Jan 2006 - ! Selected geophysics/astronomy constants with kind=kind_dyn - real(kind=kind_dyn), parameter:: con_g_dyn =9.80665e+0_kind_dyn !< gravity (\f$m/s^{2}\f$) - -!> \name Thermodynamics constants - real(kind=kind_phys),parameter:: con_rgas =8.314472_kind_phys !< molar gas constant (\f$J/mol/K\f$) - real(kind=kind_phys),parameter:: con_rd =2.8705e+2_kind_phys !< gas constant air (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_rv =4.6150e+2_kind_phys !< gas constant H2O (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_cp =1.0046e+3_kind_phys !< spec heat air at p (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_cv =7.1760e+2_kind_phys !< spec heat air at v (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_cvap =1.8460e+3_kind_phys !< spec heat H2O gas (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_cliq =4.1855e+3_kind_phys !< spec heat H2O liq (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_csol =2.1060e+3_kind_phys !< spec heat H2O ice (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_hvap =2.5000e+6_kind_phys !< lat heat H2O cond (\f$J/kg\f$) -! real(kind=kind_phys),parameter:: con_hvap =2.5010e+6_kind_phys ! from AMS - real(kind=kind_phys),parameter:: con_hfus =3.3358e+5_kind_phys !< lat heat H2O fusion (\f$J/kg\f$) -! real(kind=kind_phys),parameter:: con_hfus =3.3370e+5_kind_phys ! from AMS - real(kind=kind_phys),parameter:: con_psat =6.1078e+2_kind_phys !< pres at H2O 3pt (\f$Pa\f$) - real(kind=kind_phys),parameter:: con_t0c =2.7315e+2_kind_phys !< temp at 0C (K) - real(kind=kind_phys),parameter:: con_ttp =2.7316e+2_kind_phys !< temp at H2O 3pt (K) - real(kind=kind_phys),parameter:: con_tice =2.7120e+2_kind_phys !< temp freezing sea (K) - real(kind=kind_phys),parameter:: con_jcal =4.1855E+0_kind_phys !< joules per calorie - real(kind=kind_phys),parameter:: con_rhw0 =1022.0_kind_phys !< sea water reference density (\f$kg/m^{3}\f$) - real(kind=kind_phys),parameter:: con_epsq =1.0E-12_kind_phys !< min q for computing precip type - real(kind=kind_phys),parameter:: con_epsqs =1.0E-10_kind_phys - ! Selected thermodynamics constants with kind=kind_dyn - real(kind=kind_dyn), parameter:: con_rd_dyn =2.8705e+2_kind_dyn !< gas constant air (\f$J/kg/K\f$) - real(kind=kind_dyn), parameter:: con_rv_dyn =4.6150e+2_kind_dyn !< gas constant H2O (\f$J/kg/K\f$) - real(kind=kind_dyn), parameter:: con_cp_dyn =1.0046e+3_kind_dyn !< spec heat air at p (\f$J/kg/K\f$) - real(kind=kind_dyn), parameter:: con_hvap_dyn =2.5000e+6_kind_dyn !< lat heat H2O cond (\f$J/kg\f$) - real(kind=kind_dyn), parameter:: con_hfus_dyn =3.3358e+5_kind_dyn !< lat heat H2O fusion (\f$J/kg\f$) - -!> \name Secondary constants - real(kind=kind_phys),parameter:: con_rocp =con_rd/con_cp - real(kind=kind_phys),parameter:: con_cpor =con_cp/con_rd - real(kind=kind_phys),parameter:: con_rog =con_rd/con_g - real(kind=kind_phys),parameter:: con_fvirt =con_rv/con_rd-1. - real(kind=kind_phys),parameter:: con_eps =con_rd/con_rv - real(kind=kind_phys),parameter:: con_epsm1 =con_rd/con_rv-1. - real(kind=kind_phys),parameter:: con_dldt =con_cvap-con_cliq - real(kind=kind_phys),parameter:: con_xpona =-con_dldt/con_rv - real(kind=kind_phys),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp) - real(kind=kind_phys),parameter:: con_1ovg = 1._kind_phys/con_g - -!> \name Other Physics/Chemistry constants (source: 2002 CODATA) - real(kind=kind_phys),parameter:: con_c =2.99792458e+8_kind_phys !< speed of light (\f$m/s\f$) - real(kind=kind_phys),parameter:: con_plnk =6.6260693e-34_kind_phys !< planck constant (\f$J/s\f$) - real(kind=kind_phys),parameter:: con_boltz =1.3806505e-23_kind_phys !< boltzmann constant (\f$J/K\f$) - real(kind=kind_phys),parameter:: con_sbc =5.670400e-8_kind_phys !< stefan-boltzmann (\f$W/m^{2}/K^{4}\f$) - real(kind=kind_phys),parameter:: con_avgd =6.0221415e23_kind_phys !< avogadro constant (\f$mol^{-1}\f$) - real(kind=kind_phys),parameter:: con_gasv =22413.996e-6_kind_phys !< vol of ideal gas at 273.15K, 101.325kPa (\f$m^{3}/mol\f$) -! real(kind=kind_phys),parameter:: con_amd =28.970_kind_phys !< molecular wght of dry air (g/mol) - real(kind=kind_phys),parameter:: con_amd =28.9644_kind_phys !< molecular wght of dry air (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amw =18.0154_kind_phys !< molecular wght of water vapor (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amo3 =47.9982_kind_phys !< molecular wght of o3 (\f$g/mol\f$) -! real(kind=kind_phys),parameter:: con_amo3 =48.0_kind_phys !< molecular wght of o3 (g/mol) - real(kind=kind_phys),parameter:: con_amco2 =44.011_kind_phys !< molecular wght of co2 (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amo2 =31.9999_kind_phys !< molecular wght of o2 (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amch4 =16.043_kind_phys !< molecular wght of ch4 (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amn2o =44.013_kind_phys !< molecular wght of n2o (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_thgni =-38.15_kind_phys !< temperature the H.G.Nuc. ice starts - real(kind=kind_phys),parameter:: karman =0.4_kind_phys !< Von Karman constant - real(kind=kind_phys),parameter:: con_runiver=con_avgd*con_boltz - -!> minimum ice concentration - real(kind=kind_phys),parameter:: cimin =0.15 !< minimum ice concentration - -!> minimum aerosol concentration - real(kind=kind_phys),parameter:: qamin = 1.e-16_kind_phys -!> minimum rain amount - real(kind=kind_phys),parameter:: rainmin = 1.e-13_kind_phys -!> \name Miscellaneous physics related constants (For WSM6; Moorthi - Jul 2014) -! integer, parameter :: max_lon=16000, max_lat=8000, min_lon=192, min_lat=94 -! integer, parameter :: max_lon=5000, max_lat=2500, min_lon=192, min_lat=94 ! current opr -! integer, parameter :: max_lon=5000, max_lat=2000, min_lon=192, min_lat=94 ! current opr -! integer, parameter :: max_lon=8000, max_lat=4000, min_lon=192, min_lat=94 ! current opr -! real(kind=kind_phys), parameter:: rlapse = 0.65e-2, rhc_max = 0.9999 ! current opr -! real(kind=kind_phys), parameter:: rlapse = 0.65e-2, rhc_max = 0.9999999 ! new -! real(kind=kind_phys), parameter:: rlapse = 0.65e-2, rhc_max = 0.9900 - - real(kind=kind_phys), parameter:: rlapse = 0.65e-2_kind_phys - real(kind=kind_phys), parameter:: cb2mb = 10.0_kind_phys, pa2mb = 0.01_kind_phys -! for wsm6 - real(kind=kind_phys),parameter:: rhowater = 1000._kind_phys !< density of water (kg/m^3) - real(kind=kind_phys),parameter:: rhosnow = 100._kind_phys !< density of snow (kg/m^3) - real(kind=kind_phys),parameter:: rhoair = 1.28_kind_phys !< density of air near surface (kg/m^3) - real(kind=kind_phys),parameter:: rholakeice = 0.917e3_kind_phys !< density of ice on lake (kg/m^3) - real(kind=kind_phys),parameter:: rhoair_IFS = 1._kind_phys !< reference air density (kg/m^3), ref: IFS - -! Decorrelation length constant (km) for iovr = 4 or 5 and idcor = 0 - real(kind=kind_phys),parameter:: decorr_con = 2.50_kind_phys - -! for gfdlmp v3 - real(kind=kind_phys), parameter :: visd = 1.717e-5 ! dynamics viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (kg/m/s) - real(kind=kind_phys), parameter :: visk = 1.35e-5 ! kinematic viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s) - real(kind=kind_phys), parameter :: vdifu = 2.25e-5 ! diffusivity of water vapor in air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s) - real(kind=kind_phys), parameter :: tcond = 2.40e-2 ! thermal conductivity of air at 0 deg C and 1000 hPa (Mason, 1971) (J/m/s/K) - real(kind=kind_phys), parameter :: cdg = 3.15121 ! drag coefficient of graupel (Locatelli and Hobbs, 1974) - real(kind=kind_phys), parameter :: cdh = 0.5 ! drag coefficient of hail (Heymsfield and Wright, 2014) - real(kind=kind_phys), parameter :: rhocw = 1.0e3 ! density of cloud water (kg/m^3) - real(kind=kind_phys), parameter :: rhoci = 9.17e2 ! density of cloud ice (kg/m^3) - real(kind=kind_phys), parameter :: rhocr = 1.0e3 ! density of rain (Lin et al. 1983) (kg/m^3) - real(kind=kind_phys), parameter :: rhocg = 4.0e2 ! density of graupel (Rutledge and Hobbs 1984) (kg/m^3) - real(kind=kind_phys), parameter :: rhoch = 9.17e2 ! density of hail (Lin et al. 1983) (kg/m^3) - real(kind=kind_phys), parameter :: qcmin = 1.0e-15 ! min value for cloud condensates (kg/kg) - real(kind=kind_phys), parameter :: qfmin = 1.0e-8 ! min value for sedimentation (kg/kg) - real(kind=kind_phys), parameter :: con_one = 1_kind_phys - real(kind=kind_phys), parameter :: con_p001 = 0.001_kind_phys - real(kind=kind_phys), parameter :: con_secinday = 86400._kind_phys - -!........................................! - end module physcons ! -!========================================! diff --git a/physics/tools/funcphys.f90 b/physics/tools/funcphys.f90 index 3e81a0d5a..aa75984b6 100644 --- a/physics/tools/funcphys.f90 +++ b/physics/tools/funcphys.f90 @@ -1,15 +1,15 @@ -!>\file funcphys.f90 +!>\file funcphys.f90 !! This file includes API for basic thermodynamic physics. !>\defgroup func_phys GFS Physics Function Module !! This module provides API for computing basic thermodynamic physics -!! functions. +!! functions. !> This module provides an Application Program Interface (API) for computing !! basic thermodynamic physics functions, in particular: !! -# saturation vapor pressure as a function of temperature; !! -# dewpoint temperature as a function of vapor pressure; -!! -# equivalent potential temperature as a function of temperature and +!! -# equivalent potential temperature as a function of temperature and !! scaled pressure to the kappa power; !! -# temperature and specific humidity along a moist adiabat as functions !! of equivalent potential temperature and scaled pressure to the kappa power; @@ -18,7 +18,7 @@ !! and dewpoint depression. !! !! The entry points required to set up lookup tables start with a "g". -!! All the other entry points are functions starting with an "f" or +!! All the other entry points are functions starting with an "f" or !! are subroutines starting with an "s". These other functions and subroutines !! are elemental; that is, they return a scalar if they are passed only scalars, !! but they return an array if they are passed an array. These other functions @@ -261,16 +261,32 @@ module funcphys ! !$$$ use machine,only:kind_phys,r8=>kind_dbl_prec,r4=>kind_sngl_prec - use physcons implicit none private + logical :: initialized = .false. + real(kind=kind_phys):: con_cpor = 1.0E30_kind_phys + real(kind=kind_phys):: con_dldt = 1.0E30_kind_phys + real(kind=kind_phys):: con_xpona = 1.0E30_kind_phys + real(kind=kind_phys):: con_xponb = 1.0E30_kind_phys + real(kind=kind_phys):: con_cp = 1.0E30_kind_phys + real(kind=kind_phys):: con_cvap = 1.0E30_kind_phys + real(kind=kind_phys):: con_cliq = 1.0E30_kind_phys + real(kind=kind_phys):: con_rv = 1.0E30_kind_phys + real(kind=kind_phys):: con_hvap = 1.0E30_kind_phys + real(kind=kind_phys):: con_ttp = 1.0E30_kind_phys + real(kind=kind_phys):: con_csol = 1.0E30_kind_phys + real(kind=kind_phys):: con_hfus = 1.0E30_kind_phys + real(kind=kind_phys):: con_rocp = 1.0E30_kind_phys + real(kind=kind_phys):: con_eps = 1.0E30_kind_phys + real(kind=kind_phys):: con_psat = 1.0E30_kind_phys + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Public Variables ! integer,public,parameter:: krealfp=selected_real_kind(15,45) integer,public,parameter:: krealfp=kind_phys !< Integer parameter kind or length of reals ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Private Variables - real(krealfp),parameter:: psatb=con_psat*1.e-5 + real(krealfp):: psatb=1.0E30_kind_phys integer,parameter:: nxpvsl=7501 real(krealfp) c1xpvsl,c2xpvsl,tbpvsl(nxpvsl) integer,parameter:: nxpvsi=7501 @@ -307,15 +323,51 @@ module funcphys public gpkap,fpkap,fpkapq,fpkapo,fpkapx public grkap,frkap,frkapq,frkapx public gtlcl,ftlcl,ftlclq,ftlclo,ftlclx - public gfuncphys + public gfuncphys,funcphys_init interface fpvsl - module procedure fpvsl_r4, fpvsl_r8 + module procedure fpvsl_r4, fpvsl_r8 end interface fpvsl interface fpvsi - module procedure fpvsi_r4, fpvsi_r8 + module procedure fpvsi_r4, fpvsi_r8 end interface fpvsi contains + subroutine is_initialized() + if (initialized .eqv. .false.) then + print *, "WARNING: funcphys_init needs to be called for constants to be initalized" + end if + end subroutine is_initialized + + subroutine funcphys_init(con_cp_in, con_rd_in, con_cvap_in, con_cliq_in, & + con_rv_in, con_hvap_in, con_ttp_in, con_psat_in, con_csol_in, & + con_hfus_in, con_rocp_in, con_eps_in) + real(kind=kind_phys), intent(in) :: con_cp_in, con_rd_in, con_cvap_in + real(kind=kind_phys), intent(in) :: con_cliq_in, con_rv_in, con_hvap_in + real(kind=kind_phys), intent(in) :: con_ttp_in, con_psat_in, con_csol_in + real(kind=kind_phys), intent(in) :: con_hfus_in, con_rocp_in, con_eps_in + ! set constants used by other functions in this module + con_cp = con_cp_in + con_cvap = con_cvap_in + con_cliq = con_cliq_in + con_rv = con_rv_in + con_hvap = con_hvap_in + con_ttp = con_ttp_in + con_psat = con_psat_in + con_csol = con_csol_in + con_hfus = con_hfus_in + con_rocp = con_rocp_in + con_eps = con_eps_in + + ! Set module level variables + con_cpor = con_cp/con_rd_in + con_dldt = con_cvap-con_cliq + con_xpona = -con_dldt/con_rv + con_xponb = -con_dldt/con_rv+con_hvap/(con_rv*con_ttp) + psatb=con_psat*1.e-5 + initialized = .true. + end subroutine funcphys_init + + !------------------------------------------------------------------------------- !> This subroutine computes saturation vapor pressure table as a function of !! temperature for the table lookup function fpval. Exact saturation vapor @@ -369,7 +421,7 @@ subroutine gpvsl !> This funtion computes saturation vapor pressure from the temperature. !! A linear interpolation is done between values in a lookup table computed !! in gpvsl(). See documentation for fpvslx() for details. Input values -!! outside table range are reset to table extrema. +!! outside table range are reset to table extrema. !>\author N phillips elemental function fpvsl_r4(t) @@ -461,8 +513,8 @@ end function fpvsl_r8 !------------------------------------------------------------------------------- -!> This function computes saturation vapor pressure from the temperature. -!! A quadratic interpolation is done between values in a lookup table +!> This function computes saturation vapor pressure from the temperature. +!! A quadratic interpolation is done between values in a lookup table !! computed in gpvsl(). See documentaion for fpvslx() for details. !! Input values outside table range are reset to table extrema. elemental function fpvslq(t) @@ -516,7 +568,7 @@ elemental function fpvslq(t) !> This function exactly computes saturation vapor pressure from temperature. !! The water model assumes a perfect gas, constant specific heats !! for gas and liquid, and neglects the volume of the liquid. -!! The model does account for the variation of the latent heat +!! The model does account for the variation of the latent heat !! of condensation with temperature. The ice option is not included. !! The Clausius-Clapeyron equation is integrated from the triple point !! to get the formula: @@ -563,21 +615,26 @@ elemental function fpvslx(t) implicit none real(krealfp) fpvslx real(krealfp),intent(in):: t - real(krealfp),parameter:: dldt=con_cvap-con_cliq - real(krealfp),parameter:: heat=con_hvap - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) tr -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + real(krealfp) :: dldt + real(krealfp) :: heat + real(krealfp) :: xpona + real(krealfp) :: xponb + real(krealfp) :: tr +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + dldt=con_cvap-con_cliq + heat=con_hvap + xpona=-dldt/con_rv + xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + tr=con_ttp/t fpvslx=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function !------------------------------------------------------------------------------- -!> This subroutine computes saturation vapor pressure table as a function of +!> This subroutine computes saturation vapor pressure table as a function of !! temperature for the table lookup function fpvsi(). Exact saturation vapor !! pressures are calculated in subprogram fpvsix(). The current implementation -!! computes a table with a length of 7501 for temperatures ranging from 180. +!! computes a table with a length of 7501 for temperatures ranging from 180. !! to 330. Kelvin. !>\author N Phillips subroutine gpvsi @@ -626,7 +683,7 @@ subroutine gpvsi end subroutine !------------------------------------------------------------------------------- !> This function computes saturation vapor pressure from the temperature. -!! A linear interpolation is done between values in a lookup table +!! A linear interpolation is done between values in a lookup table !! computed in gpvsi(). See documentation for fpvsix() for details. !! Input values outside table range are reset to table extrema. !>\author N Phillips @@ -777,10 +834,10 @@ elemental function fpvsiq(t) !! The water model assumes a perfect gas, constant specific heats !! for gas and ice, and neglects the volume of the ice. The model does !! account for the variation of the latent heat of condensation with temperature. -!! The liquid option is not included. The Clausius- Clapeyron equation is +!! The liquid option is not included. The Clausius- Clapeyron equation is !! integrated from the triple point to get the formula: !!\n pvsi=con_psat*(tr**xa)*exp(xb*(1.-tr)) -!!\n where tr is ttp/t and other values are physical constants. +!!\n where tr is ttp/t and other values are physical constants. !! This function should be expanded inline in the calling routine. !>\param[in] t real, temperature in Kelvin !\param[out] fpvsix real, saturation vapor pressure in Pascals @@ -822,11 +879,16 @@ elemental function fpvsix(t) implicit none real(krealfp) fpvsix real(krealfp),intent(in):: t - real(krealfp),parameter:: dldt=con_cvap-con_csol - real(krealfp),parameter:: heat=con_hvap+con_hfus - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp):: dldt + real(krealfp):: heat + real(krealfp):: xpona + real(krealfp):: xponb real(krealfp) tr + + dldt=con_cvap-con_csol + heat=con_hvap+con_hfus + xpona=-dldt/con_rv + xponb=-dldt/con_rv+heat/(con_rv*con_ttp) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t fpvsix=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) @@ -837,7 +899,7 @@ elemental function fpvsix(t) !! temperature for the table lookup function fpvs(). !! Exact saturation vapor pressures are calculated in subprogram fpvsx(). !! The current implementation computes a table with a length -!! of 7501 for temperatures ranging from 180. to 330. Kelvin. +!! of 7501 for temperatures ranging from 180. to 330. Kelvin. subroutine gpvs !$$$ Subprogram Documentation Block ! @@ -1047,17 +1109,27 @@ elemental function fpvsx(t) implicit none real(krealfp) fpvsx real(krealfp),intent(in):: t - real(krealfp),parameter:: tliq=con_ttp - real(krealfp),parameter:: tice=con_ttp-20.0 - real(krealfp),parameter:: dldtl=con_cvap-con_cliq - real(krealfp),parameter:: heatl=con_hvap - real(krealfp),parameter:: xponal=-dldtl/con_rv - real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) - real(krealfp),parameter:: dldti=con_cvap-con_csol - real(krealfp),parameter:: heati=con_hvap+con_hfus - real(krealfp),parameter:: xponai=-dldti/con_rv - real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) + real(krealfp):: tliq + real(krealfp):: tice + real(krealfp):: dldtl + real(krealfp):: heatl + real(krealfp):: xponal + real(krealfp):: xponbl + real(krealfp):: dldti + real(krealfp):: heati + real(krealfp):: xponai + real(krealfp):: xponbi real(krealfp) tr,w,pvl,pvi + tliq=con_ttp + tice=con_ttp-20.0 + dldtl=con_cvap-con_cliq + heatl=con_hvap + xponal=-dldtl/con_rv + xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) + dldti=con_cvap-con_csol + heati=con_hvap+con_hfus + xponai=-dldti/con_rv + xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t if(t.ge.tliq) then @@ -1335,12 +1407,16 @@ elemental function ftdplxg(tg,pv) real(krealfp) ftdplxg real(krealfp),intent(in):: tg,pv real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: dldt=con_cvap-con_cliq - real(krealfp),parameter:: heat=con_hvap - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp):: dldt + real(krealfp):: heat + real(krealfp):: xpona + real(krealfp):: xponb real(krealfp) t,tr,pvt,el,dpvt,terr integer i + dldt=con_cvap-con_cliq + heat=con_hvap + xpona=-dldt/con_rv + xponb=-dldt/con_rv+heat/(con_rv*con_ttp) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg do i=1,100 @@ -1625,12 +1701,17 @@ elemental function ftdpixg(tg,pv) real(krealfp) ftdpixg real(krealfp),intent(in):: tg,pv real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: dldt=con_cvap-con_csol - real(krealfp),parameter:: heat=con_hvap+con_hfus - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp):: dldt + real(krealfp):: heat + real(krealfp):: xpona + real(krealfp):: xponb real(krealfp) t,tr,pvt,el,dpvt,terr integer i + + dldt=con_cvap-con_csol + heat=con_hvap+con_hfus + xpona=-dldt/con_rv + xponb=-dldt/con_rv+heat/(con_rv*con_ttp) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg do i=1,100 @@ -1924,19 +2005,30 @@ elemental function ftdpxg(tg,pv) implicit none real(krealfp) ftdpxg real(krealfp),intent(in):: tg,pv - real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: tliq=con_ttp - real(krealfp),parameter:: tice=con_ttp-20.0 - real(krealfp),parameter:: dldtl=con_cvap-con_cliq - real(krealfp),parameter:: heatl=con_hvap - real(krealfp),parameter:: xponal=-dldtl/con_rv - real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) - real(krealfp),parameter:: dldti=con_cvap-con_csol - real(krealfp),parameter:: heati=con_hvap+con_hfus - real(krealfp),parameter:: xponai=-dldti/con_rv - real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) + real(krealfp), parameter:: terrm=1.e-6 + real(krealfp):: tliq + real(krealfp):: tice + real(krealfp):: dldtl + real(krealfp):: heatl + real(krealfp):: xponal + real(krealfp):: xponbl + real(krealfp):: dldti + real(krealfp):: heati + real(krealfp):: xponai + real(krealfp):: xponbi real(krealfp) t,tr,w,pvtl,pvti,pvt,ell,eli,el,dpvt,terr integer i + + tliq=con_ttp + tice=con_ttp-20.0 + dldtl=con_cvap-con_cliq + heatl=con_hvap + xponal=-dldtl/con_rv + xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) + dldti=con_cvap-con_csol + heati=con_hvap+con_hfus + xponai=-dldti/con_rv + xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg do i=1,100 @@ -2007,6 +2099,7 @@ subroutine gthe integer jx,jy real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,t ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call is_initialized() xmin=con_ttp-90._krealfp xmax=con_ttp+30._krealfp ymin=0.04_krealfp**con_rocp @@ -2229,6 +2322,7 @@ function fthex(t,pk) real(krealfp),intent(in):: t,pk real(krealfp) p,tr,pv,pd,el,expo,expmax ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call is_initialized() p=pk**con_cpor tr=con_ttp/t pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) @@ -2284,6 +2378,7 @@ subroutine gtma integer jx,jy real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,the,t,q,tg ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call is_initialized() xmin=200._krealfp xmax=500._krealfp ymin=0.01_krealfp**con_rocp @@ -2541,7 +2636,7 @@ subroutine stmax(the,pk,tma,qma) !>\param[in] tg real, guess parcel temperature in Kelvin !>\param[in] the real, equivalent potential temperature in Kelvin !>\param[in] pk real, pressure over 1e5 Pa to the kappa power -!>\param[out] tma real, parcel temperature in Kelvin +!>\param[out] tma real, parcel temperature in Kelvin !>\param[out] qma real, parcel specific humidity in kg/kg subroutine stmaxg(tg,the,pk,tma,qma) !$$$ Subprogram Documentation Block @@ -2594,6 +2689,7 @@ subroutine stmaxg(tg,the,pk,tma,qma) real(krealfp) t,p,tr,pv,pd,el,expo,thet,dthet,terr integer i ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call is_initialized() t=tg p=pk**con_cpor do i=1,100 @@ -2776,7 +2872,7 @@ elemental function fpkapq(p) !! using a rational weighted chebyshev approximation. !! The numerator is of order 2 and the denominator is of order 4. !! The pressure range is 40000-110000 Pa and kappa is defined in fpkapx(). -!>\param[in] p real, surface pressure in Pascals p should be in the +!>\param[in] p real, surface pressure in Pascals p should be in the !! range 40000 to 110000 !\param[out] fpkapo real, p over 1e5 Pa to the kappa power function fpkapo(p) diff --git a/physics/tools/get_phi_fv3.F90 b/physics/tools/get_phi_fv3.F90 index d111d3ae0..60fbc2470 100644 --- a/physics/tools/get_phi_fv3.F90 +++ b/physics/tools/get_phi_fv3.F90 @@ -4,7 +4,6 @@ module get_phi_fv3 use machine, only: kind_phys - use physcons, only: con_fvirt !--- public declarations public get_phi_fv3_run @@ -56,4 +55,4 @@ subroutine get_phi_fv3_run(ix, levs, con_fvirt, gt0, gq01, del_gz, phii, phil, e end subroutine get_phi_fv3_run -end module get_phi_fv3 \ No newline at end of file +end module get_phi_fv3 diff --git a/physics/tools/get_phi_fv3.meta b/physics/tools/get_phi_fv3.meta index 5c162c746..2d30a7bb6 100644 --- a/physics/tools/get_phi_fv3.meta +++ b/physics/tools/get_phi_fv3.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = get_phi_fv3 type = scheme - dependencies = ../hooks/machine.F,../hooks/physcons.F90 + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table]