MODULE Pbl_UniversityWashington IMPLICIT NONE PRIVATE ! vertical_diffusion_tend_ ! | ! |____compute_tms ! | ! |____compute_eddy_diff_ ! | | ! | |__trbintd_ ! | | | ! | | |__sfdiag ! | | ! | |__austausch_atm ! | | ! | |__caleddy_ ! | | | ! | | |__exacol ! | | | ! | | |__zisocl ! | | ! | |__compute_vdiff_ ! | | ! | |__compute_molec_diff_ ! | | | ! | | |__ubc_get_vals ! | | ! | |__vd_lu_decomp ! | | ! | |__vd_lu_solve ! | | ! | |__vd_lu_solve ! | | ! | |__vd_lu_decomp ! | | ! | |__vd_lu_solve ! | | ! | |__vd_lu_decomp ! | | ! | |__vd_lu_qdecomp ! | ! |____aqsat ! | ! |__compute_vdiff_ ! | | ! | |__compute_molec_diff_ ! | | | ! | | |__ubc_get_vals ! | | ! | |__vd_lu_decomp ! | | ! | |__vd_lu_solve ! | | ! | |__vd_lu_solve ! | | ! | |__vd_lu_decomp ! | | ! | |__vd_lu_solve ! | | ! | |__vd_lu_decomp ! | | ! | |__vd_lu_qdecomp ! | ! |__compute_vdiff_ ! | | ! | |__compute_molec_diff_ ! | | | ! | | |__ubc_get_vals ! | | ! | |__vd_lu_decomp ! | | ! | |__vd_lu_solve ! | | ! | |__vd_lu_solve ! | | ! | |__vd_lu_decomp ! | | ! | |__vd_lu_solve ! | | ! | |__vd_lu_decomp ! | | ! | |__vd_lu_qdecomp ! | ! |____positive_moisture ! | ! |____aqsat ! ! ! ! ! !---------------------------------------------------------------------------- ! precision/kind constants add data public !---------------------------------------------------------------------------- INTEGER,PARAMETER :: R8 = SELECTED_REAL_KIND(12) ! 8 byte real INTEGER,PARAMETER :: R4 = SELECTED_REAL_KIND( 6) ! 4 byte real INTEGER,PARAMETER :: RN = KIND(1.0) ! native real INTEGER,PARAMETER :: I8 = SELECTED_INT_KIND (13) ! 8 byte integer INTEGER,PARAMETER :: I4 = SELECTED_INT_KIND ( 6) ! 4 byte integer INTEGER,PARAMETER :: IN = KIND(1) ! native integer INTEGER,PARAMETER :: CS = 80 ! short char INTEGER,PARAMETER :: CL = 256 ! long char INTEGER,PARAMETER :: CX = 512 ! extra-long char CHARACTER(len=8), PARAMETER :: eddy_scheme='diag_TKE' INTEGER , PARAMETER :: iulog=0 LOGICAL :: do_iss=.TRUE. ! switch for implicit turbulent surface stress LOGICAL :: do_molec_diff = .FALSE. ! Switch for molecular diffusion LOGICAL :: do_tms= .FALSE. ! Switch for turbulent mountain stress REAL(r8) :: tms_orocnst =1 ! Converts from standard deviation to height LOGICAL :: do_pseudocon_diff = .FALSE. ! If .true., do pseudo-conservative variables diffusion LOGICAL :: MODAL_AERO= .FALSE. LOGICAL :: wstarent=.TRUE. ! .true. means use the 'wstar' entrainment closure. INTEGER :: nturb =3 ! Number of iteration steps for calculating eddy diffusivity [ # ] LOGICAL :: is_first_step = .TRUE. LOGICAL, PARAMETER :: use_kvf = .false. ! .true. (.false.) : initialize kvh/kvm = kvf ( 0. ) LOGICAL, PARAMETER :: use_dw_surf = .false. ! Used in 'zisocl'. Default is 'true' ! If 'true', surface interfacial energy does not contribute to the CL mean ! stbility functions after finishing merging. For this case, ! 'dl2n2_surf' is only used for a merging test based on 'l2n2' ! If 'false',surface interfacial enery explicitly contribute to CL mean ! stability functions after finishing merging. For this case, ! 'dl2n2_surf' and 'dl2s2_surf' are directly used for calculating ! surface interfacial layer energetics ! --------------------------------- ! ! PBL Parameters used in the UW PBL ! ! --------------------------------- ! CHARACTER, PARAMETER :: sftype = 'l' ! Method for calculating saturation fraction CHARACTER(len=4), PARAMETER :: choice_evhc = 'maxi' ! 'orig', 'ramp', 'maxi' : recommended to be used with choice_radf CHARACTER(len=6), PARAMETER :: choice_radf = 'maxi' ! 'orig', 'ramp', 'maxi' : recommended to be used with choice_evhc CHARACTER(len=6), PARAMETER :: choice_SRCL = 'nonamb' ! 'origin', 'remove', 'nonamb' CHARACTER(len=6), PARAMETER :: choice_tunl = 'rampcl' ! 'origin', 'rampsl'(Sungsu), 'rampcl'(Chris) REAL(r8), PARAMETER :: ctunl = 2._r8 ! Maximum asympt leng = ctunl*tunl when choice_tunl = 'rampsl(cl)' [ no unit ] CHARACTER(len=6), PARAMETER :: choice_leng = 'origin' ! 'origin', 'takemn' REAL(r8), PARAMETER :: cleng = 3._r8 ! Order of 'leng' when choice_leng = 'origin' [ no unit ] CHARACTER(len=6), PARAMETER :: choice_tkes = 'ibprod' ! 'ibprod' (include tkes in computing bprod), 'ebprod'(exclude) ! Parameters for 'sedimenttaion-entrainment feedback' for liquid stratus ! If .false., no sedimentation entrainment feedback ( i.e., use default evhc ) LOGICAL, PARAMETER :: id_sedfact = .FALSE. REAL(r8), PARAMETER :: ased = 9._r8 ! Valid only when id_sedfact = .true. ! --------------------------------------------------------------------------------------------------- ! ! Parameters governing entrainment efficiency A = a1l(i)*evhc, evhc = 1 + a2l * a3l * L * ql / jt2slv ! ! Here, 'ql' is cloud-top LWC and 'jt2slv' is the jump in 'slv' across ! ! the cloud-top entrainment zone ( across two grid layers to consider full mixture ) ! ! --------------------------------------------------------------------------------------------------- ! REAL(r8), PARAMETER :: a1l = 0.10_r8 ! Dry entrainment efficiency for TKE closure ! a1l = 0.2*tunl*erat^-1.5, where erat = /wstar^2 for dry CBL = 0.3. REAL(r8), PARAMETER :: a1i = 0.2_r8 ! Dry entrainment efficiency for wstar closure REAL(r8), PARAMETER :: ccrit = 0.5_r8 ! Minimum allowable sqrt(tke)/wstar. Used in solving cubic equation for 'ebrk' REAL(r8), PARAMETER :: wstar3factcrit = 0.5_r8 ! 1/wstar3factcrit is the maximally allowed enhancement of 'wstar3' due to entrainment. REAL(r8), PARAMETER :: a2l = 30._r8 ! Moist entrainment enhancement param (recommended range : 10~30 ) REAL(r8), PARAMETER :: a3l = 0.8_r8 ! Approximation to a complicated thermodynamic parameters REAL(r8), PARAMETER :: jbumin = .001_r8 ! Minimum buoyancy jump at an entrainment jump, [m/s2] REAL(r8), PARAMETER :: evhcmax = 10._r8 ! Upper limit of evaporative enhancement factor REAL(r8), PARAMETER :: ustar_min = 0.01_r8 ! Minimum permitted value of ustar [ m/s ] REAL(r8), PARAMETER :: onet = 1._r8/3._r8 ! 1/3 power in wind gradient expression [ no unit ] REAL(r8), PARAMETER :: qmin(3) = 1.0e-12_r8 ! Minimum grid-mean LWC counted as clouds [kg/kg] REAL(r8), PARAMETER :: ntzero = 1.e-12_r8 ! Not zero (small positive number used in 's2') REAL(r8), PARAMETER :: b1 = 5.8_r8 ! TKE dissipation D = e^3/(b1*leng), e = b1*W. REAL(r8) :: b123 ! b1**(2/3) REAL(r8), PARAMETER :: tunl = 0.085_r8 ! Asympt leng = tunl*(turb lay depth) REAL(r8), PARAMETER :: alph1 = 0.5562_r8 ! alph1~alph5 : Galperin instability function parameters REAL(r8), PARAMETER :: alph2 = -4.3640_r8 ! These coefficients are used to calculate REAL(r8), PARAMETER :: alph3 = -34.6764_r8 ! 'sh' and 'sm' from 'gh'. REAL(r8), PARAMETER :: alph4 = -6.1272_r8 ! REAL(r8), PARAMETER :: alph5 = 0.6986_r8 ! REAL(r8), PARAMETER :: ricrit = 0.19_r8 ! Critical Richardson number for turbulence. Can be any value >= 0.19. REAL(r8), PARAMETER :: ae = 1._r8 ! TKE transport efficiency [no unit] REAL(r8), PARAMETER :: rinc = -0.04_r8 ! Minimum W/ used for CL merging test REAL(r8), PARAMETER :: wpertmin = 1.e-6_r8 ! Minimum PBL eddy vertical velocity perturbation REAL(r8), PARAMETER :: wfac = 1._r8 ! Ratio of 'wpert' to sqrt(tke) for CL. REAL(r8), PARAMETER :: tfac = 1._r8 ! Ratio of 'tpert' to (w't')/wpert for CL. Same ratio also used for q REAL(r8), PARAMETER :: fak = 8.5_r8 ! Constant in surface temperature excess for stable STL. [ no unit ] REAL(r8), PARAMETER :: rcapmin = 0.1_r8 ! Minimum allowable e/ in a CL REAL(r8), PARAMETER :: rcapmax = 2.0_r8 ! Maximum allowable e/ in a CL REAL(r8), PARAMETER :: tkemax = 20._r8 ! TKE is capped at tkemax [m2/s2] REAL(r8), PARAMETER :: lambda = 0.5_r8 ! Under-relaxation factor ( 0 < lambda =< 1 ) LOGICAL, PARAMETER :: set_qrlzero = .FALSE. ! .true. ( .false.) : turning-off ( on) radiative-turbulence interaction by setting qrl = 0. ! ------------------------------------- ! ! PBL Parameters not used in the UW PBL ! ! ------------------------------------- ! REAL(r8), PARAMETER :: pblmaxp = 4.e4_r8 ! PBL max depth in pressure units. REAL(r8), PARAMETER :: zkmin = 0.01_r8 ! Minimum kneutral*f(ri). REAL(r8), PARAMETER :: betam = 15.0_r8 ! Constant in wind gradient expression. REAL(r8), PARAMETER :: betas = 5.0_r8 ! Constant in surface layer gradient expression. REAL(r8), PARAMETER :: betah = 15.0_r8 ! Constant in temperature gradient expression. REAL(r8), PARAMETER :: fakn = 7.2_r8 ! Constant in turbulent prandtl number. REAL(r8), PARAMETER :: ricr = 0.3_r8 ! Critical richardson number. REAL(r8), PARAMETER :: sffrac = 0.1_r8 ! Surface layer fraction of boundary layer REAL(r8), PARAMETER :: binm = betam*sffrac ! betam * sffrac REAL(r8), PARAMETER :: binh = betah*sffrac ! betah * sffrac ! ------------------------------------------------------- ! ! PBL constants set using values from other parts of code ! ! ------------------------------------------------------- ! REAL(R8),PARAMETER :: SHR_CONST_G = 9.80616_R8 ! acceleration of gravity ~ m/s^2 REAL(r8),PARAMETER :: gravit = shr_const_g ! gravitational acceleration (m/s**2) REAL(R8),PARAMETER :: SHR_CONST_KARMAN = 0.4_R8 ! Von Karman constant REAL(r8),PARAMETER :: karman = shr_const_karman ! Von Karman constant REAL(R8),PARAMETER :: SHR_CONST_CPDAIR = 1.00464e3_R8 ! specific heat of dry air ~ J/kg/K REAL(r8),PARAMETER :: cpair = shr_const_cpdair ! specific heat of dry air (J/K/kg) REAL(R8),PARAMETER :: SHR_CONST_MWDAIR = 28.966_R8 ! molecular weight dry air ~ kg/kmole REAL(R8),PARAMETER :: SHR_CONST_MWWV = 18.016_R8 ! molecular weight water vapor REAL(R8),PARAMETER :: SHR_CONST_BOLTZ = 1.38065e-23_R8 ! Boltzmann's constant ~ J/K/molecule REAL(R8),PARAMETER :: SHR_CONST_AVOGAD = 6.02214e26_R8 ! Avogadro's number ~ molecules/kmole REAL(R8),PARAMETER :: SHR_CONST_RGAS = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ ! Universal gas constant ~ J/K/kmole REAL(R8),PARAMETER :: SHR_CONST_RDAIR = SHR_CONST_RGAS/SHR_CONST_MWDAIR ! Dry air gas constant ~ J/K/kg REAL(r8),PARAMETER :: rair = shr_const_rdair ! Dry air gas constant ~ J/K/kg real(r8),parameter :: avogad = shr_const_avogad ! Avogadro's number (molecules/kmole) REAL(r8),PARAMETER :: boltz = shr_const_boltz ! Boltzman's constant (J/K/molecule) REAL(R8),PARAMETER :: SHR_CONST_RWV = SHR_CONST_RGAS/SHR_CONST_MWWV ! Water vapor gas constant ~ J/K/kg REAL(r8),PARAMETER :: zvir = (shr_const_rwv/shr_const_rdair)-1.0_R8 ! (rh2o/rair) - 1 REAL(R8),PARAMETER :: SHR_CONST_LATVAP = 2.501e6_R8 ! latent heat of evaporation ~ J/kg REAL(r8),PARAMETER :: latvap = shr_const_latvap ! Latent heat of vaporization (J/kg) REAL(R8),PARAMETER :: SHR_CONST_LATICE = 3.337e5_R8 ! latent heat of fusion ~ J/kg REAL(r8),PARAMETER :: latice = shr_const_latice ! Latent heat of fusion (J/kg) REAL(R8),PARAMETER :: SHR_CONST_LATSUB = SHR_CONST_LATICE + SHR_CONST_LATVAP ! latent heat of sublimation ~ J/kg REAL(r8),PARAMETER :: latsub =SHR_CONST_LATSUB ! Latent heat of sublimation REAL(r8),PARAMETER :: g =SHR_CONST_G ! Gravitational acceleration REAL(r8),PARAMETER :: vk =SHR_CONST_KARMAN ! Von Karman's constant REAL(r8),PARAMETER :: ccon =fak*sffrac*SHR_CONST_KARMAN ! fak * sffrac * vk REAL(r8),PARAMETER :: tmin = 173.16_r8 ! min temperature (K) for table REAL(r8),PARAMETER :: tmax = 375.16_r8 ! max temperature (K) for table! Maximum temperature entry in table REAL(r8),PARAMETER :: trice = 20.00_r8 ! Transition range from es over range to es over ice REAL(r8),PARAMETER :: ttrice=trice REAL(R8),PARAMETER :: SHR_CONST_TKFRZ = 273.15_R8 ! freezing T of fresh water ~ K REAL(r8), PARAMETER :: tmelt = shr_const_tkfrz ! Freezing point of water (K) real(r8), PARAMETER :: mwdry = shr_const_mwdair! molecular weight dry air INTEGER :: ntop_turb ! Top interface level to which turbulent vertical diffusion is applied ( = 1 ) INTEGER :: nbot_turb ! Bottom interface level to which turbulent vertical diff is applied ( = pver ) INTEGER :: ntop_eddy ! Top interface level to which eddy vertical diffusion is applied ( = 1 ) INTEGER :: nbot_eddy ! Bottom interface level to which eddy vertical diffusion is applied ( = pver ) real(r8), parameter :: d0 = 1.52E20_r8 ! Diffusion factor [ m-1 s-1 ] molec sqrt(kg/kmol/K) [ unit ? ] REAL(r8) , ALLOCATABLE :: ml2(:) ! Mixing lengths squared. Not used in the UW PBL. Used for computing free air diffusivity. REAL(KIND=r8), ALLOCATABLE :: hypm(:) ! reference pressures at midpoints CHARACTER*3 , ALLOCATABLE :: cnst_type(:) ! wet or dry mixing ratio ! Parameters used for Turbulent Mountain Stress ! real(r8), parameter :: z0fac = 0.025_r8 ! Factor determining z_0 from orographic standard deviation REAL(r8), PARAMETER :: z0fac = 0.075_r8 ! Factor determining z_0 from orographic standard deviation [ no unit ] ! real(r8), parameter :: z0max = 100._r8 ! Max value of z_0 for orography REAL(r8), PARAMETER :: z0max = 100._r8 ! Maximum value of z_0 for orography [ m ] ! real(r8), parameter :: horomin = 10._r8 ! Min value of subgrid orographic height for mountain stress REAL(r8), PARAMETER :: horomin= 1._r8 ! Minimum value of subgrid orographic height for mountain stress [ m ] REAL(r8), PARAMETER :: dv2min = 0.01_r8 ! Minimum shear squared [ m2/s2 ] ! real(r8), parameter :: dv2min = 0.01_r8 ! Minimum shear squared REAL(r8) :: oroconst ! Converts from standard deviation to height [ no unit ] ! =============================================================================== ! ! ! ! =============================================================================== ! INTEGER :: ncvmax = -1 ! Max numbers of CLs (good to set to 'pver') INTEGER :: pver = -1 INTEGER :: nbot_molec ! Bottom level where molecular diffusivity is applied INTEGER :: ntop_molec ! Top interface level to which molecular vertical diffusion is applied ( = 1 ) INTEGER, PUBLIC :: pcnst = -1 ! number of advected constituents (including water vapor) INTEGER :: ntop ! Top interface level to which vertical diffusion is applied ( = 1 ). INTEGER :: nbot ! Bottom interface level to which vertical diffusion is applied ( = pver ). ! Below stores logical array of fields to be diffused TYPE vdiff_selector PRIVATE LOGICAL, POINTER, DIMENSION(:) :: fields END TYPE vdiff_selector ! Below extends .not. to operate on type vdiff_selector INTERFACE OPERATOR(.NOT.) MODULE PROCEDURE not END INTERFACE ! Below provides functionality of intrinsic any for type vdiff_selector INTERFACE any MODULE PROCEDURE my_any END INTERFACE TYPE(vdiff_selector) :: fieldlist_wet ! Logical switches for moist mixing ratio diffusion TYPE(vdiff_selector) :: fieldlist_dry ! Logical switches for dry mixing ratio diffusion INTEGER :: ixcldice, ixcldliq ! Constituent indices for cloud liquid and ice water INTEGER :: ixnumice, ixnumliq CHARACTER(len=528), ALLOCATABLE :: vdiffnam(:) ! Names of vertical diffusion tendencies CHARACTER(len=16) , ALLOCATABLE :: cnst_name(:) ! constituent names ! Constants for each tracer REAL(r8), ALLOCATABLE :: qmincg (:) ! for backward compatibility only REAL(r8), ALLOCATABLE :: cnst_mw (:) ! molecular weight (kg/kmole) LOGICAL, ALLOCATABLE :: cnst_fixed_ubc(:) != .false. ! upper bndy condition = fixed ? REAL(r8) , ALLOCATABLE :: mw_fac(:) ! sqrt(1/M_q + 1/M_d) in constituent diffusivity [ unit ? ] ! ! Data ! INTEGER, PARAMETER:: plenest=250 ! length of saturation vapor pressure table ! ! Table of saturation vapor pressure values es from tmin degrees ! to tmax+1 degrees k in one degree increments. ttrice defines the ! transition region where es is a combination of ice & water values ! REAL(r8) estbl(plenest) ! table values of saturation vapor pressure LOGICAL,PARAMETER :: icephs = .TRUE. ! false => saturation vapor press over water only ! Ice phase (true or false) REAL(r8) pcf(6) ! polynomial coeffs -> es transition water to ice REAL(r8),PARAMETER :: epsilo = shr_const_mwwv/shr_const_mwdair ! ratio of h2o to dry air molecular weights REAL(r8),PARAMETER :: epsqs=epsilo PUBLIC :: Init_Pbl_UniversityWashington PUBLIC :: Finalize_Pbl_UniversityWashington PUBLIC :: vertical_diffusion_tend CONTAINS ! ! Init_Pbl_UniversityWashington ! SUBROUTINE Init_Pbl_UniversityWashington(pver_in,pcnst_in,ncnst,sig) IMPLICIT NONE INTEGER , INTENT(IN ) :: pver_in INTEGER , INTENT(IN ) :: pcnst_in INTEGER , INTENT(in ) :: ncnst ! Number of constituents REAL(KIND=r8), INTENT(IN) :: sig(pver_in) REAL(KIND=r8) :: ps0 INTEGER :: k ! !---------------------------Local variables----------------------------- ! real(r8) :: t ! Temperature integer :: n ! Increment counter integer :: lentbl ! Calculated length of lookup table integer :: itype ! Ice phase: 0 -> no ice phase ! 1 -> ice phase, no transition ! -x -> ice phase, x degree transition logical :: ip ! Ice phase logical flag ! !----------------------------------------------------------------------- ! pcnst = pcnst_in pver = pver_in ncvmax = pver ! Max numbers of CLs (good to set to 'pver') ! hypm reference state midpoint pressures ALLOCATE(hypm (pver_in));hypm=0.0_r8 ALLOCATE(vdiffnam (pcnst) );vdiffnam='' ALLOCATE(cnst_name(pcnst) );cnst_name='' ALLOCATE(qmincg (pcnst) );qmincg=0.0_r8 ALLOCATE(cnst_mw (pcnst));cnst_mw=0.0_r8 ALLOCATE(cnst_type(pcnst) );cnst_type='wet' ALLOCATE(cnst_fixed_ubc(pcnst));cnst_fixed_ubc(1:pcnst) = .FALSE. ALLOCATE(mw_fac(pcnst));mw_fac=0.0_r8 ps0 = 1.0e5_r8 ! Base state surface pressure (pascals) DO k=pver_in,1,-1 hypm(k) = ps0*sig(pver_in + 1 - k) END DO qmincg=1.0e-12_r8 cnst_mw=18.0_r8 ! Molecular weight [ kg/kmole ] ! ---------------------------------- ! ! Initialize diffusion solver module ! ! ---------------------------------- ! CALL vertical_diffusion_init() lentbl = INT(tmax-tmin+2.000001_r8) if (lentbl .gt. plenest) then write(0,9000) tmax, tmin, plenest STOP 'call endrun (GESTBL) ! Abnormal termination' end if ! ! Begin building es table. ! Check whether ice phase requested. ! If so, set appropriate transition range for temperature ! if (icephs) then if (ttrice /= 0.0_r8) then itype = -ttrice else itype = 1 end if else itype = 0 end if ! t = tmin - 1.0_r8 do n=1,lentbl t = t + 1.0_r8 call gffgch(t,estbl(n),itype) end do ! do n=lentbl+1,plenest estbl(n) = -99999.0_r8 end do ! ! Table complete -- Set coefficients for polynomial approximation of ! difference between saturation vapor press over water and saturation ! pressure over ice for -ttrice < t < 0 (degrees C). NOTE: polynomial ! is valid in the range -40 < t < 0 (degrees C). ! ! --- Degree 5 approximation --- ! pcf(1) = 5.04469588506e-01_r8 pcf(2) = -5.47288442819e+00_r8 pcf(3) = -3.67471858735e-01_r8 pcf(4) = -8.95963532403e-03_r8 pcf(5) = -7.78053686625e-05_r8 ! ! --- Degree 6 approximation --- ! !-----pcf(1) = 7.63285250063e-02 !-----pcf(2) = -5.86048427932e+00 !-----pcf(3) = -4.38660831780e-01 !-----pcf(4) = -1.37898276415e-02 !-----pcf(5) = -2.14444472424e-04 !-----pcf(6) = -1.36639103771e-06 ! return ! 9000 format('GESTBL: FATAL ERROR *********************************',/, & ' TMAX AND TMIN REQUIRE A LARGER DIMENSION ON THE LENGTH', & ' OF THE SATURATION VAPOR PRESSURE TABLE ESTBL(PLENEST)',/, & ' TMAX, TMIN, AND PLENEST => ', 2f7.2, i3) ! END SUBROUTINE Init_Pbl_UniversityWashington !============================================================================ ! ! ! !============================================================================ ! SUBROUTINE vertical_diffusion_init() CHARACTER(128) :: errstring ! Error status for init_vdiff INTEGER :: k ! Vertical loop index INTEGER :: m INTEGER :: l ! ----------------------------------------------------------------- ! ! Get indices of cloud liquid and ice within the constituents array ! ! ----------------------------------------------------------------- ! ixcldliq=3 !call cnst_get_ind( 'CLDLIQ', ixcldliq ) ixcldice=2 !call cnst_get_ind( 'CLDICE', ixcldice ) ! if( microp_scheme .eq. 'MG' ) then ixnumliq=1 ! call cnst_get_ind( 'NUMLIQ', ixnumliq ) ixnumice=1 ! call cnst_get_ind( 'NUMICE', ixnumice ) ! endif ! if (masterproc) then ! write(iulog,*)'Initializing vertical diffusion (vertical_diffusion_init)' ! end if ! ---------------------------------------------------------------------------------------- ! ! Initialize molecular diffusivity module ! ! Molecular diffusion turned on above ~60 km (50 Pa) if model top is above ~90 km (.1 Pa). ! ! Note that computing molecular diffusivities is a trivial expense, but constituent ! ! diffusivities depend on their molecular weights. Decomposing the diffusion matric ! ! for each constituent is a needless expense unless the diffusivity is significant. ! ! ---------------------------------------------------------------------------------------- ! ntop_molec = 1 ! Should always be 1 nbot_molec = 0 ! Should be set below about 70 km IF( hypm(1) .LT. 0.1_r8 ) THEN do_molec_diff = .TRUE. DO k = 1, pver IF( hypm(k) .LT. 50._r8 ) nbot_molec = k END DO call init_molec_diff( r8, pcnst, rair, ntop_molec, nbot_molec, mwdry, & avogad, gravit, cpair, boltz ) !call addfld( 'TTPXMLC', 'K/S', 1, 'A', 'Top interf. temp. flux: molec. viscosity', phys_decomp ) !call add_default ( 'TTPXMLC', 1, ' ' ) !if( masterproc ) write(iulog,fmt='(a,i3,5x,a,i3)') 'NTOP_MOLEC =', ntop_molec, 'NBOT_MOLEC =', nbot_molec END IF ! ---------------------------------- ! ! Initialize eddy diffusivity module ! ! ---------------------------------- ! ntop_eddy = 1 ! No reason not to make this 1, if > 1, must be <= nbot_molec nbot_eddy = pver ! Should always be pver !if( masterproc ) write(iulog,fmt='(a,i3,5x,a,i3)') 'NTOP_EDDY =', ntop_eddy, 'NBOT_EDDY =', nbot_eddy SELECT CASE ( eddy_scheme ) CASE ( 'diag_TKE' ) !if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: UW Moist Turbulence Scheme by Bretherton and Park' ! Check compatibility of eddy and shallow scheme !if( shallow_scheme .ne. 'UW' ) then ! write(iulog,*) 'ERROR: shallow convection scheme ', shallow_scheme,' is incompatible with eddy scheme ', eddy_scheme ! call endrun( 'convect_shallow_init: shallow_scheme and eddy_scheme are incompatible' ) !endif CALL init_eddy_diff( r8, pver, gravit, cpair, rair, zvir, latvap, latice, & ntop_eddy, nbot_eddy, karman ) !if( masterproc ) write(iulog,*) 'vertical_diffusion: nturb, ntop_eddy, nbot_eddy ', nturb, ntop_eddy, nbot_eddy CASE ( 'HB', 'HBR' ) !if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: Holtslag and Boville' !call init_hb_diff( gravit, cpair, rair, zvir, ntop_eddy, nbot_eddy, karman, eddy_scheme ) END SELECT ! The vertical diffusion solver must operate ! over the full range of molecular and eddy diffusion ntop = MIN(ntop_molec,ntop_eddy) nbot = MAX(nbot_molec,nbot_eddy) ! ------------------------------------------- ! ! Initialize turbulent mountain stress module ! ! ------------------------------------------- ! IF( do_tms ) THEN CALL init_tms( r8, tms_orocnst, karman, gravit, rair ) !call addfld( 'TAUTMSX' ,'N/m2 ', 1, 'A', 'Zonal turbulent mountain surface stress', phys_decomp ) !call addfld( 'TAUTMSY' ,'N/m2 ', 1, 'A', 'Meridional turbulent mountain surface stress', phys_decomp ) !call add_default( 'TAUTMSX ', 1, ' ' ) !call add_default( 'TAUTMSY ', 1, ' ' ) !if (masterproc) then ! write(iulog,*)'Using turbulent mountain stress module' ! write(iulog,*)' tms_orocnst = ',tms_orocnst !end if ENDIF ! ---------------------------------- ! ! Initialize diffusion solver module ! ! ---------------------------------- ! CALL init_vdiff( r8, pcnst, rair, gravit, fieldlist_wet, fieldlist_dry, errstring ) IF( errstring .NE. '' ) STOP 'call endrun( errstring )' ! Use fieldlist_wet to select the fields which will be diffused using moist mixing ratios ( all by default ) ! Use fieldlist_dry to select the fields which will be diffused using dry mixing ratios. IF( vdiff_select( fieldlist_wet, 'u' ) .NE. '' ) STOP '!call endrun( vdiff_select( fieldlist_wet, u ) )' IF( vdiff_select( fieldlist_wet, 'v' ) .NE. '' ) STOP '!call endrun( vdiff_select( fieldlist_wet, v ) )' IF( vdiff_select( fieldlist_wet, 's' ) .NE. '' ) STOP '!call endrun( vdiff_select( fieldlist_wet, s ) )' DO k = 1, pcnst IF (MODAL_AERO)THEN ! Do not diffuse droplet number - treated in dropmixnuc !PK if( k == ixndrop ) go to 20 ! Don't diffuse aerosol - treated in dropmixnuc !PK do m = 1, ntot_amode !PK if( k == numptr_amode(m) ) go to 20 !PK do l = 1, nspec_amode(m) !PK if( k == lmassptr_amode(l,m) ) go to 20 !PK enddo !PK enddo ENDIF IF( cnst_get_type_byind(k,pcnst) .EQ. 'wet' ) THEN IF( vdiff_select( fieldlist_wet, 'q', k ) .NE. '' ) STOP 'call endrun( vdiff_select( fieldlist_wet, q, k ) )' ELSE IF( vdiff_select( fieldlist_dry, 'q', k ) .NE. '' ) STOP 'call endrun( vdiff_select( fieldlist_dry, q, k ) )' ENDIF 20 CONTINUE END DO ! ------------------------ ! ! Diagnostic output fields ! ! ------------------------ ! DO k = 1, pcnst vdiffnam(k) = 'VD'//cnst_name(k) IF( k == 1 ) vdiffnam(k) = 'VD01' !**** compatibility with old code **** !call addfld( vdiffnam(k), 'kg/kg/s ', pver, 'A', 'Vertical diffusion of '//cnst_name(k), phys_decomp ) END DO ! call phys_getopts( history_budget_out = history_budget ) ! if( history_budget ) then !call add_default( vdiffnam(ixcldliq), 1, ' ' ) !call add_default( vdiffnam(ixcldice), 1, ' ' ) ! end if END SUBROUTINE vertical_diffusion_init !============================================================================ ! ! ! !============================================================================ ! !=============================================================================== SUBROUTINE ubc_init() !----------------------------------------------------------------------- ! Initialization of time independent fields for the upper boundary condition ! Calls initialization routine for MSIS, TGCM and SNOE !----------------------------------------------------------------------- END SUBROUTINE ubc_init ! =============================================================================== ! ! ! ! =============================================================================== ! SUBROUTINE vertical_diffusion_tend(& pcols , &!INTEGER , INTENT(IN ) :: pcols ! Number of columns dimensioned ncol , &!INTEGER , INTENT(IN ) :: ncol !integer, intent(in) :: ncol! Number of columns actually used ncnst , &!INTEGER , INTENT(IN ) :: ncnst ! Number of constituents pver , &!INTEGER , INTENT(IN ) :: pver !integer, intent(in) :: pver ! Number of model layers ztodt , &!REAL(r8), INTENT(in ) :: ztodt ! 2 delta-t [ s ] colrad , &! INTENT(IN ) Cosino the colatitude [radian] state_u , &! REAL(r8), INTENT(in ) :: state_u (pcols,pver) !real(r8), intent(in) :: u(pcols,pver) ! Layer mid-point zonal wind [ m/s ] state_v , &!REAL(r8), INTENT(in ) :: state_v (pcols,pver) !real(r8), intent(in) :: v(pcols,pver) ! Layer mid-point meridional wind [ m/s ] state_t , &!REAL(r8), INTENT(in ) :: state_t (pcols,pver) !real(r8), intent(in) :: t(pcols,pver) ! Layer mid-point temperature [ K ] qm1 , &! initial/final constituent field state_qv , &!REAL(r8), INTENT(in ) :: state_qv (pcols,pver) state_ql , &!REAL(r8), INTENT(in ) :: state_ql (pcols,pver) state_qi , &!REAL(r8), INTENT(in ) :: state_qi (pcols,pver) state_pmid , &!REAL(r8), INTENT(in ) :: state_pmid (pcols,pver) !real(r8), intent(in) :: pmid(pcols,pver) ! Layer mid-point pressure [ Pa ] state_pint , &!REAL(r8), INTENT(in ) :: state_pint (pcols,pver+1)!real(r8), intent(in) :: pi(pcols,pver+1) ! Interface pressure [ Pa ] state_exner, &!REAL(r8), INTENT(in ) :: state_exner(pcols,pver) !real(r8), intent(in) :: exner(pcols,pver) ! Layer mid-point exner function [ no unit ] state_zm , &!REAL(r8), INTENT(in ) :: state_zm (pcols,pver) !real(r8), intent(in) :: zm(pcols,pver) ! Layer mid-point height [ m ] state_zi , &!REAL(r8), INTENT(in ) :: state_zi (pcols,pver+1)!real(r8), intent(in) :: zi(pcols,pver+1) ! Interface height above surface [ m ] state_rpdel, &!REAL(r8), INTENT(in ) :: state_rpdel(pcols,pver) ! 1./pdel where 'pdel' is thickness of the layer [ Pa ] state_pdel , &!REAL(r8), INTENT(in ) :: state_rpdel(pcols,pver) ! 1./pdel where 'pdel' is thickness of the layer [ Pa ] sgh , &!REAL(r8), INTENT(in ) :: sgh (pcols) !real(r8), intent(in) :: sgh(pcols) ! Standard deviation of orography [ m ] landfrac , &!REAL(r8), INTENT(in ) :: landfrac (pcols) !real(r8), intent(in) :: landfrac(pcols) ! Land fraction [ fraction ] taux , &!REAL(r8), INTENT(in ) :: taux (pcols) ! x surface stress [ N/m2 ] tauy , &!REAL(r8), INTENT(in ) :: tauy (pcols) ! y surface stress [ N/m2 ] qrl , &!REAL(r8), INTENT(in ) :: qrl (pcols,pver) !qrl','g*W/m2', pver, 'A', 'LW cooling rate, L', phys_decomp ) wsedl , &!REAL(r8), INTENT(in ) :: wsedl (pcols,pver) !not used ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] cldn , &!REAL(r8), INTENT(in) :: cldn (pcols,pver) !real(r8), intent(in) :: cldn(pcols,pver) ! Stratiform cloud fraction [ fraction ] shflx , &!REAL(r8), INTENT(in) :: shflx (pcols) !real(r8), intent(in) :: shflx(pcols) ! Sensible heat flux at surface [ unit ? ] cflx , &!REAL(r8), INTENT(in) :: cflx (pcols,ncnst) !real(r8), intent(in) :: qflx(pcols) ! Water vapor flux at surface [ unit ? ] tauresx , &!REAL(r8), INTENT(inout) :: tauresx (pcols) ! Residual stress to be added in vdiff to correct tauresy , &!REAL(r8), INTENT(inout) :: tauresy (pcols) ! for turb stress mismatch between sfc and atm accumulated. kvm_in , &!REAL(r8), INTENT(inout) :: kvm_in (pcols,pver) ! kvm saved from last timestep [ m2/s ] kvh_in , &!REAL(r8), INTENT(inout) :: kvh_in (pcols,pver) ! kvh saved from last timestep [ m2/s ] dtv , &!REAL(r8), INTENT(OUT ) :: dtv (pcols,plev) ! temperature tendency (heating) dqv , &!REAL(r8), INTENT(OUT ) :: dqv (pcols,plev,pcnst) ! constituent diffusion tendency duv , &!REAL(r8), INTENT(OUT ) :: duv (pcols,plev) ! u-wind tendency dvv , &!REAL(r8), INTENT(OUT ) :: dvv (pcols,plev) ! v-wind tendency up1 , &!REAL(r8), INTENT(OUT ) :: up1 (pcols,plev)! u-wind after vertical diffusion vp1 , &!REAL(r8), INTENT(OUT ) :: vp1 (pcols,plev)! v-wind after vertical diffusion pblh , &!REAL(r8), INTENT(OUT ) :: pblh (pcols)! planetary boundary layer height tpert , &!REAL(r8), INTENT(OUT ) :: tpert (pcols)! convective temperature excess qpert , &!REAL(r8), INTENT(OUT ) :: qpert (pcols,pcnst)! convective humidity and constituent excess tke , &!real(r8), intent(inout) :: tke (pcols,plev+1) rino , &!REAL(r8), INTENT(INOUT) :: rino (pcols,plev)! bulk Richardson no. from level to ref lev obklen , &!REAL(r8), INTENT(OUT ) :: obklen(pcols)! Obukhov length tstar , &!REAL(r8), INTENT(OUT ) :: tstar (pcols) wstar , &!REAL(r8), INTENT(OUT ) :: wstar (pcols) ustar ) IMPLICIT NONE INTEGER , INTENT(IN ) :: pcols ! Number of columns dimensioned INTEGER , INTENT(IN ) :: ncol !integer, intent(in) :: ncol! Number of columns actually used INTEGER , INTENT(IN ) :: pver !integer, intent(in) :: pver ! Number of model layers INTEGER , INTENT(IN ) :: ncnst ! Number of constituents REAL(r8), INTENT(in ) :: ztodt ! 2 delta-t [ s ] REAL(r8), INTENT(IN ) :: colrad (pcols) REAL(r8), INTENT(in ) :: state_u (pcols,pver) !real(r8), intent(in) :: u(pcols,pver) ! Layer mid-point zonal wind [ m/s ] REAL(r8), INTENT(in ) :: state_v (pcols,pver) !real(r8), intent(in) :: v(pcols,pver) ! Layer mid-point meridional wind [ m/s ] REAL(r8), INTENT(in ) :: state_t (pcols,pver) !real(r8), intent(in) :: t(pcols,pver) ! Layer mid-point temperature [ K ] REAL(r8), INTENT(in ) :: state_qv (pcols,pver) REAL(r8), INTENT(in ) :: state_ql (pcols,pver) REAL(r8), INTENT(in ) :: state_qi (pcols,pver) REAL(r8), INTENT(in ) :: state_pmid (pcols,pver) !real(r8), intent(in) :: pmid(pcols,pver) ! Layer mid-point pressure [ Pa ] REAL(r8), INTENT(in ) :: state_pint (pcols,pver+1)!real(r8), intent(in) :: pi(pcols,pver+1) ! Interface pressure [ Pa ] REAL(r8), INTENT(in ) :: state_exner(pcols,pver) !real(r8), intent(in) :: exner(pcols,pver) ! Layer mid-point exner function [ no unit ] REAL(r8), INTENT(in ) :: state_zm (pcols,pver) !real(r8), intent(in) :: zm(pcols,pver) ! Layer mid-point height [ m ] REAL(r8), INTENT(in ) :: state_zi (pcols,pver+1)!real(r8), intent(in) :: zi(pcols,pver+1) ! Interface height above surface [ m ] REAL(r8), INTENT(in ) :: state_pdel (pcols,pver) ! layer thickness (Pa) REAL(r8), INTENT(in ) :: state_rpdel(pcols,pver) ! 1./pdel where 'pdel' is thickness of the layer [ Pa ] REAL(r8), INTENT(in ) :: sgh (pcols) !real(r8), intent(in) :: sgh(pcols) ! Standard deviation of orography [ m ] REAL(r8), INTENT(in ) :: landfrac (pcols) !real(r8), intent(in) :: landfrac(pcols) ! Land fraction [ fraction ] REAL(r8), INTENT(in ) :: taux (pcols) ! x surface stress [ N/m2 ] REAL(r8), INTENT(in ) :: tauy (pcols) ! y surface stress [ N/m2 ] REAL(r8), INTENT(in ) :: qrl (pcols,pver) !qrl','g*W/m2', pver, 'A', 'LW cooling rate, L', phys_decomp ) REAL(r8), INTENT(in ) :: wsedl (pcols,pver) !not used ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] REAL(r8), INTENT(in) :: cldn (pcols,pver) !real(r8), intent(in) :: cldn(pcols,pver) ! Stratiform cloud fraction [ fraction ] REAL(r8), INTENT(in) :: shflx (pcols) !real(r8), intent(in) :: shflx(pcols) ! Sensible heat flux at surface [ unit ? ] REAL(r8), INTENT(in) :: cflx (pcols,ncnst) !real(r8), intent(in) :: qflx(pcols) ! Water vapor flux at surface [ unit ? ] ! ! Input/output arguments ! REAL(kind=r8), INTENT(IN) :: qm1(pcols,pver,ncnst) ! initial/final constituent field ! ! Output arguments ! REAL(r8), INTENT(inout) :: tauresx (pcols) ! Residual stress to be added in vdiff to correct REAL(r8), INTENT(inout) :: tauresy (pcols) ! for turb stress mismatch between sfc and atm accumulated. REAL(r8), INTENT(inout) :: kvm_in (pcols,pver+1) ! kvm saved from last timestep [ m2/s ] REAL(r8), INTENT(inout) :: kvh_in (pcols,pver+1) ! kvh saved from last timestep [ m2/s ] REAL(kind=r8), INTENT(OUT ) :: dtv(pcols,pver) ! temperature tendency (heating) REAL(kind=r8), INTENT(OUT ) :: dqv(pcols,pver,pcnst) ! constituent diffusion tendency REAL(kind=r8), INTENT(OUT ) :: duv(pcols,pver) ! u-wind tendency REAL(kind=r8), INTENT(OUT ) :: dvv(pcols,pver) ! v-wind tendency REAL(kind=r8), INTENT(OUT ) :: up1(pcols,pver) ! u-wind after vertical diffusion REAL(kind=r8), INTENT(OUT ) :: vp1(pcols,pver) ! v-wind after vertical diffusion REAL(kind=r8), INTENT(OUT ) :: pblh(pcols) ! planetary boundary layer height REAL(kind=r8), INTENT(OUT ) :: tpert(pcols) ! convective temperature excess REAL(kind=r8), INTENT(OUT ) :: qpert(pcols,pcnst) ! convective humidity and constituent excess REAL(kind=r8), INTENT(INOUT) :: TKE(pcols,pver+1) REAL(kind=r8), INTENT(INOUT) :: rino(pcols,pver) ! bulk Richardson no. from level to ref lev REAL(kind=r8), INTENT(OUT ) :: obklen(pcols) ! Obukhov length REAL(kind=r8), INTENT(OUT ) :: tstar(pcols) REAL(kind=r8), INTENT(OUT ) :: wstar(pcols) REAL(r8) , INTENT(OUT ):: ustar(pcols) ! Surface friction velocity [ m/s ] REAL(r8) :: ptend_q(pcols,pver,ncnst) REAL(r8) :: ptend_s(pcols,pver) REAL(r8) :: ptend_u(pcols,pver) REAL(r8) :: ptend_v(pcols,pver) REAL(r8) :: state_s(pcols,pver) !real(r8), intent(in) :: t(pcols,pver) ! Layer mid-point temperature [ K ] REAL(r8) :: state_pmiddry(pcols,pver) REAL(r8) :: state_pintdry(pcols,pver+1) REAL(r8) :: state_rpdeldry(pcols,pver) !REAL(r8) :: ustar(pcols) ! Surface friction velocity [ m/s ] !REAL(r8) :: pblh(pcols) ! PBL top height [ m ] !REAL(r8) :: obklen(pcols) ! Obukhov length [ m ] REAL(r8) :: tpertPBL(pcols) REAL(r8) :: qpertPBL(pcols) REAL(r8) :: slv_prePBL(pcols,pver) REAL(r8) :: slten(pcols,pver) REAL(r8) :: qtten(pcols,pver) REAL(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH REAL(r8) :: ftem(pcols,pver) ! Saturation vapor pressure before PBL REAL(r8) :: ftem_prePBL(pcols,pver) ! Saturation vapor pressure before PBL !real(r8) :: kvm_out(pcols,pver+1) ! Eddy diffusivity for momentum [ m2/s ] !real(r8) :: kvh_out(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] !real(r8) :: kvq(pcols,pver+1) ! Eddy diffusivity for constituents, moisture and tracers [ m2/s ] (note not having '_out') REAL(r8) :: smaw(pcols,pver+1)!real(r8), intent(out) :: sm_aw(pcols,pver+1) ! Normalized Galperin instability function for momentum [ no unit ] REAL(r8) :: cgh(pcols,pver+1) ! Counter-gradient term for heat [ J/kg/m ] REAL(r8) :: cgs(pcols,pver+1) ! Counter-gradient star [ cg/flux ] !REAL(r8) :: tpert(pcols) ! Convective temperature excess [ K ] REAL(r8) :: qpert_loc(pcols) ! Convective humidity excess [ kg/kg ] REAL(r8) :: wpert(pcols) ! Turbulent velocity excess [ m/s ] !REAL(r8) :: tke(pcols,pver+1) ! Turbulent kinetic energy [ m2/s2 ] REAL(r8) :: bprod(pcols,pver+1) ! Buoyancy production [ m2/s3 ] REAL(r8) :: sprod(pcols,pver+1) ! Shear production [ m2/s3 ] REAL(r8) :: sfi(pcols,pver+1) ! Interfacial layer saturation fraction [ fraction ] !integer ,external :: fqsatd !integer, external :: compute_molec_diff ! Constituent-independent moleculuar diffusivity routine REAL(r8) :: ipbl(pcols) ! If 1, PBL is CL, while if 0, PBL is STL. REAL(r8) :: kpblh(pcols) ! Layer index containing PBL top within or at the base interface REAL(r8) :: wstarPBL(pcols) ! Convective velocity within PBL [ m/s ] REAL(r8) :: turbtype(pcols,pver+1)! Turbulence type identifier at all interfaces [ no unit ] REAL(r8) :: kvm (pcols,pver+1) ! Eddy diffusivity for momentum [ m2/s ] REAL(r8) :: kvh (pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] REAL(r8) :: kvq (pcols,pver+1) ! Eddy diffusivity for constituents, moisture and tracers [ m2/s ] (note not having '_out') REAL(r8) :: sl_prePBL(pcols,pver) REAL(r8) :: qt_prePBL(pcols,pver) LOGICAL :: kvinit ! Tell compute_eddy_diff/ caleddy to initialize kvh, kvm (uses kvf) REAL(r8) :: rztodt ! 1./ztodt [ 1/s ] REAL(r8) :: ksrftms(pcols) !real(r8), intent(out) :: ksrf(pcols) ! Surface drag coefficient [ kg/s/m2 ] REAL(r8) :: tautmsx(pcols) !real(r8), intent(out) :: taux(pcols) ! Surface zonal wind stress [ N/m2 ] REAL(r8) :: tautmsy(pcols) !real(r8), intent(out) :: tauy(pcols) ! Surface meridional wind stress [ N/m2 ] REAL(r8) :: tautotx(pcols) ! U component of total surface stress [ N/m2 ] REAL(r8) :: tautoty(pcols) ! V component of total surface stress [ N/m2 ] REAL(r8) :: dtk(pcols,pver) ! T tendency from KE dissipation REAL(r8) :: topflx(pcols) ! Molecular heat flux at top interface REAL(r8) :: sl(pcols,pver) REAL(r8) :: qt(pcols,pver) REAL(r8) :: slv(pcols,pver) REAL(r8) :: slflx(pcols,pver+1) REAL(r8) :: qtflx(pcols,pver+1) REAL(r8) :: uflx(pcols,pver+1) REAL(r8) :: vflx(pcols,pver+1) REAL(r8) :: slflx_cg(pcols,pver+1) REAL(r8) :: qtflx_cg(pcols,pver+1) REAL(r8) :: uflx_cg(pcols,pver+1) REAL(r8) :: vflx_cg(pcols,pver+1) REAL(r8) :: qv_pro(pcols,pver) REAL(r8) :: ql_pro(pcols,pver) REAL(r8) :: qi_pro(pcols,pver) REAL(r8) :: s_pro(pcols,pver) REAL(r8) :: t_pro(pcols,pver) REAL(r8) :: qv_aft_PBL(pcols,pver) ! qv after PBL diffusion REAL(r8) :: ql_aft_PBL(pcols,pver) ! ql after PBL diffusion REAL(r8) :: qi_aft_PBL(pcols,pver) ! qi after PBL diffusion REAL(r8) :: s_aft_PBL(pcols,pver) ! s after PBL diffusion REAL(r8) :: u_aft_PBL(pcols,pver) ! u after PBL diffusion REAL(r8) :: v_aft_PBL(pcols,pver) ! v after PBL diffusion REAL(r8) :: t_aftPBL(pcols,pver) ! Temperature after PBL diffusion REAL(r8) :: ftem_aftPBL(pcols,pver) ! Saturation vapor pressure after PBL REAL(r8) :: tten(pcols,pver) ! Temperature tendency by PBL diffusion REAL(r8) :: rhten(pcols,pver) ! RH tendency by PBL diffusion REAL(r8) :: rhoair CHARACTER(128) :: errstring ! Error status for init_vdiff INTEGER :: lchnk ,i,k ,m ! Chunk identifier INTEGER :: time_index ! Time level index for physics buffer access ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! rhoair=0.0_r8 DO m=1,pcnst DO k=1,pver DO i=1,ncol dqv(i,k,m) =0.0_r8 ! constituent diffusion tendency ptend_q(i,k,m) =0.0_r8 END DO END DO END DO DO k=1,pver DO i=1,ncol dtv(i,k)=0.0_r8 ! temperature tendency (heating) duv(i,k)=0.0_r8 ! u-wind tendency dvv(i,k)=0.0_r8 ! v-wind tendency ptend_s(i,k)=0.0_r8 ptend_u(i,k)=0.0_r8 ptend_v(i,k)=0.0_r8 state_s(i,k)=0.0_r8 !real(r8), intent(in) :: t(pcols,pver) ! Layer mid-point temperature [ K ] state_pmiddry(i,k)=0.0_r8 up1(i,k)=0.0_r8 ! u-wind after vertical diffusion vp1(i,k)=0.0_r8 ! v-wind after vertical diffusion state_rpdeldry(i,k)=0.0_r8 slv_prePBL(i,k) =0.0_r8 slten(i,k) =0.0_r8 qtten(i,k) =0.0_r8 tem2(i,k) =0.0_r8 ! Saturation specific humidity and RH ftem(i,k) =0.0_r8 ! Saturation vapor pressure before PBL ftem_prePBL(i,k) =0.0_r8 ! Saturation vapor pressure before PBL sl_prePBL(i,k) =0.0_r8 qt_prePBL(i,k) =0.0_r8 dtk(i,k) =0.0_r8 ! T tendency from KE dissipation sl(i,k) =0.0_r8 qt(i,k) =0.0_r8 slv(i,k) =0.0_r8 qv_pro(i,k) =0.0_r8 ql_pro(i,k) =0.0_r8 qi_pro(i,k) =0.0_r8 s_pro(i,k) =0.0_r8 t_pro(i,k) =0.0_r8 qv_aft_PBL(i,k) =0.0_r8 ! qv after PBL diffusion ql_aft_PBL(i,k) =0.0_r8 ! ql after PBL diffusion qi_aft_PBL(i,k) =0.0_r8 ! qi after PBL diffusion s_aft_PBL(i,k) =0.0_r8 ! s after PBL diffusion u_aft_PBL(i,k) =0.0_r8 ! u after PBL diffusion v_aft_PBL(i,k) =0.0_r8 ! v after PBL diffusion t_aftPBL(i,k) =0.0_r8 ! Temperature after PBL diffusion ftem_aftPBL(i,k) =0.0_r8 ! Saturation vapor pressure after PBL tten(i,k) =0.0_r8 ! Temperature tendency by PBL diffusion rhten(i,k) =0.0_r8 ! RH tendency by PBL diffusion END DO END DO DO k=1,pver+1 DO i=1,ncol state_pintdry(i,k)=0.0_r8 smaw (i,k)=0.0_r8!real(r8), intent(out) :: sm_aw(i,k) ! Normalized Galperin instability function for momentum [ no unit ] cgh (i,k)=0.0_r8! Counter-gradient term for heat [ J/kg/m ] cgs (i,k)=0.0_r8! Counter-gradient star [ cg/flux ] bprod(i,k)=0.0_r8! Buoyancy production [ m2/s3 ] sprod(i,k)=0.0_r8! Shear production [ m2/s3 ] sfi (i,k)=0.0_r8! Interfacial layer saturation fraction [ fraction ] turbtype(i,k)=0.0_r8! Turbulence type identifier at all interfaces [ no unit ] kvm (i,k)=0.0_r8! Eddy diffusivity for momentum [ m2/s ] kvh (i,k)=0.0_r8! Eddy diffusivity for heat [ m2/s ] kvq (i,k)=0.0_r8! Eddy diffusivity for constituents, moisture and tracers [ m2/s ] (note not having '_out') slflx(i,k)=0.0_r8 qtflx(i,k)=0.0_r8 uflx(i,k)=0.0_r8 vflx(i,k)=0.0_r8 slflx_cg(i,k)=0.0_r8 qtflx_cg(i,k)=0.0_r8 uflx_cg(i,k)=0.0_r8 vflx_cg(i,k)=0.0_r8 END DO END DO DO m=1,pcnst DO i=1,ncol qpert(i,m)=0.0_r8 ! convective humidity and constituent excess END DO END DO DO i=1,ncol tpertPBL(i)=0.0_r8 qpertPBL(i)=0.0_r8 wpert(i)=0.0_r8! Turbulent velocity excess [ m/s ] qpert_loc(i)=0.0_r8! Convective humidity excess [ kg/kg ] ipbl(i)=0.0_r8! If 1, PBL is CL, while if 0, PBL is STL. kpblh(i)=0.0_r8! Layer index containing PBL top within or at the base interface wstarPBL(i)=0.0_r8! Convective velocity within PBL [ m/s ] ksrftms(i)=0.0_r8!real(r8), intent(out) :: ksrf(pcols)! Surface drag coefficient [ kg/s/m2 ] tautmsx(i)=0.0_r8!real(r8), intent(out) :: taux(pcols)! Surface zonal wind stress [ N/m2 ] tautmsy(i)=0.0_r8!real(r8), intent(out) :: tauy(pcols)! Surface meridional wind stress [ N/m2 ] tautotx(i)=0.0_r8! U component of total surface stress [ N/m2 ] tautoty(i)=0.0_r8! V component of total surface stress [ N/m2 ] topflx(i)=0.0_r8! Molecular heat flux at top interface pblh(i)=0.0_r8 ! planetary boundary layer height tpert(i)=0.0_r8 ! convective temperature excess obklen(i)=0.0_r8 ! Obukhov length tstar(i)=0.0_r8 wstar(i)=0.0_r8 END DO !------ rztodt = 1._r8 / ztodt !state_s(pcols,pver) !real(r8), intent(in) :: t(pcols,pver) ! Layer mid-point temperature [ K ] ! !t_aftPBL(:ncol,:pver) = ( s_aft_PBL(:ncol,:pver) - gravit*state_zm(:ncol,:pver) ) / cpair ! !cpair * t_aftPBL(:ncol,:pver) = s_aft_PBL(:ncol,:pver) - gravit*state_zm(:ncol,:pver) ! !cpair * t_aftPBL(:ncol,:pver)+ gravit*state_zm(:ncol,:pver) = s_aft_PBL(:ncol,:pver) ! DO k=1,pver DO i=1,ncol state_s(i,k) =cpair * state_t(i,k)+ gravit*state_zm(i,k) END DO END DO !lchnk = state%lchnk !ncol = state%ncol IF( is_first_step) THEN ! tauresx(:ncol) = 0._r8 ! tauresy(:ncol) = 0._r8 ELSE ! tauresx(:ncol) = pbuf(tauresx_idx)%fld_ptr(1,1:ncol,1,lchnk,time_index) ! tauresy(:ncol) = pbuf(tauresy_idx)%fld_ptr(1,1:ncol,1,lchnk,time_index) ENDIF ! All variables are modified by vertical diffusion !ptend%name = "vertical diffusion" !ptend%lq(:) = .TRUE. !ptend%ls = .TRUE. !ptend%lu = .TRUE. !ptend%lv = .TRUE. ! ---------------------------------------- ! ! Computation of turbulent mountain stress ! ! ---------------------------------------- ! ! Consistent with the computation of 'normal' drag coefficient, we are using ! the raw input (u,v) to compute 'ksrftms', not the provisionally-marched 'u,v' ! within the iteration loop of the PBL scheme. IF( do_tms ) THEN CALL compute_tms( pcols , &!integer, intent(in) :: pcols ! Number of columns dimensioned pver , &!integer, intent(in) :: pver ! Number of model layers ncol , &!integer, intent(in) :: ncol ! Number of columns actually used state_u , &!real(r8), intent(in) :: u(pcols,pver) ! Layer mid-point zonal wind [ m/s ] state_v , &!real(r8), intent(in) :: v(pcols,pver) ! Layer mid-point meridional wind [ m/s ] state_t , &!real(r8), intent(in) :: t(pcols,pver) ! Layer mid-point temperature [ K ] state_pmid , &!real(r8), intent(in) :: pmid(pcols,pver) ! Layer mid-point pressure [ Pa ] state_exner, &!real(r8), intent(in) :: exner(pcols,pver) ! Layer mid-point exner function [ no unit ] state_zm , &!real(r8), intent(in) :: zm(pcols,pver) ! Layer mid-point height [ m ] sgh , &!real(r8), intent(in) :: sgh(pcols) ! Standard deviation of orography [ m ] ksrftms , &!real(r8), intent(out) :: ksrf(pcols) ! Surface drag coefficient [ kg/s/m2 ] tautmsx , &!real(r8), intent(out) :: taux(pcols) ! Surface zonal wind stress [ N/m2 ] tautmsy , &!real(r8), intent(out) :: tauy(pcols) ! Surface meridional wind stress [ N/m2 ] landfrac )!real(r8), intent(in) :: landfrac(pcols) ! Land fraction [ fraction ] ! Here, both 'taux, tautmsx' are explicit surface stresses. ! Note that this 'tautotx, tautoty' are different from the total stress ! that has been actually added into the atmosphere. This is because both ! taux and tautmsx are fully implicitly treated within compute_vdiff. ! However, 'tautotx, tautoty' are not used in the actual numerical ! computation in this module. DO i=1,ncol tautotx(i) = taux(i) + tautmsx(i) tautoty(i) = tauy(i) + tautmsy(i) END DO ELSE DO i=1,ncol ksrftms(i) = 0._r8 tautotx(i) = taux(i) tautoty(i) = tauy(i) END DO ENDIF !----------------------------------------------------------------------- ! ! Computation of eddy diffusivities - Select appropriate PBL scheme ! !----------------------------------------------------------------------- ! SELECT CASE (eddy_scheme) CASE ( 'diag_TKE' ) ! ---------------------------------------------------------------- ! ! At first time step, have eddy_diff.F90:caleddy() use kvh=kvm=kvf ! ! This has to be done in compute_eddy_diff after kvf is calculated ! ! ---------------------------------------------------------------- ! IF( is_first_step) THEN kvinit = .TRUE. ELSE kvinit = .FALSE. ENDIF ! ---------------------------------------------- ! ! Get LW radiative heating out of physics buffer ! ! ---------------------------------------------- ! ! qrl (pcols,pver) ! => pbuf(pbuf_get_fld_idx('QRL' ))%fld_ptr(1,1:pcols,1:pver,lchnk,1) ! wsedl(pcols,pver) ! => pbuf(pbuf_get_fld_idx('WSEDL'))%fld_ptr(1,1:pcols,1:pver,lchnk,1) ! Retrieve eddy diffusivities for heat and momentum from physics buffer ! from last timestep ( if first timestep, has been initialized by inidat.F90 ) !time_index = pbuf_old_tim_idx() !kvm_in(:ncol,:) = pbuf(kvm_idx)%fld_ptr(1,1:ncol,1:pverp,lchnk,time_index) !kvh_in(:ncol,:) = pbuf(kvh_idx)%fld_ptr(1,1:ncol,1:pverp,lchnk,time_index) CALL compute_eddy_diff( & lchnk , &!integer, intent(in) :: lchnk pcols , &!integer, intent(in) :: pcols ! Number of atmospheric columns [ # ] pver , &!integer, intent(in) :: pver ! Number of atmospheric layers [ # ] ncol , &!integer, intent(in) :: ncol ! Number of atmospheric columns [ # ] state_t , &!real(r8), intent(in) :: t(pcols,pver) ! Temperature [K] state_qv , &!real(r8), intent(in) :: qv(pcols,pver) ! Water vapor specific humidity [ kg/kg ] ztodt , &!real(r8), intent(in) :: ztodt ! Physics integration time step 2 delta-t [ s ] state_ql , &!real(r8), intent(in) :: ql(pcols,pver) ! Liquid water specific humidity [ kg/kg ] state_qi , &!real(r8), intent(in) :: qi(pcols,pver) ! Ice specific humidity [ kg/kg ] state_rpdel , &!real(r8), intent(in) :: rpdel(pcols,pver) ! 1./pdel where 'pdel' is thickness of the layer [ Pa ] cldn , &!real(r8), intent(in) :: cldn(pcols,pver) ! Stratiform cloud fraction [ fraction ] qrl , &!real(r8), intent(in) :: qrl(pcols,pver) ! LW cooling rate wsedl , &!real(r8), intent(in) :: wsedl(pcols,pver) ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] state_zm , &!real(r8), intent(in) :: z(pcols,pver) ! Layer mid-point height above surface [ m ] state_zi , &!real(r8), intent(in) :: zi(pcols,pver+1) ! Interface height above surface [ m ] state_pmid , &!real(r8), intent(in) :: pmid(pcols,pver) ! Layer mid-point pressure [ Pa ] state_pint , &!real(r8), intent(in) :: pi(pcols,pver+1) ! Interface pressure [ Pa ] state_u , &!real(r8), intent(in) :: u(pcols,pver) ! Zonal velocity [ m/s ] state_v , &!real(r8), intent(in) :: v(pcols,pver) ! Meridional velocity [ m/s ] taux , &!real(r8), intent(in) :: taux(pcols) ! Zonal wind stress at surface [ N/m2 ] tauy , &!real(r8), intent(in) :: tauy(pcols) ! Meridional wind stress at surface [ N/m2 ] shflx , &!real(r8), intent(in) :: shflx(pcols) ! Sensible heat flux at surface [ unit ? ] cflx(:,1) , &!real(r8), intent(in) :: qflx(pcols) ! Water vapor flux at surface [ unit ? ] wstarent , &!logical, intent(in) :: wstarent ! .true. means use the 'wstar' entrainment closure. nturb , &!integer, intent(in) :: nturb ! Number of iteration steps for calculating eddy diffusivity [ # ] ustar , &!real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] pblh , &!real(r8), intent(out) :: pblh(pcols) ! PBL top height [ m ] landfrac , & kvm_in , &!real(r8), intent(in) :: kvm_in(pcols,pver+1) ! kvm saved from last timestep [ m2/s ] kvh_in , &!real(r8), intent(in) :: kvh_in(pcols,pver+1) ! kvh saved from last timestep [ m2/s ] kvm , &!real(r8), intent(out) :: kvm_out(pcols,pver+1) ! Eddy diffusivity for momentum [ m2/s ] kvh , &!real(r8), intent(out) :: kvh_out(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] kvq , &!real(r8), intent(out) :: kvq(pcols,pver+1) ! Eddy diffusivity for constituents, moisture and tracers [ m2/s ] (note not having '_out') cgh , &!real(r8), intent(out) :: cgh(pcols,pver+1) ! Counter-gradient term for heat [ J/kg/m ] cgs , &!real(r8), intent(out) :: cgs(pcols,pver+1) ! Counter-gradient star [ cg/flux ] tpert , &!real(r8), intent(out) :: tpert(pcols) ! Convective temperature excess [ K ] qpert_loc , &!real(r8), intent(out) :: qpert(pcols) ! Convective humidity excess [ kg/kg ] wpert , &!real(r8), intent(out) :: wpert(pcols) ! Turbulent velocity excess [ m/s ] tke , &!real(r8), intent(out) :: tke(pcols,pver+1) ! Turbulent kinetic energy [ m2/s2 ] bprod , &!real(r8), intent(out) :: bprod(pcols,pver+1) ! Buoyancy production [ m2/s3 ] sprod , &!real(r8), intent(out) :: sprod(pcols,pver+1) ! Shear production [ m2/s3 ] sfi , &!real(r8), intent(out) :: sfi(pcols,pver+1) ! Interfacial layer saturation fraction [ fraction ] kvinit , &!logical, intent(in ) :: kvinit ! Tell compute_eddy_diff/ caleddy to initialize kvh, kvm (uses kvf) tauresx , &!real(r8), intent(inout) :: tauresx(pcols) ! Residual stress to be added in vdiff to correct for turb tauresy , &!real(r8), intent(inout) :: tauresy(pcols) ! Stress mismatch between sfc and atm accumulated in prior timesteps ksrftms , &!real(r8), intent(in) :: ksrftms(pcols) ! Surface drag coefficient of turbulent mountain stress [ unit ? ] ipbl(:) , &!real(r8), intent(out) :: ipbl(pcols) ! If 1, PBL is CL, while if 0, PBL is STL. kpblh(:) , &!real(r8), intent(out) :: kpblh(pcols) ! Layer index containing PBL top within or at the base interface wstarPBL(:) , &!real(r8), intent(out) :: wstarPBL(pcols) ! Convective velocity within PBL [ m/s ] turbtype , &!real(r8), intent(out) :: turbtype(pcols,pver+1)! Turbulence type identifier at all interfaces [ no unit ] smaw , &!real(r8), intent(out) :: sm_aw(pcols,pver+1) ! Normalized Galperin instability function for momentum [ no unit ] rino )!REAL(r8), INTENT(out) :: ri(pcols,pver) ! Richardson number, 'n2/s2', defined at interfaces except surface [ s-2 ] obklen(1:ncol) = 0._r8 ! ----------------------------------------------- ! ! Store TKE in pbuf for use by shallow convection ! ! ----------------------------------------------- ! DO i=1,ncol wstar(i)=wstarPBL(i) tpertPBL(i) = tpert(i) qpertPBL(i) = qpert_loc(i) qpert (i,1) = qpert_loc(i) END DO !pbuf(tke_idx)%fld_ptr(1,1:ncol,1:pverp,lchnk,time_index) = tke(:ncol,:) !pbuf(turbtype_idx)%fld_ptr(1,1:ncol,1:pverp,lchnk,time_index) = turbtype(:ncol,:) !pbuf(smaw_idx)%fld_ptr(1,1:ncol,1:pverp,lchnk,time_index) = smaw(:ncol,:) ! Store updated kvh, kvm in pbuf to use here on the next timestep !pbuf(kvh_idx)%fld_ptr(1,1:ncol,1:pverp,lchnk,time_index) = kvh(:ncol,:) !pbuf(kvm_idx)%fld_ptr(1,1:ncol,1:pverp,lchnk,time_index) = kvm(:ncol,:) !if( is_first_step() ) then ! do i = 1, pbuf_times ! pbuf(kvh_idx)%fld_ptr(1,1:ncol,1:pverp,lchnk,i) = kvh(:ncol,:) ! pbuf(kvm_idx)%fld_ptr(1,1:ncol,1:pverp,lchnk,i) = kvm(:ncol,:) ! enddo !endif ! Write out fields that are only used by this scheme !call outfld( 'BPROD ', bprod(1,1), pcols, lchnk ) !call outfld( 'SPROD ', sprod(1,1), pcols, lchnk ) !call outfld( 'SFI ', sfi, pcols, lchnk ) CASE ( 'HB', 'HBR' ) ! Modification : We may need to use 'taux' instead of 'tautotx' here, for ! consistency with the previous HB scheme. END SELECT !pbuf(wgustd_index)%fld_ptr(1,1:ncol,1,lchnk,1) = wpert(:ncol) !call outfld( 'WGUSTD' , wpert, pcols, lchnk ) !------------------------------------ ! ! Application of diffusivities ! !------------------------------------ ! !qm1 DO m=1,ncnst DO k=1,pver DO i=1,ncol !ptend_q(i,k,1) = state_qv(i,k) !ptend_q(i,k,2) = state_qi(i,k) !ptend_q(i,k,3) = state_ql(i,k) ptend_q(i,k,m) = qm1(i,k,m) END DO END DO END DO DO k=1,pver DO i=1,ncol ptend_s(i,k) = state_s(i,k) ptend_u(i,k) = state_u(i,k) ptend_v(i,k) = state_v(i,k) END DO END DO !------------------------------------------------------ ! ! Write profile output before applying diffusion scheme ! !------------------------------------------------------ ! DO k=1,pver DO i=1,ncol IF(ncnst > ixcldliq .and. ncnst > ixcldice)THEN sl_prePBL(i,k) = ptend_s(i,k) - latvap * ptend_q(i,k,ixcldliq) & - ( latvap + latice) * ptend_q(i,k,ixcldice) qt_prePBL(i,k) = ptend_q(i,k,1) + ptend_q(i,k,ixcldliq) + ptend_q(i,k,ixcldice) ELSE sl_prePBL(i,k) = ptend_s(i,k) qt_prePBL(i,k) = ptend_q(i,k,1) END IF slv_prePBL(i,k) = sl_prePBL(i,k) * ( 1._r8 + zvir*qt_prePBL(i,k) ) END DO END DO CALL aqsat( state_t, state_pmid, tem2, ftem, pcols, ncol, pver, 1, pver ) ! Saturation vapor pressure before PBL DO k=1,pver DO i=1,pcols ftem_prePBL(i,k) = state_qv(i,k)/ftem(i,k)*100._r8 END DO END DO !call outfld( 'qt_pre_PBL ', qt_prePBL, pcols, lchnk ) !call outfld( 'sl_pre_PBL ', sl_prePBL, pcols, lchnk ) !call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) !call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) !call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) !call outfld( 'qv_pre_PBL ', state%q(:ncol,:,1), pcols, lchnk ) !call outfld( 'ql_pre_PBL ', state%q(:ncol,:,ixcldliq), pcols, lchnk ) !call outfld( 'qi_pre_PBL ', state%q(:ncol,:,ixcldice), pcols, lchnk ) !call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) !call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) ! --------------------------------------------------------------------------------- ! ! Call the diffusivity solver and solve diffusion equation ! ! The final two arguments are optional function references to ! ! constituent-independent and constituent-dependent moleculuar diffusivity routines ! ! --------------------------------------------------------------------------------- ! ! Modification : We may need to output 'tautotx_im,tautoty_im' from below 'compute_vdiff' and ! separately print out as diagnostic output, because these are different from ! the explicit 'tautotx, tautoty' computed above. ! Note that the output 'tauresx,tauresy' from below subroutines are fully implicit ones. IF( ANY(fieldlist_wet) ) THEN CALL compute_vdiff( & lchnk , & !integer, intent(in) :: lchnk pcols , & !integer, intent(in) :: pcols pver , & !integer, intent(in) :: pver pcnst , & !integer, intent(in) :: ncnst ncol , & !integer, intent(in) :: ncol ! Number of atmospheric columns state_pmid , & !real(r8), intent(in) :: pmid(pcols,pver) ! Mid-point pressures [ Pa ] state_pint , & !real(r8), intent(in) :: pint(pcols,pver+1) ! Interface pressures [ Pa ] state_rpdel , & !real(r8), intent(in) :: rpdel(pcols,pver) ! 1./pdel state_t , & !real(r8), intent(in) :: t(pcols,pver) ! Temperature [ K ] ztodt , & !real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] taux , & !real(r8), intent(in) :: taux(pcols) ! Surface zonal stress. Input u-momentum per unit time per unit area into the atmosphere [ N/m2 ] tauy , & !real(r8), intent(in) :: tauy(pcols) ! Surface meridional stress. Input v-momentum per unit time per unit area into the atmosphere [ N/m2 ] shflx , & !real(r8), intent(in) :: shflx(pcols) ! Surface sensible heat flux [ W/m2 ] cflx , & !real(r8), intent(in) :: cflx(pcols,ncnst) ! Surface constituent flux [ kg/m2/s ] ntop , & !integer, intent(in) :: ntop ! Top interface level to which vertical diffusion is applied ( = 1 ). nbot , & !integer, intent(in) :: nbot ! Bottom interface level to which vertical diffusion is applied ( = pver ). kvh , & !real(r8), intent(inout) :: kvh(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] kvm , & !real(r8), intent(inout) :: kvm(pcols,pver+1) ! Eddy viscosity ( Eddy diffusivity for momentum ) [ m2/s ] kvq , & !real(r8), intent(inout) :: kvq(pcols,pver+1) ! Eddy diffusivity for constituents cgs , & !real(r8), intent(inout) :: cgs(pcols,pver+1) ! Counter-gradient star [ cg/flux ] cgh , & !real(r8), intent(inout) :: cgh(pcols,pver+1) ! Counter-gradient term for heat state_zi , & !real(r8), intent(in) :: zi(pcols,pver+1) ! Interface heights [ m ] ksrftms , & !real(r8), intent(in) :: ksrftms(pcols) ! Surface drag coefficient for turbulent mountain stress. > 0. [ kg/s/m2 ] qmincg , & !real(r8), intent(in) :: qmincg(ncnst) ! Minimum constituent mixing ratios from cg fluxes fieldlist_wet , & !type(vdiff_selector), intent(in) :: fieldlist ! Array of flags selecting which fields to diffuse ptend_u , & !real(r8), intent(inout) :: u(pcols,pver) ! U wind. This input is the 'raw' input wind to PBL scheme without iterative provisional update. [ m/s ptend_v , & !real(r8), intent(inout) :: v(pcols,pver) ! V wind. This input is the 'raw' input wind to PBL scheme without iterative provisional update. [ m/s ptend_q , & !real(r8), intent(inout) :: q(pcols,pver,ncnst) ! Moisture and trace constituents [ kg/kg, #/kg ? ] ptend_s , & !real(r8), intent(inout) :: dse(pcols,pver) ! Dry static energy [ J/kg ] tautmsx , & !real(r8), intent(inout) :: tauresx(pcols) ! Input : Reserved surface stress at previous time step tautmsy , & !real(r8), intent(inout) :: tauresy(pcols) ! Output : Reserved surface stress at current time step dtk , & !real(r8), intent(out) :: dtk(pcols,pver) ! T tendency from KE dissipation topflx , & !real(r8), intent(out) :: topflx(pcols) ! Molecular heat flux at the top interface errstring , & !character(128), intent(out) :: errstring ! Output status tauresx , & !real(r8), intent(out) :: tautmsx(pcols) ! Implicit zonal turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ] tauresy , & !real(r8), intent(out) :: tautmsy(pcols) ! Implicit meridional turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ] 1 )!, & !integer, intent(in) :: itaures ! Indicator determining whether 'tauresx,tauresy' is updated (1) or non-updated (0) in this subroutine !do_molec_diff , & ! !compute_molec_diff, & ! !compute_molec_diff ) !integer, external, optional :: compute_molec_diff ! Constituent-independent moleculuar diffusivity routine END IF IF( errstring .NE. '' ) STOP 'call endrun( errstring )' IF( ANY( fieldlist_dry ) ) THEN IF( do_molec_diff ) THEN errstring = "Design flaw: dry vdiff not currently supported with molecular diffusion" STOP 'call endrun( errstring )' END IF CALL compute_vdiff( & lchnk , &!integer, intent(in) :: lchnk pcols , &!integer, intent(in) :: pcols pver , &!integer, intent(in) :: pver pcnst , &!integer, intent(in) :: ncnst ncol , &!integer, intent(in) :: ncol ! Number of atmospheric columns state_pmid , &!real(r8), intent(in) :: state_pmiddry(pcols,pver) ! Mid-point pressures [ Pa ] state_pint , &!real(r8), intent(in) :: state_pintdry(pcols,pver+1) ! Interface pressures [ Pa ] state_rpdel , &!real(r8), intent(in) :: state_rpdeldry(pcols,pver) ! 1./pdel state_t , &!real(r8), intent(in) :: t(pcols,pver) ! Temperature [ K ] ztodt , &!real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] taux , &!real(r8), intent(in) :: taux(pcols) ! Surface zonal stress. Input u-momentum per unit time per unit area into the atmosphere [ N/m2 ] tauy , &!real(r8), intent(in) :: tauy(pcols) ! Surface meridional stress. Input v-momentum per unit time per unit area into the atmosphere [ N/m2 ] shflx , &!real(r8), intent(in) :: shflx(pcols) ! Surface sensible heat flux [ W/m2 ] cflx , &!real(r8), intent(in) :: cflx(pcols,ncnst) ! Surface constituent flux [ kg/m2/s ] ntop , &!integer, intent(in) :: ntop ! Top interface level to which vertical diffusion is applied ( = 1 ). nbot , &!integer, intent(in) :: nbot ! Bottom interface level to which vertical diffusion is applied ( = pver ). kvh , &!real(r8), intent(inout) :: kvh(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] kvm , &!real(r8), intent(inout) :: kvm(pcols,pver+1) ! Eddy viscosity ( Eddy diffusivity for momentum ) [ m2/s ] kvq , &!real(r8), intent(inout) :: kvq(pcols,pver+1) ! Eddy diffusivity for constituents cgs , &!real(r8), intent(inout) :: cgs(pcols,pver+1) ! Counter-gradient star [ cg/flux ] cgh , &!real(r8), intent(inout) :: cgh(pcols,pver+1) ! Counter-gradient term for heat state_zi , &!real(r8), intent(in) :: zi(pcols,pver+1) ! Interface heights [ m ] ksrftms , &!real(r8), intent(in) :: ksrftms(pcols) ! Surface drag coefficient for turbulent mountain stress. > 0. [ kg/s/m2 ] qmincg , &!real(r8), intent(in) :: qmincg(ncnst) ! Minimum constituent mixing ratios from cg fluxes fieldlist_dry , &!type(vdiff_selector) , intent(in) :: fieldlist ! Array of flags selecting which fields to diffuse ptend_u , &!real(r8), intent(inout) :: u(pcols,pver) ! U wind. This input is the 'raw' input wind to PBL scheme without iterative provisional update. [ m/s ptend_v , &!real(r8), intent(inout) :: v(pcols,pver) ! V wind. This input is the 'raw' input wind to PBL scheme without iterative provisional update. [ m/s ptend_q , &!real(r8), intent(inout) :: q(pcols,pver,ncnst) ! Moisture and trace constituents [ kg/kg, #/kg ? ] ptend_s , &!real(r8), intent(inout) :: dse(pcols,pver) ! Dry static energy [ J/kg ] tautmsx , &!real(r8), intent(inout) :: tauresx(pcols) ! Input : Reserved surface stress at previous time step tautmsy , &!real(r8), intent(inout) :: tauresy(pcols) ! Output : Reserved surface stress at current time step dtk , &!real(r8), intent(out) :: dtk(pcols,pver) ! T tendency from KE dissipation topflx , &!real(r8), intent(out) :: topflx(pcols) ! Molecular heat flux at the top interface errstring , &!character(128), intent(out) :: errstring ! Output status tauresx , &!real(r8), intent(out) :: tautmsx(pcols) ! Implicit zonal turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ] tauresy , &!real(r8), intent(out) :: tautmsy(pcols) ! Implicit meridional turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ] 1 )!, &!integer, intent(in) :: itaures ! Indicator determining whether 'tauresx,tauresy' is updated (1) or non-updated (0) in this subroutine !do_molec_diff , &! !compute_molec_diff , &! !compute_molec_diff )!integer, external, optional :: compute_molec_diff ! Constituent-independent moleculuar diffusivity routine IF( errstring .NE. '' ) STOP 'call endrun( errstring )' END IF ! Store updated tauresx, tauresy in pbuf to use here on the next timestep !pbuf(tauresx_idx)%fld_ptr(1,1:ncol,1,lchnk,time_index) = tauresx(:ncol) !pbuf(tauresy_idx)%fld_ptr(1,1:ncol,1,lchnk,time_index) = tauresy(:ncol) !if( is_first_step() ) then ! do i = 1, pbuf_times ! pbuf(tauresx_idx)%fld_ptr(1,1:ncol,1,lchnk,i) = tauresx(:ncol) ! pbuf(tauresy_idx)%fld_ptr(1,1:ncol,1,lchnk,i) = tauresy(:ncol) ! end do !end if IF(MODAL_AERO)THEN ! Add the explicit surface fluxes to the lowest layer ! Modification : I should check whether this explicit adding is consistent with ! the treatment of other tracers. !tmp1(:ncol) = ztodt * gravit * state_rpdel(:ncol,pver) !do m = 1, ntot_amode ! l = numptr_amode(m) ! ptend_q(:ncol,pver,l) = ptend_q(:ncol,pver,l) + tmp1(:ncol) * cflx(:ncol,l) ! do lspec = 1, nspec_amode(m) ! l = lmassptr_amode(lspec,m) ! ptend_q(:ncol,pver,l) = ptend_q(:ncol,pver,l) + tmp1(:ncol) * cflx(:ncol,l) ! enddog !enddo END IF ! -------------------------------------------------------- ! ! Diagnostics and output writing after applying PBL scheme ! ! -------------------------------------------------------- ! DO k=1,pver DO i=1,ncol IF(ncnst > ixcldliq .and. ncnst > ixcldice)THEN sl(i,k) = ptend_s(i,k) - latvap * ptend_q(i,k,ixcldliq) & - ( latvap + latice) * ptend_q(i,k,ixcldice) qt(i,k) = ptend_q(i,k,1) + ptend_q(i,k,ixcldliq) & + ptend_q(i,k,ixcldice) ELSE sl(i,k) = ptend_s(i,k) qt(i,k) = ptend_q(i,k,1) END IF slv(i,k) = sl(i,k) * ( 1.0_r8 + zvir*qt(i,k) ) END DO END DO DO i=1,ncol slflx (i,1) = 0.0_r8 qtflx (i,1) = 0.0_r8 uflx (i,1) = 0.0_r8 vflx (i,1) = 0.0_r8 slflx_cg(i,1) = 0.0_r8 qtflx_cg(i,1) = 0.0_r8 uflx_cg (i,1) = 0.0_r8 vflx_cg (i,1) = 0.0_r8 END DO DO k = 2, pver DO i = 1, ncol rhoair = state_pint(i,k) / ( rair * ( ( 0.5*(slv(i,k)+slv(i,k-1)) - gravit*state_zi(i,k))/cpair ) ) slflx(i,k) = kvh(i,k) * & ( - rhoair*(sl(i,k-1)-sl(i,k))/(state_zm(i,k-1)-state_zm(i,k)) & + cgh(i,k) ) IF(ncnst > ixcldliq .and. ncnst > ixcldice)THEN qtflx(i,k) = kvh(i,k) * & ( - rhoair*(qt(i,k-1)-qt(i,k))/(state_zm(i,k-1)-state_zm(i,k)) & + rhoair*(cflx(i,1)+cflx(i,2)+cflx(i,3))*cgs(i,k) ) ELSE qtflx(i,k) = kvh(i,k) * & ( - rhoair*(qt(i,k-1)-qt(i,k))/(state_zm(i,k-1)-state_zm(i,k)) & + rhoair*(cflx(i,1))*cgs(i,k) ) END IF uflx(i,k) = kvm(i,k) * & ( - rhoair*(ptend_u(i,k-1)-ptend_u(i,k))/(state_zm(i,k-1)-state_zm(i,k))) vflx(i,k) = kvm(i,k) * & ( - rhoair*(ptend_v(i,k-1)-ptend_v(i,k))/(state_zm(i,k-1)-state_zm(i,k))) slflx_cg(i,k) = kvh(i,k) * cgh(i,k) IF(ncnst > ixcldliq .and. ncnst > ixcldice)THEN qtflx_cg(i,k) = kvh(i,k) * rhoair * ( cflx(i,1) + cflx(i,2) + cflx(i,3) ) * cgs(i,k) ELSE qtflx_cg(i,k) = kvh(i,k) * rhoair * ( cflx(i,1) ) * cgs(i,k) END IF uflx_cg(i,k) = 0._r8 vflx_cg(i,k) = 0._r8 END DO END DO ! Modification : I should check whether slflx(:ncol,pverp) is correctly computed. ! Note also that 'tautotx' is explicit total stress, different from ! the ones that have been actually added into the atmosphere. DO i=1,ncol slflx(i,pver+1) = shflx(i) qtflx(i,pver+1) = cflx(i,1) uflx (i,pver+1) = tautotx(i) vflx (i,pver+1) = tautoty(i) slflx_cg (i,pver+1) = 0._r8 qtflx_cg (i,pver+1) = 0._r8 uflx_cg (i,pver+1) = 0._r8 vflx_cg (i,pver+1) = 0._r8 END DO ! --------------------------------------------------------------- ! ! Convert the new profiles into vertical diffusion tendencies. ! ! Convert KE dissipative heat change into "temperature" tendency. ! ! --------------------------------------------------------------- ! !qm1 DO m=1,ncnst DO k=1,pver DO i=1,ncol ptend_q(i,k,m) = ( ptend_q(i,k,m) - qm1(i,k,m)) * rztodt END DO END DO END DO DO k = 1, pver DO i = 1, ncol ptend_s(i,k) = ( ptend_s(i,k) - state_s(i,k) ) * rztodt ptend_u(i,k) = ( ptend_u(i,k) - state_u(i,k) ) * rztodt ptend_v(i,k) = ( ptend_v(i,k) - state_v(i,k) ) * rztodt !ptend_q(i,k,1) = ( ptend_q(i,k,1) - state_qv(i,k) ) * rztodt !ptend_q(i,k,ixcldliq) = ( ptend_q(i,k,ixcldliq) - state_ql(i,k) ) * rztodt !ptend_q(i,k,ixcldice) = ( ptend_q(i,k,ixcldice) - state_qi(i,k) ) * rztodt slten(i,k) = ( sl(i,k) - sl_prePBL(i,k) ) * rztodt qtten(i,k) = ( qt(i,k) - qt_prePBL(i,k) ) * rztodt END DO END DO ! ----------------------------------------------------------- ! ! In order to perform 'pseudo-conservative varible diffusion' ! ! perform the following two stages: ! ! ! ! I. Re-set (1) 'qvten' by 'qtten', and 'qlten = qiten = 0' ! ! (2) 'sten' by 'slten', and ! ! (3) 'qlten = qiten = 0' ! ! ! ! II. Apply 'positive_moisture' ! ! ! ! ----------------------------------------------------------- ! IF( eddy_scheme .EQ. 'diag_TKE' .AND. do_pseudocon_diff ) THEN DO k = 1, pver DO i = 1, ncol ptend_q(i,k,1) = qtten(i,k) ptend_s(i,k) = slten(i,k) IF(ncnst > ixcldliq .and. ncnst > ixcldice)THEN ptend_q(i,k,ixcldliq) = 0._r8 ptend_q(i,k,ixcldice) = 0._r8 ptend_q(i,k,ixnumliq) = 0._r8 ptend_q(i,k,ixnumice) = 0._r8 END IF END DO END DO DO i = 1, ncol DO k = 1, pver qv_pro(i,k) = state_qv(i,k) + ptend_q(i,k,1) * ztodt IF(ncnst > ixcldliq )THEN ql_pro(i,k) = state_ql(i,k) + ptend_q(i,k,ixcldliq) * ztodt ELSE ql_pro(i,k) = state_ql(i,k) END IF IF(ncnst > ixcldice )THEN qi_pro(i,k) = state_qi(i,k) + ptend_q(i,k,ixcldice) * ztodt ELSE qi_pro(i,k) = state_qi(i,k) END IF s_pro(i,k) = state_s(i,k) + ptend_s(i,k) * ztodt t_pro(i,k) = state_t(i,k) + (1.0_r8/cpair)*ptend_s(i,k) * ztodt END DO END DO CALL positive_moisture( cpair, latvap, latvap+latice, ncol, pver, ztodt, qmin(1), qmin(2), qmin(3), & state_pdel(:ncol,pver:1:-1), qv_pro(:ncol,pver:1:-1), ql_pro(:ncol,pver:1:-1), & qi_pro(:ncol,pver:1:-1), t_pro(:ncol,pver:1:-1), s_pro(:ncol,pver:1:-1), & ptend_q(:ncol,pver:1:-1,1), ptend_q(:ncol,pver:1:-1,ixcldliq), & ptend_q(:ncol,pver:1:-1,ixcldice), ptend_s(:ncol,pver:1:-1) ) END IF ! ----------------------------------------------------------------- ! ! Re-calculate diagnostic output variables after vertical diffusion ! ! ----------------------------------------------------------------- ! DO k = 1, pver DO i = 1, ncol ! qv after PBL diffusion qv_aft_PBL(i,k) = state_qv(i,k) + ptend_q(i,k,1) * ztodt ! ql after PBL diffusion IF(ncnst > ixcldliq )THEN ql_aft_PBL(i,k) = state_ql(i,k) + ptend_q(i,k,ixcldliq) * ztodt ELSE ql_aft_PBL(i,k) = state_ql(i,k) END IF ! qi after PBL diffusion IF(ncnst > ixcldice )THEN qi_aft_PBL(i,k) = state_qi(i,k) + ptend_q(i,k,ixcldice) * ztodt ELSE qi_aft_PBL(i,k) = state_qi(i,k) END IF ! s after PBL diffusion s_aft_PBL (i,k) = state_s(i,k) + ptend_s(i,k) * ztodt ! Temperature after PBL diffusion t_aftPBL (i,k) = (s_aft_PBL(i,k) - gravit*state_zm(i,k) ) / cpair ! u after PBL diffusion u_aft_PBL (i,k) = state_u(i,k) + ptend_u(i,k) * ztodt up1(i,k)= u_aft_PBL (i,k) ! v after PBL diffusion v_aft_PBL (i,k) = state_v(i,k) + ptend_v(i,k) * ztodt vp1(i,k)= v_aft_PBL (i,k) END DO END DO CALL aqsat( t_aftPBL, state_pmid, tem2, ftem, pcols, ncol, pver, 1, pver ) DO k = 1, pver DO i = 1, ncol ! Saturation vapor pressure after PBL ftem_aftPBL(i,k) = qv_aft_PBL(i,k) / ftem(i,k) * 100._r8 ! Temperature tendency by PBL diffusion tten(i,k) = ( t_aftPBL(i,k) - state_t(i,k) ) * rztodt ! RH tendency by PBL diffusion rhten(i,k) = ( ftem_aftPBL(i,k) - ftem_prePBL(i,k) ) * rztodt END DO END DO !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- ! ! Convert the diffused fields back to diffusion tendencies. ! Add the diffusion tendencies to the cummulative physics tendencies, ! except for constituents. The diffused values of the constituents ! replace the input values. ! !rztodt = 1.0_r8/ztodt DO k=1,pver DO i=1,ncol duv(i,k) = ptend_u(i,k)*SIN( colrad(i)) ! (up1(i,k)*SIN( colrad(i)) - um1(i,k)*SIN( colrad(i)))*rztodt dvv(i,k) = ptend_v(i,k)*SIN( colrad(i)) !(vp1(i,k)*SIN( colrad(i)) - vm1(i,k)*SIN( colrad(i)))*rztodt dtv(i,k) = tten(i,k)*state_exner(i,k)!(thp(i,k) - thm(i,k))*rztodt END DO DO m=1,pcnst DO i=1,ncol dqv(i,k,m) = ptend_q(i,k,m) !(qp1(i,k,m) - qm1(i,k,m))*rztodt END DO END DO END DO is_first_step = .FALSE. RETURN END SUBROUTINE vertical_diffusion_tend ! =============================================================================== ! ! ! ! =============================================================================== ! SUBROUTINE positive_moisture( cp, xlv, xls, ncol, mkx, dt, qvmin, qlmin, qimin, & dp, qv, ql, qi, t, s, qvten, qlten, qiten, sten ) ! ------------------------------------------------------------------------------- ! ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, ! ! force them to be larger than minimum value by (1) condensating water vapor ! ! into liquid or ice, and (2) by transporting water vapor from the very lower ! ! layer. '2._r8' is multiplied to the minimum values for safety. ! ! Update final state variables and tendencies associated with this correction. ! ! If any condensation happens, update (s,t) too. ! ! Note that (qv,ql,qi,t,s) are final state variables after applying corresponding ! ! input tendencies. ! ! Be careful the order of k : '1': near-surface layer, 'mkx' : top layer ! ! ------------------------------------------------------------------------------- ! IMPLICIT NONE INTEGER, INTENT(in) :: ncol, mkx REAL(r8), INTENT(in) :: cp, xlv, xls REAL(r8), INTENT(in) :: dt, qvmin, qlmin, qimin REAL(r8), INTENT(in) :: dp(ncol,mkx) REAL(r8), INTENT(inout) :: qv(ncol,mkx), ql(ncol,mkx), qi(ncol,mkx), t(ncol,mkx), s(ncol,mkx) REAL(r8), INTENT(inout) :: qvten(ncol,mkx), qlten(ncol,mkx), qiten(ncol,mkx), sten(ncol,mkx) INTEGER i, k REAL(r8) dql, dqi, dqv, sum, aa, dum ! Modification : I should check whether this is exactly same as the one used in ! shallow convection and cloud macrophysics. DO i = 1, ncol DO k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface dql = MAX(0._r8,1._r8*qlmin-ql(i,k)) dqi = MAX(0._r8,1._r8*qimin-qi(i,k)) qlten(i,k) = qlten(i,k) + dql/dt qiten(i,k) = qiten(i,k) + dqi/dt qvten(i,k) = qvten(i,k) - (dql+dqi)/dt sten(i,k) = sten(i,k) + xlv * (dql/dt) + xls * (dqi/dt) ql(i,k) = ql(i,k) + dql qi(i,k) = qi(i,k) + dqi qv(i,k) = qv(i,k) - dql - dqi s(i,k) = s(i,k) + xlv * dql + xls * dqi t(i,k) = t(i,k) + (xlv * dql + xls * dqi)/cp dqv = MAX(0._r8,1._r8*qvmin-qv(i,k)) qvten(i,k) = qvten(i,k) + dqv/dt qv(i,k) = qv(i,k) + dqv IF( k .NE. 1 ) THEN qv(i,k-1) = qv(i,k-1) - dqv*dp(i,k)/dp(i,k-1) qvten(i,k-1) = qvten(i,k-1) - dqv*dp(i,k)/dp(i,k-1)/dt ENDIF qv(i,k) = MAX(qv(i,k),qvmin) ql(i,k) = MAX(ql(i,k),qlmin) qi(i,k) = MAX(qi(i,k),qimin) END DO ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally ! extracted from all the layers that has 'qv > 2*qvmin'. This fully ! preserves column moisture. IF( dqv .GT. 1.e-20_r8 ) THEN sum = 0._r8 DO k = 1, mkx IF( qv(i,k) .GT. 2._r8*qvmin ) sum = sum + qv(i,k)*dp(i,k) ENDDO aa = dqv*dp(i,1)/MAX(1.e-20_r8,sum) IF( aa .LT. 0.5_r8 ) THEN DO k = 1, mkx IF( qv(i,k) .GT. 2._r8*qvmin ) THEN dum = aa*qv(i,k) qv(i,k) = qv(i,k) - dum qvten(i,k) = qvten(i,k) - dum/dt ENDIF ENDDO ELSE WRITE(iulog,*) 'Full positive_moisture is impossible in vertical_diffusion' ENDIF ENDIF END DO RETURN END SUBROUTINE positive_moisture SUBROUTINE init_tms( kind, oro_in, karman_in, gravit_in, rair_in ) INTEGER, INTENT(in) :: kind REAL(r8), INTENT(in) :: oro_in, karman_in, gravit_in, rair_in IF( kind .NE. r8 ) THEN WRITE(iulog,*) 'KIND of reals passed to init_tms -- exiting.' STOP 'compute_tms' ENDIF oroconst = oro_in RETURN END SUBROUTINE init_tms !============================================================================ ! ! ! !============================================================================ ! SUBROUTINE init_eddy_diff( kind, pver, gravx, cpairx, rairx, zvirx, & latvapx, laticex, ntop_eddy, nbot_eddy, vkx ) !---------------------------------------------------------------- ! ! Purpose: ! ! Initialize time independent constants/variables of PBL package. ! !---------------------------------------------------------------- ! !use diffusion_solver, only: init_vdiff, vdiff_select !use cam_history, only: outfld, addfld, phys_decomp IMPLICIT NONE ! --------- ! ! Arguments ! ! --------- ! INTEGER, INTENT(in) :: kind ! Kind of reals being passed in INTEGER, INTENT(in) :: pver ! Number of vertical layers INTEGER, INTENT(in) :: ntop_eddy ! Top interface level to which eddy vertical diffusivity is applied ( = 1 ) INTEGER, INTENT(in) :: nbot_eddy ! Bottom interface level to which eddy vertical diffusivity is applied ( = pver ) REAL(r8), INTENT(in) :: gravx ! Acceleration of gravity REAL(r8), INTENT(in) :: cpairx ! Specific heat of dry air REAL(r8), INTENT(in) :: rairx ! Gas constant for dry air REAL(r8), INTENT(in) :: zvirx ! rh2o/rair - 1 REAL(r8), INTENT(in) :: latvapx ! Latent heat of vaporization REAL(r8), INTENT(in) :: laticex ! Latent heat of fusion REAL(r8), INTENT(in) :: vkx ! Von Karman's constant CHARACTER(128) :: errstring ! Error status for init_vdiff INTEGER :: k ! Vertical loop index IF( kind .NE. r8 ) THEN WRITE(iulog,*) 'wrong KIND of reals passed to init_diffusvity -- exiting.' STOP 'init_eddy_diff' ENDIF ! --------------- ! ! Basic constants ! ! --------------- ! ntop_turb = ntop_eddy nbot_turb = nbot_eddy b123 = b1**(2._r8/3._r8) ! Set the square of the mixing lengths. Only for CAM3 HB PBL scheme. ! Not used for UW moist PBL. Used for free air eddy diffusivity. ALLOCATE(ml2(pver+1));ml2=0.0_r8 ml2(1:ntop_turb) = 0._r8 DO k = ntop_turb + 1, nbot_turb ml2(k) = 30.0_r8**2 END DO ml2(nbot_turb+1:pver+1) = 0._r8 ! Initialize diffusion solver module CALL init_vdiff(r8, 1, rair, g, fieldlist_wet, fieldlist_dry, errstring) ! Select the fields which will be diffused IF(vdiff_select(fieldlist_wet,'s').NE.'') WRITE(iulog,*) 'error: ', vdiff_select(fieldlist_wet,'s') IF(vdiff_select(fieldlist_wet,'q',1).NE.'') WRITE(iulog,*) 'error: ', vdiff_select(fieldlist_wet,'q',1) IF(vdiff_select(fieldlist_wet,'u').NE.'') WRITE(iulog,*) 'error: ', vdiff_select(fieldlist_wet,'u') IF(vdiff_select(fieldlist_wet,'v').NE.'') WRITE(iulog,*) 'error: ', vdiff_select(fieldlist_wet,'v') ! ------------------------------------------------------------------- ! ! Writing outputs for detailed analysis of UW moist turbulence scheme ! ! ------------------------------------------------------------------- ! !call addfld('UW_errorPBL', 'm2/s', 1, 'A', 'Error function of UW PBL', phys_decomp ) !call addfld('UW_n2', 's-2', pver, 'A', 'Buoyancy Frequency, LI', phys_decomp ) !call addfld('UW_s2', 's-2', pver, 'A', 'Shear Frequency, LI', phys_decomp ) !call addfld('UW_ri', 'no', pver, 'A', 'Interface Richardson Number, I', phys_decomp ) !call addfld('UW_sfuh', 'no', pver, 'A', 'Upper-Half Saturation Fraction, L', phys_decomp ) !call addfld('UW_sflh', 'no', pver, 'A', 'Lower-Half Saturation Fraction, L', phys_decomp ) !call addfld('UW_sfi', 'no', pver+1, 'A', 'Interface Saturation Fraction, I', phys_decomp ) !call addfld('UW_cldn', 'no', pver, 'A', 'Cloud Fraction, L', phys_decomp ) !call addfld('UW_qrl', 'g*W/m2', pver, 'A', 'LW cooling rate, L', phys_decomp ) !call addfld('UW_ql', 'kg/kg', pver, 'A', 'ql(LWC), L', phys_decomp ) !call addfld('UW_chu', 'g*kg/J', pver+1, 'A', 'Buoyancy Coefficient, chu, I', phys_decomp ) !call addfld('UW_chs', 'g*kg/J', pver+1, 'A', 'Buoyancy Coefficient, chs, I', phys_decomp ) !call addfld('UW_cmu', 'g/kg/kg', pver+1, 'A', 'Buoyancy Coefficient, cmu, I', phys_decomp ) !call addfld('UW_cms', 'g/kg/kg', pver+1, 'A', 'Buoyancy Coefficient, cms, I', phys_decomp ) !call addfld('UW_tke', 'm2/s2', pver+1, 'A', 'TKE, I', phys_decomp ) !call addfld('UW_wcap', 'm2/s2', pver+1, 'A', 'Wcap, I', phys_decomp ) !call addfld('UW_bprod', 'm2/s3', pver+1, 'A', 'Buoyancy production, I', phys_decomp ) !call addfld('UW_sprod', 'm2/s3', pver+1, 'A', 'Shear production, I', phys_decomp ) !call addfld('UW_kvh', 'm2/s', pver+1, 'A', 'Eddy diffusivity of heat, I', phys_decomp ) !call addfld('UW_kvm', 'm2/s', pver+1, 'A', 'Eddy diffusivity of uv, I', phys_decomp ) !call addfld('UW_pblh', 'm', 1, 'A', 'PBLH, 1', phys_decomp ) !call addfld('UW_pblhp', 'Pa', 1, 'A', 'PBLH pressure, 1', phys_decomp ) !call addfld('UW_tpert', 'K', 1, 'A', 'Convective T excess, 1', phys_decomp ) !call addfld('UW_qpert', 'kg/kg', 1, 'A', 'Convective qt excess, I', phys_decomp ) !call addfld('UW_wpert', 'm/s', 1, 'A', 'Convective W excess, I', phys_decomp ) !call addfld('UW_ustar', 'm/s', 1, 'A', 'Surface Frictional Velocity, 1', phys_decomp ) !call addfld('UW_tkes', 'm2/s2', 1, 'A', 'Surface TKE, 1', phys_decomp ) !call addfld('UW_minpblh', 'm', 1, 'A', 'Minimum PBLH, 1', phys_decomp ) !call addfld('UW_turbtype', 'no', pver+1, 'A', 'Interface Turbulence Type, I', phys_decomp ) !call addfld('UW_kbase_o', 'no', ncvmax, 'A', 'Initial CL Base Exterbal Interface Index, CL', phys_decomp ) !call addfld('UW_ktop_o', 'no', ncvmax, 'A', 'Initial Top Exterbal Interface Index, CL', phys_decomp ) !call addfld('UW_ncvfin_o', '#', 1, 'A', 'Initial Total Number of CL regimes, CL', phys_decomp ) !call addfld('UW_kbase_mg', 'no', ncvmax, 'A', 'kbase after merging, CL', phys_decomp ) !call addfld('UW_ktop_mg', 'no', ncvmax, 'A', 'ktop after merging, CL', phys_decomp ) !call addfld('UW_ncvfin_mg', '#', 1, 'A', 'ncvfin after merging, CL', phys_decomp ) !call addfld('UW_kbase_f', 'no', ncvmax, 'A', 'Final kbase with SRCL, CL', phys_decomp ) !call addfld('UW_ktop_f', 'no', ncvmax, 'A', 'Final ktop with SRCL, CL', phys_decomp ) !call addfld('UW_ncvfin_f', '#', 1, 'A', 'Final ncvfin with SRCL, CL', phys_decomp ) !call addfld('UW_wet', 'm/s', ncvmax, 'A', 'Entrainment rate at CL top, CL', phys_decomp ) !call addfld('UW_web', 'm/s', ncvmax, 'A', 'Entrainment rate at CL base, CL', phys_decomp ) !call addfld('UW_jtbu', 'm/s2', ncvmax, 'A', 'Buoyancy jump across CL top, CL', phys_decomp ) !call addfld('UW_jbbu', 'm/s2', ncvmax, 'A', 'Buoyancy jump across CL base, CL', phys_decomp ) !call addfld('UW_evhc', 'no', ncvmax, 'A', 'Evaporative enhancement factor, CL', phys_decomp ) !call addfld('UW_jt2slv', 'J/kg', ncvmax, 'A', 'slv jump for evhc, CL', phys_decomp ) !call addfld('UW_n2ht', 's-2', ncvmax, 'A', 'n2 at just below CL top interface, CL', phys_decomp ) !call addfld('UW_n2hb', 's-2', ncvmax, 'A', 'n2 at just above CL base interface', phys_decomp ) !call addfld('UW_lwp', 'kg/m2', ncvmax, 'A', 'LWP in the CL top layer, CL', phys_decomp ) !call addfld('UW_optdepth', 'no', ncvmax, 'A', 'Optical depth of the CL top layer, CL', phys_decomp ) !call addfld('UW_radfrac', 'no', ncvmax, 'A', 'Fraction of radiative cooling confined in the CL top', phys_decomp ) !call addfld('UW_radf', 'm2/s3', ncvmax, 'A', 'Buoyancy production at the CL top by radf, I', phys_decomp ) !call addfld('UW_wstar', 'm/s', ncvmax, 'A', 'Convective velocity, Wstar, CL', phys_decomp ) !call addfld('UW_wstar3fact', 'no', ncvmax, 'A', 'Enhancement of wstar3 due to entrainment, CL', phys_decomp ) !call addfld('UW_ebrk', 'm2/s2', ncvmax, 'A', 'CL-averaged TKE, CL', phys_decomp ) !call addfld('UW_wbrk', 'm2/s2', ncvmax, 'A', 'CL-averaged W, CL', phys_decomp ) !call addfld('UW_lbrk', 'm', ncvmax, 'A', 'CL internal thickness, CL', phys_decomp ) !call addfld('UW_ricl', 'no', ncvmax, 'A', 'CL-averaged Ri, CL', phys_decomp ) !call addfld('UW_ghcl', 'no', ncvmax, 'A', 'CL-averaged gh, CL', phys_decomp ) !call addfld('UW_shcl', 'no', ncvmax, 'A', 'CL-averaged sh, CL', phys_decomp ) !call addfld('UW_smcl', 'no', ncvmax, 'A', 'CL-averaged sm, CL', phys_decomp ) !call addfld('UW_gh', 'no', pver+1, 'A', 'gh at all interfaces, I', phys_decomp ) !call addfld('UW_sh', 'no', pver+1, 'A', 'sh at all interfaces, I', phys_decomp ) !call addfld('UW_sm', 'no', pver+1, 'A', 'sm at all interfaces, I', phys_decomp ) !call addfld('UW_ria', 'no', pver+1, 'A', 'ri at all interfaces, I', phys_decomp ) !call addfld('UW_leng', 'm/s', pver+1, 'A', 'Turbulence length scale, I', phys_decomp ) RETURN END SUBROUTINE init_eddy_diff ! =============================================================================== ! ! ! ! =============================================================================== ! SUBROUTINE init_vdiff( kind, ncnst, rair_in, gravit_in, fieldlist_wet, fieldlist_dry, errstring ) INTEGER, INTENT(in) :: kind ! Kind used for reals INTEGER, INTENT(in) :: ncnst ! Number of constituents REAL(r8), INTENT(in) :: rair_in ! Input gas constant for dry air REAL(r8), INTENT(in) :: gravit_in ! Input gravititational acceleration TYPE(vdiff_selector), INTENT(out) :: fieldlist_wet ! List of fields to be diffused using moist mixing ratio TYPE(vdiff_selector), INTENT(out) :: fieldlist_dry ! List of fields to be diffused using dry mixing ratio CHARACTER(128), INTENT(out) :: errstring ! Output status errstring = '' IF( kind .NE. r8 ) THEN WRITE(iulog,*) 'KIND of reals passed to init_vdiff -- exiting.' errstring = 'init_vdiff' RETURN ENDIF !rair = rair_in !gravit = gravit_in ALLOCATE( fieldlist_wet%fields( 3 + ncnst ) ) fieldlist_wet%fields(:) = .FALSE. ALLOCATE( fieldlist_dry%fields( 3 + ncnst ) ) fieldlist_dry%fields(:) = .FALSE. END SUBROUTINE init_vdiff ! =============================================================================== ! !=============================================================================== ! ! ! !=============================================================================== ! SUBROUTINE compute_eddy_diff( lchnk , &!integer, intent(in) :: lchnk pcols , &!integer, intent(in) :: pcols ! Number of atmospheric columns [ # ] pver , &!integer, intent(in) :: pver ! Number of atmospheric layers [ # ] ncol , &!integer, intent(in) :: ncol ! Number of atmospheric columns [ # ] t , &!real(r8), intent(in) :: t(pcols,pver) ! Temperature [K] qv , &!real(r8), intent(in) :: qv(pcols,pver) ! Water vapor specific humidity [ kg/kg ] ztodt , &!real(r8), intent(in) :: ztodt ! Physics integration time step 2 delta-t [ s ] ql , &!real(r8), intent(in) :: ql(pcols,pver) ! Liquid water specific humidity [ kg/kg ] qi , &!real(r8), intent(in) :: qi(pcols,pver) ! Ice specific humidity [ kg/kg ] rpdel , &!real(r8), intent(in) :: rpdel(pcols,pver) ! 1./pdel where 'pdel' is thickness of the layer [ Pa ] cldn , &!real(r8), intent(in) :: cldn(pcols,pver) ! Stratiform cloud fraction [ fraction ] qrl , &!real(r8), intent(in) :: qrl(pcols,pver) ! LW cooling rate wsedl , &!real(r8), intent(in) :: wsedl(pcols,pver) ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] z , &!real(r8), intent(in) :: z(pcols,pver) ! Layer mid-point height above surface [ m ] zi , &!real(r8), intent(in) :: zi(pcols,pver+1) ! Interface height above surface [ m ] pmid , &!real(r8), intent(in) :: pmid(pcols,pver) ! Layer mid-point pressure [ Pa ] pi , &!real(r8), intent(in) :: pi(pcols,pver+1) ! Interface pressure [ Pa ] u , &!real(r8), intent(in) :: u(pcols,pver) ! Zonal velocity [ m/s ] v , &!real(r8), intent(in) :: v(pcols,pver) ! Meridional velocity [ m/s ] taux , &!real(r8), intent(in) :: taux(pcols) ! Zonal wind stress at surface [ N/m2 ] tauy , &!real(r8), intent(in) :: tauy(pcols) ! Meridional wind stress at surface [ N/m2 ] shflx , &!real(r8), intent(in) :: shflx(pcols) ! Sensible heat flux at surface [ unit ? ] qflx , &!real(r8), intent(in) :: qflx(pcols) ! Water vapor flux at surface [ unit ? ] wstarent , &!logical, intent(in) :: wstarent ! .true. means use the 'wstar' entrainment closure. nturb , &!integer, intent(in) :: nturb ! Number of iteration steps for calculating eddy diffusivity [ # ] ustar , &!real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] pblh , &!real(r8), intent(out) :: pblh(pcols) ! PBL top height [ m ] landfrac ,& kvm_in , &!real(r8), intent(in) :: kvm_in(pcols,pver+1) ! kvm saved from last timestep [ m2/s ] kvh_in , &!real(r8), intent(in) :: kvh_in(pcols,pver+1) ! kvh saved from last timestep [ m2/s ] kvm_out , &!real(r8), intent(out) :: kvm_out(pcols,pver+1) ! Eddy diffusivity for momentum [ m2/s ] kvh_out , &!real(r8), intent(out) :: kvh_out(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] kvq , &!real(r8), intent(out) :: kvq(pcols,pver+1) ! Eddy diffusivity for constituents, moisture and tracers [ m2/s ] (note not having '_out') cgh , &!real(r8), intent(out) :: cgh(pcols,pver+1) ! Counter-gradient term for heat [ J/kg/m ] cgs , &!real(r8), intent(out) :: cgs(pcols,pver+1) ! Counter-gradient star [ cg/flux ] tpert , &!real(r8), intent(out) :: tpert(pcols) ! Convective temperature excess [ K ] qpert , &!real(r8), intent(out) :: qpert(pcols) ! Convective humidity excess [ kg/kg ] wpert , &!real(r8), intent(out) :: wpert(pcols) ! Turbulent velocity excess [ m/s ] tke , &!real(r8), intent(out) :: tke(pcols,pver+1) ! Turbulent kinetic energy [ m2/s2 ] bprod , &!real(r8), intent(out) :: bprod(pcols,pver+1) ! Buoyancy production [ m2/s3 ] sprod , &!real(r8), intent(out) :: sprod(pcols,pver+1) ! Shear production [ m2/s3 ] sfi , &!real(r8), intent(out) :: sfi(pcols,pver+1) ! Interfacial layer saturation fraction [ fraction ] kvinit , &!logical, intent(in ) :: kvinit ! Tell compute_eddy_diff/ caleddy to initialize kvh, kvm (uses kvf) tauresx , &!real(r8), intent(inout) :: tauresx(pcols) ! Residual stress to be added in vdiff to correct for turb tauresy , &!real(r8), intent(inout) :: tauresy(pcols) ! Stress mismatch between sfc and atm accumulated in prior timesteps ksrftms , &!real(r8), intent(in) :: ksrftms(pcols) ! Surface drag coefficient of turbulent mountain stress [ unit ? ] ipbl , &!real(r8), intent(out) :: ipbl(pcols) ! If 1, PBL is CL, while if 0, PBL is STL. kpblh , &!real(r8), intent(out) :: kpblh(pcols) ! Layer index containing PBL top within or at the base interface wstarPBL , &!real(r8), intent(out) :: wstarPBL(pcols) ! Convective velocity within PBL [ m/s ] turbtype , &!real(r8), intent(out) :: turbtype(pcols,pver+1) ! Turbulence type identifier at all interfaces [ no unit ] sm_aw , &!real(r8), intent(out) :: sm_aw(pcols,pver+1) ! Normalized Galperin instability function for momentum [ no unit ] ri )!REAL(r8), INTENT(out) :: ri(pcols,pver) ! Richardson number, 'n2/s2', defined at interfaces except surface [ s-2 ] !-------------------------------------------------------------------- ! ! Purpose: Interface to compute eddy diffusivities. ! ! Eddy diffusivities are calculated in a fully implicit way ! ! through iteration process. ! ! Author: Sungsu Park. August. 2006. ! ! May. 2008. ! !-------------------------------------------------------------------- ! ! use diffusion_solver, only: compute_vdiff ! use cam_history, only: outfld, addfld, phys_decomp ! use physics_types, only: physics_state ! use phys_debug_util, only: phys_debug_col ! use time_manager, only: is_first_step, get_nstep IMPLICIT NONE ! type(physics_state) :: state ! Physics state variables ! --------------- ! ! Input Variables ! ! --------------- ! INTEGER, INTENT(in) :: lchnk INTEGER, INTENT(in) :: pcols ! Number of atmospheric columns [ # ] INTEGER, INTENT(in) :: pver ! Number of atmospheric layers [ # ] INTEGER, INTENT(in) :: ncol ! Number of atmospheric columns [ # ] INTEGER, INTENT(in) :: nturb ! Number of iteration steps for calculating eddy diffusivity [ # ] LOGICAL, INTENT(in) :: wstarent ! .true. means use the 'wstar' entrainment closure. LOGICAL, INTENT(in) :: kvinit ! 'true' means time step = 1 : used for initializing kvh, kvm (uses kvf or zero) REAL(r8), INTENT(in) :: ztodt ! Physics integration time step 2 delta-t [ s ] REAL(r8), INTENT(in) :: t(pcols,pver) ! Temperature [K] REAL(r8), INTENT(in) :: qv(pcols,pver) ! Water vapor specific humidity [ kg/kg ] REAL(r8), INTENT(in) :: ql(pcols,pver) ! Liquid water specific humidity [ kg/kg ] REAL(r8), INTENT(in) :: qi(pcols,pver) ! Ice specific humidity [ kg/kg ] ! real(r8), intent(in) :: s(pcols,pver) ! Dry static energy [ J/kg ] REAL(r8), INTENT(in) :: rpdel(pcols,pver) ! 1./pdel where 'pdel' is thickness of the layer [ Pa ] REAL(r8), INTENT(in) :: cldn(pcols,pver) ! Stratiform cloud fraction [ fraction ] REAL(r8), INTENT(in) :: qrl(pcols,pver) ! LW cooling rate REAL(r8), INTENT(in) :: wsedl(pcols,pver) ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] REAL(r8), INTENT(in) :: z(pcols,pver) ! Layer mid-point height above surface [ m ] REAL(r8), INTENT(in) :: zi(pcols,pver+1) ! Interface height above surface [ m ] REAL(r8), INTENT(in) :: pmid(pcols,pver) ! Layer mid-point pressure [ Pa ] REAL(r8), INTENT(in) :: pi(pcols,pver+1) ! Interface pressure [ Pa ] REAL(r8), INTENT(in) :: u(pcols,pver) ! Zonal velocity [ m/s ] REAL(r8), INTENT(in) :: v(pcols,pver) ! Meridional velocity [ m/s ] REAL(r8), INTENT(in) :: taux(pcols) ! Zonal wind stress at surface [ N/m2 ] REAL(r8), INTENT(in) :: tauy(pcols) ! Meridional wind stress at surface [ N/m2 ] REAL(r8), INTENT(in) :: shflx(pcols) ! Sensible heat flux at surface [ unit ? ] REAL(r8), INTENT(in) :: qflx(pcols) ! Water vapor flux at surface [ unit ? ] REAL(r8), INTENT(in) :: kvm_in(pcols,pver+1) ! kvm saved from last timestep [ m2/s ] REAL(r8), INTENT(in) :: kvh_in(pcols,pver+1) ! kvh saved from last timestep [ m2/s ] REAL(r8), INTENT(in) :: ksrftms(pcols) ! Surface drag coefficient of turbulent mountain stress [ unit ? ] REAL(r8), INTENT(in) :: landfrac(pcols) ! S ! ---------------- ! ! Output Variables ! ! ---------------- ! REAL(r8), INTENT(out) :: kvm_out(pcols,pver+1) ! Eddy diffusivity for momentum [ m2/s ] REAL(r8), INTENT(out) :: kvh_out(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] REAL(r8), INTENT(out) :: kvq(pcols,pver+1) ! Eddy diffusivity for constituents, moisture and tracers [ m2/s ] (note not having '_out') REAL(r8), INTENT(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] REAL(r8), INTENT(out) :: pblh(pcols) ! PBL top height [ m ] REAL(r8), INTENT(out) :: cgh(pcols,pver+1) ! Counter-gradient term for heat [ J/kg/m ] REAL(r8), INTENT(out) :: cgs(pcols,pver+1) ! Counter-gradient star [ cg/flux ] REAL(r8), INTENT(out) :: tpert(pcols) ! Convective temperature excess [ K ] REAL(r8), INTENT(out) :: qpert(pcols) ! Convective humidity excess [ kg/kg ] REAL(r8), INTENT(out) :: wpert(pcols) ! Turbulent velocity excess [ m/s ] REAL(r8), INTENT(out) :: tke(pcols,pver+1) ! Turbulent kinetic energy [ m2/s2 ] REAL(r8), INTENT(out) :: bprod(pcols,pver+1) ! Buoyancy production [ m2/s3 ] REAL(r8), INTENT(out) :: sprod(pcols,pver+1) ! Shear production [ m2/s3 ] REAL(r8), INTENT(out) :: sfi(pcols,pver+1) ! Interfacial layer saturation fraction [ fraction ] REAL(r8), INTENT(out) :: turbtype(pcols,pver+1) ! Turbulence type identifier at all interfaces [ no unit ] REAL(r8), INTENT(out) :: sm_aw(pcols,pver+1) ! Normalized Galperin instability function for momentum [ no unit ] ! This is 1 when neutral condition (Ri=0), 4.964 for maximum unstable case, and 0 when Ri > Ricrit=0.19. REAL(r8), INTENT(out) :: ipbl(pcols) ! If 1, PBL is CL, while if 0, PBL is STL. REAL(r8), INTENT(out) :: kpblh(pcols) ! Layer index containing PBL top within or at the base interface REAL(r8), INTENT(out) :: wstarPBL(pcols) ! Convective velocity within PBL [ m/s ] REAL(r8), INTENT(out) :: ri(pcols,pver) ! Richardson number, 'n2/s2', defined at interfaces except surface [ s-2 ] ! ---------------------- ! ! Input-Output Variables ! ! ---------------------- ! REAL(r8), INTENT(inout) :: tauresx(pcols) ! Residual stress to be added in vdiff to correct for turb REAL(r8), INTENT(inout) :: tauresy(pcols) ! Stress mismatch between sfc and atm accumulated in prior timesteps ! --------------- ! ! Local Variables ! ! --------------- ! INTEGER icol INTEGER i, k, iturb, status,m !integer, external :: qsat CHARACTER(128) :: errstring ! Error status for compute_vdiff REAL(r8) :: tautotx(pcols) ! Total stress including tms REAL(r8) :: tautoty(pcols) ! Total stress including tms REAL(r8) :: kvf(pcols,pver+1) ! Free atmospheric eddy diffusivity [ m2/s ] REAL(r8) :: kvm(pcols,pver+1) ! Eddy diffusivity for momentum [ m2/s ] REAL(r8) :: kvh(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] REAL(r8) :: kvm_preo(pcols,pver+1) ! Eddy diffusivity for momentum [ m2/s ] REAL(r8) :: kvh_preo(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] REAL(r8) :: kvm_pre(pcols,pver+1) ! Eddy diffusivity for momentum [ m2/s ] REAL(r8) :: kvh_pre(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] REAL(r8) :: errorPBL(pcols) ! Error function showing whether PBL produced convergent solution or not. [ unit ? ] REAL(r8) :: s2(pcols,pver) ! Shear squared, defined at interfaces except surface [ s-2 ] REAL(r8) :: n2(pcols,pver) ! Buoyancy frequency, defined at interfaces except surface [ s-2 ] REAL(r8) :: pblhp(pcols) ! PBL top pressure [ Pa ] REAL(r8) :: minpblh(pcols) ! Minimum PBL height based on surface stress REAL(r8) :: qt(pcols,pver) ! Total specific humidity [ kg/kg ] REAL(r8) :: sfuh(pcols,pver) ! Saturation fraction in upper half-layer [ fraction ] REAL(r8) :: sflh(pcols,pver) ! Saturation fraction in lower half-layer [ fraction ] REAL(r8) :: sl(pcols,pver) ! Liquid water static energy [ J/kg ] REAL(r8) :: slv(pcols,pver) ! Liquid water virtual static energy [ J/kg ] REAL(r8) :: slslope(pcols,pver) ! Slope of 'sl' in each layer REAL(r8) :: qtslope(pcols,pver) ! Slope of 'qt' in each layer REAL(r8) :: rrho(pcols) ! Density at the lowest layer REAL(r8) :: qvfd(pcols,pver) ! Specific humidity for diffusion [ kg/kg ] REAL(r8) :: tfd(pcols,pver) ! Temperature for diffusion [ K ] REAL(r8) :: slfd(pcols,pver) ! Liquid static energy [ J/kg ] REAL(r8) :: qtfd(pcols,pver) ! Total specific humidity [ kg/kg ] REAL(r8) :: qlfd(pcols,pver) ! Liquid water specific humidity for diffusion [ kg/kg ] REAL(r8) :: ufd(pcols,pver) ! U-wind for diffusion [ m/s ] REAL(r8) :: vfd(pcols,pver) ! V-wind for diffusion [ m/s ] ! Buoyancy coefficients : w'b' = ch * w'sl' + cm * w'qt' REAL(r8) :: chu(pcols,pver+1) ! Heat buoyancy coef for dry states, defined at each interface, finally. REAL(r8) :: chs(pcols,pver+1) ! Heat buoyancy coef for sat states, defined at each interface, finally. REAL(r8) :: cmu(pcols,pver+1) ! Moisture buoyancy coef for dry states, defined at each interface, finally. REAL(r8) :: cms(pcols,pver+1) ! Moisture buoyancy coef for sat states, defined at each interface, finally. REAL(r8) :: jnk1d(pcols) REAL(r8) :: jnk2d(pcols,pver+1) REAL(r8) :: zero(pcols) REAL(r8) :: zero2d(pcols,pver+1) REAL(r8) :: es(1) ! Saturation vapor pressure REAL(r8) :: qs(1) ! Saturation specific humidity REAL(r8) :: gam(1) ! (L/cp)*dqs/dT REAL(r8) :: ep2, templ(1), temps(1) ! ------------------------------- ! ! Variables for diagnostic output ! ! ------------------------------- ! REAL(r8) :: tkes(pcols) ! TKE at surface interface [ m2/s2 ] REAL(r8) :: kbase_o(pcols,ncvmax) ! Original external base interface index of CL from 'exacol' REAL(r8) :: ktop_o(pcols,ncvmax) ! Original external top interface index of CL from 'exacol' REAL(r8) :: ncvfin_o(pcols) ! Original number of CLs from 'exacol' REAL(r8) :: kbase_mg(pcols,ncvmax) ! 'kbase' after extending-merging from 'zisocl' REAL(r8) :: ktop_mg(pcols,ncvmax) ! 'ktop' after extending-merging from 'zisocl' REAL(r8) :: ncvfin_mg(pcols) ! 'ncvfin' after extending-merging from 'zisocl' REAL(r8) :: kbase_f(pcols,ncvmax) ! Final 'kbase' after extending-merging & including SRCL REAL(r8) :: ktop_f(pcols,ncvmax) ! Final 'ktop' after extending-merging & including SRCL REAL(r8) :: ncvfin_f(pcols) ! Final 'ncvfin' after extending-merging & including SRCL REAL(r8) :: wet(pcols,ncvmax) ! Entrainment rate at the CL top [ m/s ] REAL(r8) :: web(pcols,ncvmax) ! Entrainment rate at the CL base [ m/s ]. Set to zero if CL is based at surface. REAL(r8) :: jtbu(pcols,ncvmax) ! Buoyancy jump across the CL top [ m/s2 ] REAL(r8) :: jbbu(pcols,ncvmax) ! Buoyancy jump across the CL base [ m/s2 ] REAL(r8) :: evhc(pcols,ncvmax) ! Evaporative enhancement factor at the CL top REAL(r8) :: jt2slv(pcols,ncvmax) ! Jump of slv ( across two layers ) at CL top used only for evhc [ J/kg ] REAL(r8) :: n2ht(pcols,ncvmax) ! n2 defined at the CL top interface but using sfuh(kt) instead of sfi(kt) [ s-2 ] REAL(r8) :: n2hb(pcols,ncvmax) ! n2 defined at the CL base interface but using sflh(kb-1) instead of sfi(kb) [ s-2 ] REAL(r8) :: lwp(pcols,ncvmax) ! LWP in the CL top layer [ kg/m2 ] REAL(r8) :: opt_depth(pcols,ncvmax) ! Optical depth of the CL top layer REAL(r8) :: radinvfrac(pcols,ncvmax) ! Fraction of radiative cooling confined in the top portion of CL top layer REAL(r8) :: radf(pcols,ncvmax) ! Buoyancy production at the CL top due to LW radiative cooling [ m2/s3 ] REAL(r8) :: wstar(pcols,ncvmax) ! Convective velocity in each CL [ m/s ] REAL(r8) :: wstar3fact(pcols,ncvmax) ! Enhancement of 'wstar3' due to entrainment (inverse) [ no unit ] REAL(r8) :: ebrk(pcols,ncvmax) ! Net mean TKE of CL including entrainment effect [ m2/s2 ] REAL(r8) :: wbrk(pcols,ncvmax) ! Net mean normalized TKE (W) of CL, 'ebrk/b1' including entrainment effect [ m2/s2 ] REAL(r8) :: lbrk(pcols,ncvmax) ! Energetic internal thickness of CL [m] REAL(r8) :: ricl(pcols,ncvmax) ! CL internal mean Richardson number REAL(r8) :: ghcl(pcols,ncvmax) ! Half of normalized buoyancy production of CL REAL(r8) :: shcl(pcols,ncvmax) ! Galperin instability function of heat-moisture of CL REAL(r8) :: smcl(pcols,ncvmax) ! Galperin instability function of mementum of CL REAL(r8) :: ghi(pcols,pver+1) ! Half of normalized buoyancy production at all interfaces REAL(r8) :: shi(pcols,pver+1) ! Galperin instability function of heat-moisture at all interfaces REAL(r8) :: smi(pcols,pver+1) ! Galperin instability function of heat-moisture at all interfaces REAL(r8) :: rii(pcols,pver+1) ! Interfacial Richardson number defined at all interfaces REAL(r8) :: lengi(pcols,pver+1) ! Turbulence length scale at all interfaces [ m ] REAL(r8) :: wcap(pcols,pver+1) ! Normalized TKE at all interfaces [ m2/s2 ] ! ---------- ! ! Initialize ! ! ---------- ! DO k=1,pver+1 DO i=1,pcols kvm_out (i,k)= 0.0_r8! Eddy diffusivity for momentum [ m2/s ] kvh_out (i,k)= 0.0_r8! Eddy diffusivity for heat [ m2/s ] kvq (i,k)= 0.0_r8! Eddy diffusivity for constituents, moisture and tracers [ m2/s ] (note not having '_out') cgh (i,k)= 0.0_r8! Counter-gradient term for heat [ J/kg/m ] cgs (i,k)= 0.0_r8! Counter-gradient star [ cg/flux ] tke (i,k)= 0.0_r8! Turbulent kinetic energy [ m2/s2 ] bprod (i,k)= 0.0_r8! Buoyancy production [ m2/s3 ] sprod (i,k)= 0.0_r8! Shear production [ m2/s3 ] sfi (i,k)= 0.0_r8! Interfacial layer saturation fraction [ fraction ] turbtype(i,k)= 0.0_r8! Turbulence type identifier at all interfaces [ no unit ] sm_aw (i,k)= 0.0_r8! Normalized Galperin instability function for momentum [ no unit ] kvf(i,k) =0.0_r8 ! Free atmospheric eddy diffusivity [ m2/s ] kvm(i,k) =0.0_r8 ! Eddy diffusivity for momentum [ m2/s ] kvh(i,k) =0.0_r8 ! Eddy diffusivity for heat [ m2/s ] kvm_preo(i,k) =0.0_r8 ! Eddy diffusivity for momentum [ m2/s ] kvh_preo(i,k) =0.0_r8 ! Eddy diffusivity for heat [ m2/s ] kvm_pre(i,k) =0.0_r8 ! Eddy diffusivity for momentum [ m2/s ] kvh_pre(i,k) =0.0_r8 ! Eddy diffusivity for heat [ m2/s ] chu(i,k) =0.0_r8 ! Heat buoyancy coef for dry states, defined at each interface, finally. chs(i,k) =0.0_r8 ! Heat buoyancy coef for sat states, defined at each interface, finally. cmu(i,k) =0.0_r8 ! Moisture buoyancy coef for dry states, defined at each interface, finally. cms(i,k) =0.0_r8 ! Moisture buoyancy coef for sat states, defined at each interface, finally. jnk2d(i,k) =0.0_r8 zero2d(i,k) =0.0_r8 ghi(i,k) =0.0_r8 ! Half of normalized buoyancy production at all interfaces shi(i,k) =0.0_r8 ! Galperin instability function of heat-moisture at all interfaces smi(i,k) =0.0_r8 ! Galperin instability function of heat-moisture at all interfaces rii(i,k) =0.0_r8 ! Interfacial Richardson number defined at all interfaces lengi(i,k) =0.0_r8 ! Turbulence length scale at all interfaces [ m ] wcap(i,k) =0.0_r8 ! Normalized TKE at all interfaces [ m2/s2 ] END DO END DO DO k=1,pver DO i=1,pcols qt(i,k) =0.0_r8 ! Total specific humidity [ kg/kg ] sfuh(i,k) =0.0_r8 ! Saturation fraction in upper half-layer [ fraction ] sflh(i,k) =0.0_r8 ! Saturation fraction in lower half-layer [ fraction ] sl(i,k) =0.0_r8 ! Liquid water static energy [ J/kg ] slv(i,k) =0.0_r8 ! Liquid water virtual static energy [ J/kg ] slslope(i,k) =0.0_r8 ! Slope of 'sl' in each layer qtslope(i,k) =0.0_r8 ! Slope of 'qt' in each layer qvfd(i,k) =0.0_r8 ! Specific humidity for diffusion [ kg/kg ] tfd(i,k) =0.0_r8 ! Temperature for diffusion [ K ] slfd(i,k) =0.0_r8 ! Liquid static energy [ J/kg ] qtfd(i,k) =0.0_r8 ! Total specific humidity [ kg/kg ] qlfd(i,k) =0.0_r8 ! Liquid water specific humidity for diffusion [ kg/kg ] ufd(i,k) =0.0_r8 ! U-wind for diffusion [ m/s ] vfd(i,k) =0.0_r8 ! V-wind for diffusion [ m/s ] s2(i,k) =0.0_r8 ! Shear squared, defined at interfaces except surface [ s-2 ] n2(i,k) =0.0_r8 ! Buoyancy frequency, defined at interfaces except surface [ s-2 ] ri(i,k)= 0.0_r8! Richardson number, 'n2/s2', defined at interfaces except surface [ s-2 ] END DO END DO DO i=1,pcols ustar (i)= 0.0_r8! Surface friction velocity [ m/s ] pblh (i)= 0.0_r8! PBL top height [ m ] tpert (i)= 0.0_r8! Convective temperature excess [ K ] qpert (i)= 0.0_r8! Convective humidity excess [ kg/kg ] wpert (i)= 0.0_r8! Turbulent velocity excess [ m/s ] ! This is 1 when neutral condition (Ri=0), 4.964 for maximum unstable case, and 0 when Ri > Ricrit=0.19. ipbl (i)= 0.0_r8! If 1, PBL is CL, while if 0, PBL is STL. kpblh (i)= 0.0_r8! Layer index containing PBL top within or at the base interface wstarPBL (i)= 0.0_r8! Convective velocity within PBL [ m/s ] rrho (i)= 0.0_r8! Density at the lowest layer tautotx (i)= 0.0_r8! Total stress including tms tautoty (i)= 0.0_r8! Total stress including tms errorPBL (i)= 0.0_r8! Error function showing whether PBL produced convergent solution or not. [ unit ? ] pblhp (i)= 0.0_r8! PBL top pressure [ Pa ] minpblh (i)= 0.0_r8! Minimum PBL height based on surface stress jnk1d (i)= 0.0_r8 zero (i)= 0.0_r8 tkes (i)= 0.0_r8! TKE at surface interface [ m2/s2 ] ncvfin_o (i)= 0.0_r8! Original number of CLs from 'exacol' ncvfin_mg(i)= 0.0_r8! 'ncvfin' after extending-merging from 'zisocl' ncvfin_f(i)= 0.0_r8! Final 'ncvfin' after extending-merging & including SRCL END DO DO m=1,ncvmax DO i=1,pcols kbase_o(i,m) = 0.0_r8 ! Original external base interface index of CL from 'exacol' ktop_o(i,m) = 0.0_r8 ! Original external top interface index of CL from 'exacol' kbase_mg(i,m) = 0.0_r8 ! 'kbase' after extending-merging from 'zisocl' ktop_mg(i,m) = 0.0_r8 ! 'ktop' after extending-merging from 'zisocl' kbase_f(i,m) = 0.0_r8 ! Final 'kbase' after extending-merging & including SRCL ktop_f(i,m) = 0.0_r8 ! Final 'ktop' after extending-merging & including SRCL wet(i,m) = 0.0_r8 ! Entrainment rate at the CL top [ m/s ] web(i,m) = 0.0_r8 ! Entrainment rate at the CL base [ m/s ]. Set to zero if CL is based at surface. jtbu(i,m) = 0.0_r8 ! Buoyancy jump across the CL top [ m/s2 ] jbbu(i,m) = 0.0_r8 ! Buoyancy jump across the CL base [ m/s2 ] evhc(i,m) = 0.0_r8 ! Evaporative enhancement factor at the CL top jt2slv(i,m) = 0.0_r8 ! Jump of slv ( across two layers ) at CL top used only for evhc [ J/kg ] n2ht(i,m) = 0.0_r8 ! n2 defined at the CL top interface but using sfuh(kt) instead of sfi(kt) [ s-2 ] n2hb(i,m) = 0.0_r8 ! n2 defined at the CL base interface but using sflh(kb-1) instead of sfi(kb) [ s-2 ] lwp(i,m) = 0.0_r8 ! LWP in the CL top layer [ kg/m2 ] opt_depth(i,m) = 0.0_r8 ! Optical depth of the CL top layer radinvfrac(i,m) = 0.0_r8 ! Fraction of radiative cooling confined in the top portion of CL top layer radf(i,m) = 0.0_r8 ! Buoyancy production at the CL top due to LW radiative cooling [ m2/s3 ] wstar(i,m) = 0.0_r8 ! Convective velocity in each CL [ m/s ] wstar3fact(i,m) = 0.0_r8 ! Enhancement of 'wstar3' due to entrainment (inverse) [ no unit ] ebrk(i,m) = 0.0_r8 ! Net mean TKE of CL including entrainment effect [ m2/s2 ] wbrk(i,m) = 0.0_r8 ! Net mean normalized TKE (W) of CL, 'ebrk/b1' including entrainment effect [ m2/s2 ] lbrk(i,m) = 0.0_r8 ! Energetic internal thickness of CL [m] ricl(i,m) = 0.0_r8 ! CL internal mean Richardson number ghcl(i,m) = 0.0_r8 ! Half of normalized buoyancy production of CL shcl(i,m) = 0.0_r8 ! Galperin instability function of heat-moisture of CL smcl(i,m) = 0.0_r8 ! Galperin instability function of mementum of CL END DO END DO !########## ! Buoyancy coefficients : w'b' = ch * w'sl' + cm * w'qt' es(1)=0.0_r8! Saturation vapor pressure qs(1)=0.0_r8! Saturation specific humidity gam(1)=0.0_r8! (L/cp)*dqs/dT ep2=0.0_r8; templ(1)=0.0_r8; temps(1)=0.0_r8 ! ------------------------------- ! ! Variables for diagnostic output ! ! ------------------------------- ! !--------- zero(:) = 0._r8 zero2d(:,:) = 0._r8 ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! DO k=1,pver DO i=1,ncol ufd(i,k) = u(i,k) vfd(i,k) = v(i,k) tfd(i,k) = t(i,k) qvfd(i,k) = qv(i,k) qlfd(i,k) = ql(i,k) END DO END DO DO iturb = 1, nturb ! Compute total stress by including 'tms'. ! Here, in computing 'tms', we can use either iteratively changed 'ufd,vfd' or the ! initially given 'u,v' to the PBL scheme. Note that normal stress, 'taux, tauy' ! are not changed by iteration. In order to treat 'tms' in a fully implicit way, ! I am using updated wind, here. DO i=1,ncol tautotx(i) = taux(i) - ksrftms(i) * ufd(i,pver) tautoty(i) = tauy(i) - ksrftms(i) * vfd(i,pver) END DO ! Calculate (qt,sl,n2,s2,ri) from a given set of (t,qv,ql,qi,u,v) CALL trbintd( & pcols , pver , ncol , z , ufd , vfd , tfd , pmid , & tautotx , tautoty , ustar , rrho , s2 , n2 , ri , zi , & pi , cldn , qtfd , qvfd , qlfd , qi , sfi , sfuh , & sflh , slfd , slv , slslope , qtslope , chs , chu , cms , & cmu , minpblh ) ! Save initial (i.e., before iterative diffusion) profile of (qt,sl) at each iteration. ! Only necessary for (qt,sl) not (u,v) because (qt,sl) are newly calculated variables. IF( iturb .EQ. 1 ) THEN DO k=1,pver DO i=1,ncol qt(i,k) = qtfd(i,k) sl(i,k) = slfd(i,k) END DO END DO ENDIF ! Get free atmosphere exchange coefficients. This 'kvf' is not used in UW moist PBL scheme CALL austausch_atm( pcols, pver, ncol, ri, s2, kvf ) ! Initialize kvh/kvm to send to caleddy, depending on model timestep and iteration number ! This is necessary for 'wstar-based' entrainment closure. IF( iturb .EQ. 1 ) THEN IF( kvinit ) THEN ! First iteration of first model timestep : Use free tropospheric value or zero. IF( use_kvf ) THEN DO k=1,pver+1 DO i=1,ncol kvh(i,k) = kvf(i,k) kvm(i,k) = kvf(i,k) END DO END DO ELSE DO k=1,pver+1 DO i=1,ncol kvh(i,k) = 0._r8 kvm(i,k) = 0._r8 END DO END DO ENDIF ELSE ! First iteration on any model timestep except the first : Use value from previous timestep DO k=1,pver+1 DO i=1,ncol kvh(i,k) = kvh_in(i,k) kvm(i,k) = kvm_in(i,k) END DO END DO ENDIF ELSE ! Not the first iteration : Use from previous iteration DO k=1,pver+1 DO i=1,ncol kvh(i,k) = kvh_out(i,k) kvm(i,k) = kvm_out(i,k) END DO END DO ENDIF ! Calculate eddy diffusivity (kvh_out,kvm_out) and (tke,bprod,sprod) using ! a given (kvh,kvm) which are used only for initializing (bprod,sprod) at ! the first part of caleddy. (bprod,sprod) are fully updated at the end of ! caleddy after calculating (kvh_out,kvm_out) CALL caleddy( pcols , pver , ncol , & slfd , qtfd , qlfd , slv ,ufd , & vfd , pi , z , zi , & qflx , shflx , slslope , qtslope , & chu , chs , cmu , cms ,sfuh , & sflh , n2 , s2 , ri ,rrho , & pblh , ustar , & kvh , kvm , kvh_out , kvm_out , & tpert , qpert , qrl , kvf , tke , & wstarent , bprod , sprod , minpblh , wpert , & tkes , turbtype , sm_aw , & kbase_o , ktop_o , ncvfin_o , & kbase_mg , ktop_mg , ncvfin_mg , & kbase_f , ktop_f , ncvfin_f , & wet , web , jtbu , jbbu , & evhc , jt2slv , n2ht , n2hb , & lwp , opt_depth , radinvfrac, radf , & wstar , wstar3fact, & ebrk , wbrk , lbrk , ricl , ghcl , & shcl , smcl , ghi , shi , smi , & rii , lengi , wcap , pblhp , cldn , & landfrac , ipbl , kpblh , wsedl ) ! Calculate errorPBL to check whether PBL produced convergent solutions or not. IF( iturb .EQ. nturb ) THEN DO i = 1, ncol errorPBL(i) = 0._r8 DO k = 1, pver errorPBL(i) = errorPBL(i) + ( kvh(i,k) - kvh_out(i,k) )**2 END DO errorPBL(i) = SQRT(errorPBL(i)/pver) END DO END IF ! Eddy diffusivities which will be used for the initialization of (bprod, ! sprod) in 'caleddy' at the next iteration step. IF( iturb .GT. 1 .AND. iturb .LT. nturb ) THEN DO k=1,pver+1 DO i=1,ncol kvm_out(i,k) = lambda * kvm_out(i,k) + ( 1._r8 - lambda ) * kvm(i,k) kvh_out(i,k) = lambda * kvh_out(i,k) + ( 1._r8 - lambda ) * kvh(i,k) END DO END DO ENDIF ! Set nonlocal terms to zero for flux diagnostics, since not used by caleddy. DO k=1,pver+1 DO i=1,ncol cgh(i,k) = 0._r8 cgs(i,k) = 0._r8 END DO END DO IF( iturb .LT. nturb ) THEN ! Each time we diffuse the original state DO k=1,pver DO i=1,ncol slfd(i,k) = sl(i,k) qtfd(i,k) = qt(i,k) ufd(i,k) = u(i,k) vfd(i,k) = v(i,k) END DO END DO ! Diffuse initial profile of each time step using a given (kvh_out,kvm_out) ! In the below 'compute_vdiff', (slfd,qtfd,ufd,vfd) are 'inout' variables. CALL compute_vdiff( lchnk , & pcols , pver , 1 , ncol , pmid , & pi , rpdel , t , ztodt , taux , & tauy , shflx , qflx , ntop_turb , nbot_turb , & kvh_out , kvm_out , kvh_out , cgs , cgh , & zi , ksrftms , zero , fieldlist_wet, & ufd , vfd , qtfd , slfd , & jnk1d , jnk1d , jnk2d , jnk1d , errstring , & ! tauresx , tauresy , 0 , .false. ) tauresx , tauresy , 0 ) ! Retrieve (tfd,qvfd,qlfd) from (slfd,qtfd) in order to ! use 'trbintd' at the next iteration. DO k = 1, pver DO i = 1, ncol ! ----------------------------------------------------- ! ! Compute the condensate 'qlfd' in the updated profiles ! ! ----------------------------------------------------- ! ! Option.1 : Assume grid-mean condensate is homogeneously diffused by the moist turbulence scheme. ! This should bs used if 'pseudodiff = .false.' in vertical_diffusion.F90. ! Modification : Need to be check whether below is correct in the presence of ice, qi. ! I should understand why the variation of ice, qi is neglected during diffusion. templ(1) = ( slfd(i,k) - g*z(i,k) ) / cpair status = fqsatd( templ(1), pmid(i,k), es(1), qs(1), gam(1), 1 ) ep2 = 0.622_r8 temps(1) = templ(1) + ( qtfd(i,k) - qs(1) ) / ( cpair / latvap + latvap * qs(1) / ( rair * templ(1)**2 ) ) status = fqsatd( temps(1), pmid(i,k), es(1), qs(1), gam(1), 1 ) qlfd(i,k) = MAX( qtfd(i,k) - qi(i,k) - qs(1) ,0._r8 ) ! Option.2 : Assume condensate is not diffused by the moist turbulence scheme. ! This should bs used if 'pseudodiff = .true.' in vertical_diffusion.F90. ! qlfd(i,k) = ql(i,k) ! ----------------------------- ! ! Compute the other 'qvfd, tfd' ! ! ----------------------------- ! qvfd(i,k) = MAX( 0._r8, qtfd(i,k) - qi(i,k) - qlfd(i,k) ) tfd(i,k) = ( slfd(i,k) + latvap * qlfd(i,k) + latsub * qi(i,k) - g*z(i,k)) / cpair END DO END DO ENDIF ! Debug ! icol = phys_debug_col(lchnk) ! if( icol > 0 .and. get_nstep() .ge. 1 ) then ! write(iulog,*) ' ' ! write(iulog,*) 'eddy_diff debug at the end of iteration' ! write(iulog,*) 't, qv, ql, cld, u, v' ! do k = pver-3, pver ! write (iulog,*) k, tfd(icol,k), qvfd(icol,k), qlfd(icol,k), cldn(icol,k), ufd(icol,k), vfd(icol,k) ! end do ! endif ! Debug END DO ! End of 'iturb' iteration DO k=1,pver+1 DO i = 1, ncol kvq(i,k) = kvh_out(i,k) END DO END DO ! Compute 'wstar' within the PBL for use in the future convection scheme. DO i = 1, ncol IF( ipbl(i) .EQ. 1._r8 ) THEN wstarPBL(i) = MAX( 0._r8, wstar(i,1) ) ELSE wstarPBL(i) = 0._r8 ENDIF END DO ! --------------------------------------------------------------- ! ! Writing for detailed diagnostic analysis of UW moist PBL scheme ! ! --------------------------------------------------------------- ! !call outfld( 'UW_errorPBL', errorPBL, pcols, lchnk ) !call outfld( 'UW_n2', n2, pcols, lchnk ) !call outfld( 'UW_s2', s2, pcols, lchnk ) !call outfld( 'UW_ri', ri, pcols, lchnk ) !call outfld( 'UW_sfuh', sfuh, pcols, lchnk ) !call outfld( 'UW_sflh', sflh, pcols, lchnk ) !call outfld( 'UW_sfi', sfi, pcols, lchnk ) !call outfld( 'UW_cldn', cldn, pcols, lchnk ) !call outfld( 'UW_qrl', qrl, pcols, lchnk ) !call outfld( 'UW_ql', qlfd, pcols, lchnk ) !call outfld( 'UW_chu', chu, pcols, lchnk ) !call outfld( 'UW_chs', chs, pcols, lchnk ) !call outfld( 'UW_cmu', cmu, pcols, lchnk ) !call outfld( 'UW_cms', cms, pcols, lchnk ) !call outfld( 'UW_tke', tke, pcols, lchnk ) !call outfld( 'UW_wcap', wcap, pcols, lchnk ) !call outfld( 'UW_bprod', bprod, pcols, lchnk ) !call outfld( 'UW_sprod', sprod, pcols, lchnk ) !call outfld( 'UW_kvh', kvh_out, pcols, lchnk ) !call outfld( 'UW_kvm', kvm_out, pcols, lchnk ) !call outfld( 'UW_pblh', pblh, pcols, lchnk ) !call outfld( 'UW_pblhp', pblhp, pcols, lchnk ) !call outfld( 'UW_tpert', tpert, pcols, lchnk ) !call outfld( 'UW_qpert', qpert, pcols, lchnk ) !call outfld( 'UW_wpert', wpert, pcols, lchnk ) !call outfld( 'UW_ustar', ustar, pcols, lchnk ) !call outfld( 'UW_tkes', tkes, pcols, lchnk ) !call outfld( 'UW_minpblh', minpblh, pcols, lchnk ) !call outfld( 'UW_turbtype', turbtype, pcols, lchnk ) !call outfld( 'UW_kbase_o', kbase_o, pcols, lchnk ) !call outfld( 'UW_ktop_o', ktop_o, pcols, lchnk ) !call outfld( 'UW_ncvfin_o', ncvfin_o, pcols, lchnk ) !call outfld( 'UW_kbase_mg', kbase_mg, pcols, lchnk ) !call outfld( 'UW_ktop_mg', ktop_mg, pcols, lchnk ) !call outfld( 'UW_ncvfin_mg', ncvfin_mg, pcols, lchnk ) !call outfld( 'UW_kbase_f', kbase_f, pcols, lchnk ) !call outfld( 'UW_ktop_f', ktop_f, pcols, lchnk ) !call outfld( 'UW_ncvfin_f', ncvfin_f, pcols, lchnk ) !call outfld( 'UW_wet', wet, pcols, lchnk ) !call outfld( 'UW_web', web, pcols, lchnk ) !call outfld( 'UW_jtbu', jtbu, pcols, lchnk ) !call outfld( 'UW_jbbu', jbbu, pcols, lchnk ) !call outfld( 'UW_evhc', evhc, pcols, lchnk ) !call outfld( 'UW_jt2slv', jt2slv, pcols, lchnk ) !call outfld( 'UW_n2ht', n2ht, pcols, lchnk ) !call outfld( 'UW_n2hb', n2hb, pcols, lchnk ) !call outfld( 'UW_lwp', lwp, pcols, lchnk ) !call outfld( 'UW_optdepth', opt_depth, pcols, lchnk ) !call outfld( 'UW_radfrac', radinvfrac, pcols, lchnk ) !call outfld( 'UW_radf', radf, pcols, lchnk ) !call outfld( 'UW_wstar', wstar, pcols, lchnk ) !call outfld( 'UW_wstar3fact', wstar3fact, pcols, lchnk ) !call outfld( 'UW_ebrk', ebrk, pcols, lchnk ) !call outfld( 'UW_wbrk', wbrk, pcols, lchnk ) !call outfld( 'UW_lbrk', lbrk, pcols, lchnk ) !call outfld( 'UW_ricl', ricl, pcols, lchnk ) !call outfld( 'UW_ghcl', ghcl, pcols, lchnk ) !call outfld( 'UW_shcl', shcl, pcols, lchnk ) !call outfld( 'UW_smcl', smcl, pcols, lchnk ) !call outfld( 'UW_gh', ghi, pcols, lchnk ) !call outfld( 'UW_sh', shi, pcols, lchnk ) !call outfld( 'UW_sm', smi, pcols, lchnk ) !call outfld( 'UW_ria', rii, pcols, lchnk ) !call outfld( 'UW_leng', lengi, pcols, lchnk ) RETURN END SUBROUTINE compute_eddy_diff !=============================================================================== ! ! ! !=============================================================================== ! SUBROUTINE trbintd( pcols , pver , ncol , & z , u , v , & t , pmid , taux , & tauy , ustar , rrho , & s2 , n2 , ri , & zi , pi , cld , & qt , qv , ql , qi , sfi , sfuh , & sflh , sl , slv , slslope , qtslope , & chs , chu , cms , cmu , minpblh ) !----------------------------------------------------------------------- ! ! Purpose: Calculate buoyancy coefficients at all interfaces including ! ! surface. Also, computes the profiles of ( sl,qt,n2,s2,ri ). ! ! Note that (n2,s2,ri) are defined at each interfaces except ! ! surface. ! ! ! ! Author: B. Stevens ( Extracted from pbldiff, August, 2000 ) ! ! Sungsu Park ( August 2006, May. 2008 ) ! !----------------------------------------------------------------------- ! IMPLICIT NONE ! --------------- ! ! Input arguments ! ! --------------- ! INTEGER, INTENT(in) :: pcols ! Number of atmospheric columns INTEGER, INTENT(in) :: pver ! Number of atmospheric layers INTEGER, INTENT(in) :: ncol ! Number of atmospheric columns REAL(r8), INTENT(in) :: z(pcols,pver) ! Layer mid-point height above surface [ m ] REAL(r8), INTENT(in) :: u(pcols,pver) ! Layer mid-point u [ m/s ] REAL(r8), INTENT(in) :: v(pcols,pver) ! Layer mid-point v [ m/s ] REAL(r8), INTENT(in) :: t(pcols,pver) ! Layer mid-point temperature [ K ] REAL(r8), INTENT(in) :: pmid(pcols,pver) ! Layer mid-point pressure [ Pa ] REAL(r8), INTENT(in) :: taux(pcols) ! Surface u stress [ N/m2 ] REAL(r8), INTENT(in) :: tauy(pcols) ! Surface v stress [ N/m2 ] REAL(r8), INTENT(in) :: zi(pcols,pver+1) ! Interface height [ m ] REAL(r8), INTENT(in) :: pi(pcols,pver+1) ! Interface pressure [ Pa ] REAL(r8), INTENT(in) :: cld(pcols,pver) ! Stratus fraction REAL(r8), INTENT(in) :: qv(pcols,pver) ! Water vapor specific humidity [ kg/kg ] REAL(r8), INTENT(in) :: ql(pcols,pver) ! Liquid water specific humidity [ kg/kg ] REAL(r8), INTENT(in) :: qi(pcols,pver) ! Ice water specific humidity [ kg/kg ] !INTEGER, EXTERNAL :: qsat ! ---------------- ! ! Output arguments ! ! ---------------- ! REAL(r8), INTENT(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] REAL(r8), INTENT(out) :: s2(pcols,pver) ! Interfacial ( except surface ) shear squared [ s-2 ] REAL(r8), INTENT(out) :: n2(pcols,pver) ! Interfacial ( except surface ) buoyancy frequency [ s-2 ] REAL(r8), INTENT(out) :: ri(pcols,pver) ! Interfacial ( except surface ) Richardson number, 'n2/s2' REAL(r8), INTENT(out) :: qt(pcols,pver) ! Total specific humidity [ kg/kg ] REAL(r8), INTENT(out) :: sfi(pcols,pver+1) ! Interfacial layer saturation fraction [ fraction ] REAL(r8), INTENT(out) :: sfuh(pcols,pver) ! Saturation fraction in upper half-layer [ fraction ] REAL(r8), INTENT(out) :: sflh(pcols,pver) ! Saturation fraction in lower half-layer [ fraction ] REAL(r8), INTENT(out) :: sl(pcols,pver) ! Liquid water static energy [ J/kg ] REAL(r8), INTENT(out) :: slv(pcols,pver) ! Liquid water virtual static energy [ J/kg ] REAL(r8), INTENT(out) :: chu(pcols,pver+1) ! Heat buoyancy coef for dry states at all interfaces, finally. [ unit ? ] REAL(r8), INTENT(out) :: chs(pcols,pver+1) ! heat buoyancy coef for sat states at all interfaces, finally. [ unit ? ] REAL(r8), INTENT(out) :: cmu(pcols,pver+1) ! Moisture buoyancy coef for dry states at all interfaces, finally. [ unit ? ] REAL(r8), INTENT(out) :: cms(pcols,pver+1) ! Moisture buoyancy coef for sat states at all interfaces, finally. [ unit ? ] REAL(r8), INTENT(out) :: slslope(pcols,pver) ! Slope of 'sl' in each layer REAL(r8), INTENT(out) :: qtslope(pcols,pver) ! Slope of 'qt' in each layer REAL(r8), INTENT(out) :: rrho(pcols) ! 1./bottom level density [ m3/kg ] REAL(r8), INTENT(out) :: minpblh(pcols) ! Minimum PBL height based on surface stress [ m ] ! --------------- ! ! Local Variables ! ! --------------- ! INTEGER :: i ! Longitude index INTEGER :: k, km1 ! Level index INTEGER :: status ! Status returned by function calls REAL(r8) :: qs(pcols,pver) ! Saturation specific humidity REAL(r8) :: es(pcols,pver) ! Saturation vapor pressure REAL(r8) :: gam(pcols,pver) ! (l/cp)*(d(qs)/dT) REAL(r8) :: rdz ! 1 / (delta z) between midpoints REAL(r8) :: dsldz ! 'delta sl / delta z' at interface REAL(r8) :: dqtdz ! 'delta qt / delta z' at interface REAL(r8) :: ch ! 'sfi' weighted ch at the interface REAL(r8) :: cm ! 'sfi' weighted cm at the interface REAL(r8) :: bfact ! Buoyancy factor in n2 calculations REAL(r8) :: product ! Intermediate vars used to find slopes REAL(r8) :: dsldp_a, dqtdp_a ! Slopes across interface above REAL(r8) :: dsldp_b(pcols), dqtdp_b(pcols) ! Slopes across interface below DO k=1,pver DO i=1,pcols s2 (i,k) = 0.0_r8 n2 (i,k) = 0.0_r8 ri (i,k) = 0.0_r8 slslope(i,k) = 0.0_r8 qtslope(i,k) = 0.0_r8 qt (i,k) = 0.0_r8 sfuh (i,k) = 0.0_r8 sflh (i,k) = 0.0_r8 sl (i,k) = 0.0_r8 slv (i,k) = 0.0_r8 qs (i,k) = 0.0_r8! Saturation specific humidity es (i,k) = 0.0_r8! Saturation vapor pressure gam (i,k) = 0.0_r8! (l/cp)*(d(qs)/dT) END DO END DO DO k=1,pver+1 DO i=1,pcols sfi (i,k) = 0.0_r8 chu (i,k) = 0.0_r8 chs (i,k) = 0.0_r8 cmu (i,k) = 0.0_r8 cms (i,k) = 0.0_r8 END DO END DO DO i=1,pcols dsldp_b(i)= 0.0_r8 dqtdp_b(i)= 0.0_r8! Slopes across interface below ustar (i)= 0.0_r8 rrho (i)= 0.0_r8 minpblh(i)= 0.0_r8 END DO rdz= 0.0_r8;dsldz= 0.0_r8;dqtdz= 0.0_r8;ch= 0.0_r8 cm= 0.0_r8;bfact= 0.0_r8;product= 0.0_r8 dsldp_a= 0.0_r8; dqtdp_a= 0.0_r8 ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! ! Compute ustar, and kinematic surface fluxes from surface energy fluxes DO i = 1, ncol rrho(i) = rair * t(i,pver) / pmid(i,pver) ustar(i) = MAX( SQRT( SQRT( taux(i)**2 + tauy(i)**2 ) * rrho(i) ), ustar_min ) minpblh(i) = 100.0_r8 * ustar(i) ! By construction, 'minpblh' is larger than 1 [m] when 'ustar_min = 0.01'. END DO ! Calculate conservative scalars (qt,sl,slv) and buoyancy coefficients at the layer mid-points. ! Note that 'ntop_turb = 1', 'nbot_turb = pver' DO k = ntop_turb, nbot_turb status = fqsatd( t(1,k), pmid(1,k), es(1,k), qs(1,k), gam(1,k), ncol ) DO i = 1, ncol qt(i,k) = qv(i,k) + ql(i,k) + qi(i,k) sl(i,k) = cpair * t(i,k) + g * z(i,k) - latvap * ql(i,k) - latsub * qi(i,k) slv(i,k) = sl(i,k) * ( 1._r8 + zvir * qt(i,k) ) ! Thermodynamic coefficients for buoyancy flux - in this loop these are ! calculated at mid-points; later, they will be averaged to interfaces, ! where they will ultimately be used. At the surface, the coefficients ! are taken from the lowest mid point. bfact = g / ( t(i,k) * ( 1._r8 + zvir * qv(i,k) - ql(i,k) - qi(i,k) ) ) chu(i,k) = ( 1._r8 + zvir * qt(i,k) ) * bfact / cpair chs(i,k) = ( ( 1._r8 + ( 1._r8 + zvir ) * gam(i,k) * cpair * t(i,k) / latvap ) / ( 1._r8 + gam(i,k) ) ) * bfact / cpair cmu(i,k) = zvir * bfact * t(i,k) cms(i,k) = latvap * chs(i,k) - bfact * t(i,k) END DO END DO DO i = 1, ncol chu(i,pver+1) = chu(i,pver) chs(i,pver+1) = chs(i,pver) cmu(i,pver+1) = cmu(i,pver) cms(i,pver+1) = cms(i,pver) END DO ! Compute slopes of conserved variables sl, qt within each layer k. ! 'a' indicates the 'above' gradient from layer k-1 to layer k and ! 'b' indicates the 'below' gradient from layer k to layer k+1. ! We take a smaller (in absolute value) of these gradients as the ! slope within layer k. If they have opposite signs, gradient in ! layer k is taken to be zero. I should re-consider whether this ! profile reconstruction is the best or not. ! This is similar to the profile reconstruction used in the UWShCu. DO i = 1, ncol ! Slopes at endpoints determined by extrapolation slslope(i,pver) = ( sl(i,pver) - sl(i,pver-1) ) / ( pmid(i,pver) - pmid(i,pver-1) ) qtslope(i,pver) = ( qt(i,pver) - qt(i,pver-1) ) / ( pmid(i,pver) - pmid(i,pver-1) ) slslope(i,1) = ( sl(i,2) - sl(i,1) ) / ( pmid(i,2) - pmid(i,1) ) qtslope(i,1) = ( qt(i,2) - qt(i,1) ) / ( pmid(i,2) - pmid(i,1) ) dsldp_b(i) = slslope(i,1) dqtdp_b(i) = qtslope(i,1) END DO DO k = 2, pver - 1 DO i = 1, ncol dsldp_a = dsldp_b(i) dqtdp_a = dqtdp_b(i) dsldp_b(i) = ( sl(i,k+1) - sl(i,k) ) / ( pmid(i,k+1) - pmid(i,k) ) dqtdp_b(i) = ( qt(i,k+1) - qt(i,k) ) / ( pmid(i,k+1) - pmid(i,k) ) product = dsldp_a * dsldp_b(i) IF( product .LE. 0._r8 ) THEN slslope(i,k) = 0._r8 ELSE IF( product .GT. 0._r8 .AND. dsldp_a .LT. 0._r8 ) THEN slslope(i,k) = MAX( dsldp_a, dsldp_b(i) ) ELSE IF( product .GT. 0._r8 .AND. dsldp_a .GT. 0._r8 ) THEN slslope(i,k) = MIN( dsldp_a, dsldp_b(i) ) END IF product = dqtdp_a*dqtdp_b(i) IF( product .LE. 0._r8 ) THEN qtslope(i,k) = 0._r8 ELSE IF( product .GT. 0._r8 .AND. dqtdp_a .LT. 0._r8 ) THEN qtslope(i,k) = MAX( dqtdp_a, dqtdp_b(i) ) ELSE IF( product .GT. 0._r8 .AND. dqtdp_a .GT. 0._r8 ) THEN qtslope(i,k) = MIN( dqtdp_a, dqtdp_b(i) ) END IF END DO ! i END DO ! k ! Compute saturation fraction at the interfacial layers for use in buoyancy ! flux computation. CALL sfdiag( pcols , pver , ncol , qt , ql , sl , & pi , pmid , zi , cld , sfi , sfuh , & sflh , slslope , qtslope ) ! Calculate buoyancy coefficients at all interfaces (1:pver+1) and (n2,s2,ri) ! at all interfaces except surface. Note 'nbot_turb = pver', 'ntop_turb = 1'. ! With the previous definition of buoyancy coefficients at the surface, the ! resulting buoyancy coefficients at the top and surface interfaces becomes ! identical to the buoyancy coefficients at the top and bottom layers. Note ! that even though the dimension of (s2,n2,ri) is 'pver', they are defined ! at interfaces ( not at the layer mid-points ) except the surface. DO k = nbot_turb, ntop_turb + 1, -1 km1 = k - 1 DO i = 1, ncol rdz = 1._r8 / ( z(i,km1) - z(i,k) ) dsldz = ( sl(i,km1) - sl(i,k) ) * rdz dqtdz = ( qt(i,km1) - qt(i,k) ) * rdz chu(i,k) = ( chu(i,km1) + chu(i,k) ) * 0.5_r8 chs(i,k) = ( chs(i,km1) + chs(i,k) ) * 0.5_r8 cmu(i,k) = ( cmu(i,km1) + cmu(i,k) ) * 0.5_r8 cms(i,k) = ( cms(i,km1) + cms(i,k) ) * 0.5_r8 ch = chu(i,k) * ( 1._r8 - sfi(i,k) ) + chs(i,k) * sfi(i,k) cm = cmu(i,k) * ( 1._r8 - sfi(i,k) ) + cms(i,k) * sfi(i,k) n2(i,k) = ch * dsldz + cm * dqtdz s2(i,k) = ( ( u(i,km1) - u(i,k) )**2 + ( v(i,km1) - v(i,k) )**2) * rdz**2 s2(i,k) = MAX( ntzero, s2(i,k) ) ri(i,k) = n2(i,k) / s2(i,k) END DO END DO DO i = 1, ncol n2(i,1) = n2(i,2) s2(i,1) = s2(i,2) ri(i,1) = ri(i,2) END DO RETURN END SUBROUTINE trbintd !=============================================================================== ! ! ! !=============================================================================== ! SUBROUTINE sfdiag( pcols , pver , ncol , qt , ql , sl , & pi , pm , zi , cld , sfi , sfuh , & sflh , slslope , qtslope ) !----------------------------------------------------------------------- ! ! ! ! Purpose: Interface for calculating saturation fractions at upper and ! ! lower-half layers, & interfaces for use by turbulence scheme ! ! ! ! Method : Various but 'l' should be chosen for consistency. ! ! ! ! Author : B. Stevens and C. Bretherton (August 2000) ! ! Sungsu Park. August 2006. ! ! May. 2008. ! ! ! ! S.Park : The computed saturation fractions are repeatedly ! ! used to compute buoyancy coefficients in'trbintd' & 'caleddy'.! !----------------------------------------------------------------------- ! IMPLICIT NONE ! --------------- ! ! Input arguments ! ! --------------- ! !INTEGER, EXTERNAL :: qsat INTEGER, INTENT(in) :: pcols ! Number of atmospheric columns INTEGER, INTENT(in) :: pver ! Number of atmospheric layers INTEGER, INTENT(in) :: ncol ! Number of atmospheric columns REAL(r8), INTENT(in) :: sl(pcols,pver) ! Liquid water static energy [ J/kg ] REAL(r8), INTENT(in) :: qt(pcols,pver) ! Total water specific humidity [ kg/kg ] REAL(r8), INTENT(in) :: ql(pcols,pver) ! Liquid water specific humidity [ kg/kg ] REAL(r8), INTENT(in) :: pi(pcols,pver+1) ! Interface pressures [ Pa ] REAL(r8), INTENT(in) :: pm(pcols,pver) ! Layer mid-point pressures [ Pa ] REAL(r8), INTENT(in) :: zi(pcols,pver+1) ! Interface heights [ m ] REAL(r8), INTENT(in) :: cld(pcols,pver) ! Stratiform cloud fraction [ fraction ] REAL(r8), INTENT(in) :: slslope(pcols,pver) ! Slope of 'sl' in each layer REAL(r8), INTENT(in) :: qtslope(pcols,pver) ! Slope of 'qt' in each layer ! ---------------- ! ! Output arguments ! ! ---------------- ! REAL(r8), INTENT(out) :: sfi(pcols,pver+1) ! Interfacial layer saturation fraction [ fraction ] REAL(r8), INTENT(out) :: sfuh(pcols,pver) ! Saturation fraction in upper half-layer [ fraction ] REAL(r8), INTENT(out) :: sflh(pcols,pver) ! Saturation fraction in lower half-layer [ fraction ] ! --------------- ! ! Local Variables ! ! --------------- ! INTEGER :: i ! Longitude index INTEGER :: k ! Vertical index INTEGER :: km1 ! k-1 INTEGER :: status ! Status returned by function calls REAL(r8) :: sltop, slbot ! sl at top/bot of grid layer REAL(r8) :: qttop, qtbot ! qt at top/bot of grid layer REAL(r8) :: tltop(1), tlbot(1) ! Liquid water temperature at top/bot of grid layer REAL(r8) :: qxtop, qxbot ! Sat excess at top/bot of grid layer REAL(r8) :: qxm ! Sat excess at midpoint REAL(r8) :: es(1) ! Saturation vapor pressure REAL(r8) :: qs(1) ! Saturation spec. humidity REAL(r8) :: gam(1) ! (L/cp)*dqs/dT REAL(r8) :: cldeff(pcols,pver) ! Effective Cloud Fraction [ fraction ] ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! DO k=1,pver+1 DO i=1,pcols sfi (i,k) = 0.0_r8 END DO END DO DO k=1,pver DO i=1,pcols sflh (i,k) = 0.0_r8 sfuh (i,k) = 0.0_r8 cldeff(i,k) = 0.0_r8 END DO END DO SELECT CASE (sftype) CASE ('d') ! ----------------------------------------------------------------------- ! ! Simply use the given stratus fraction ('horizontal' cloud partitioning) ! ! ----------------------------------------------------------------------- ! DO k = ntop_turb + 1, nbot_turb km1 = k - 1 DO i = 1, ncol sfuh(i,k) = cld(i,k) sflh(i,k) = cld(i,k) sfi(i,k) = 0.5_r8 * ( sflh(i,km1) + MIN( sflh(i,km1), sfuh(i,k) ) ) END DO END DO DO i = 1, ncol sfi(i,pver+1) = sflh(i,pver) END DO CASE ('l') ! ------------------------------------------ ! ! Use modified stratus fraction partitioning ! ! ------------------------------------------ ! DO k = ntop_turb + 1, nbot_turb km1 = k - 1 DO i = 1, ncol cldeff(i,k) = cld(i,k) sfuh(i,k) = cld(i,k) sflh(i,k) = cld(i,k) IF( ql(i,k) .LT. qmin(2) ) THEN sfuh(i,k) = 0._r8 sflh(i,k) = 0._r8 END IF ! Modification : The contribution of ice should be carefully considered. IF( choice_evhc .EQ. 'ramp' .OR. choice_radf .EQ. 'ramp' ) THEN cldeff(i,k) = cld(i,k) * MIN( ql(i,k) / qmin(2), 1._r8 ) sfuh(i,k) = cldeff(i,k) sflh(i,k) = cldeff(i,k) ELSEIF( choice_evhc .EQ. 'maxi' .OR. choice_radf .EQ. 'maxi' ) THEN cldeff(i,k) = cld(i,k) sfuh(i,k) = cldeff(i,k) sflh(i,k) = cldeff(i,k) ENDIF ! At the stratus top, take the minimum interfacial saturation fraction sfi(i,k) = 0.5_r8 * ( sflh(i,km1) + MIN( sfuh(i,k), sflh(i,km1) ) ) ! Modification : Currently sfi at the top and surface interfaces are set to be zero. ! Also, sfuh and sflh in the top model layer is set to be zero. ! However, I may need to set ! do i = 1, ncol ! sfi(i,pver+1) = sflh(i,pver) ! end do ! for treating surface-based fog. ! OK. I added below block similar to the other cases. END DO END DO DO i = 1, ncol sfi(i,pver+1) = sflh(i,pver) END DO CASE ('u') ! ------------------------------------------------------------------------- ! ! Use unsaturated buoyancy - since sfi, sfuh, sflh have already been zeroed ! ! nothing more need be done for this case. ! ! ------------------------------------------------------------------------- ! CASE ('z') ! ------------------------------------------------------------------------- ! ! Calculate saturation fraction based on whether the air just above or just ! ! below the interface is saturated, i.e. with vertical cloud partitioning. ! ! The saturation fraction of the interfacial layer between mid-points k and ! ! k+1 is computed by averaging the saturation fraction of the half-layers ! ! above and below the interface, with a special provision for cloud tops ! ! (more cloud in the half-layer below than in the half-layer above).In each ! ! half-layer, vertical partitioning of cloud based on the slopes diagnosed ! ! above is used. Loop down through the layers, computing the saturation ! ! fraction in each half-layer (sfuh for upper half, sflh for lower half). ! ! Once sfuh(i,k) is computed, use with sflh(i,k-1) to determine saturation ! ! fraction sfi(i,k) for interfacial layer k-0.5. ! ! This is 'not' chosen for full consistent treatment of stratus fraction in ! ! all physics schemes. ! ! ------------------------------------------------------------------------- ! DO k = ntop_turb + 1, nbot_turb km1 = k - 1 DO i = 1, ncol ! Compute saturation excess at the mid-point of layer k sltop = sl(i,k) + slslope(i,k) * ( pi(i,k) - pm(i,k) ) qttop = qt(i,k) + qtslope(i,k) * ( pi(i,k) - pm(i,k) ) tltop(1) = ( sltop - g * zi(i,k) ) / cpair status = fqsatd( tltop(1), pi(i,k), es(1), qs(1), gam(1), 1 ) qxtop = qttop - qs(1) slbot = sl(i,k) + slslope(i,k) * ( pi(i,k+1) - pm(i,k) ) qtbot = qt(i,k) + qtslope(i,k) * ( pi(i,k+1) - pm(i,k) ) tlbot(1) = ( slbot - g * zi(i,k+1) ) / cpair status = fqsatd( tlbot(1), pi(i,k+1), es(1), qs(1), gam(1), 1 ) qxbot = qtbot - qs(1) qxm = qxtop + ( qxbot - qxtop ) * ( pm(i,k) - pi(i,k) ) / ( pi(i,k+1) - pi(i,k) ) ! Find the saturation fraction sfuh(i,k) of the upper half of layer k. IF( ( qxtop .LT. 0._r8 ) .AND. ( qxm .LT. 0._r8 ) ) THEN sfuh(i,k) = 0._r8 ELSE IF( ( qxtop .GT. 0._r8 ) .AND. ( qxm .GT. 0._r8 ) ) THEN sfuh(i,k) = 1._r8 ELSE ! Either qxm < 0 and qxtop > 0 or vice versa sfuh(i,k) = MAX( qxtop, qxm ) / ABS( qxtop - qxm ) END IF ! Combine with sflh(i) (still for layer k-1) to get interfac layer saturation fraction sfi(i,k) = 0.5_r8 * ( sflh(i,k-1) + MIN( sflh(i,k-1), sfuh(i,k) ) ) ! Update sflh to be for the lower half of layer k. IF( ( qxbot .LT. 0._r8 ) .AND. ( qxm .LT. 0._r8 ) ) THEN sflh(i,k) = 0._r8 ELSE IF( ( qxbot .GT. 0._r8 ) .AND. ( qxm .GT. 0._r8 ) ) THEN sflh(i,k) = 1._r8 ELSE ! Either qxm < 0 and qxbot > 0 or vice versa sflh(i,k) = MAX( qxbot, qxm ) / ABS( qxbot - qxm ) END IF END DO ! i END DO ! k DO i = 1, ncol sfi(i,pver+1) = sflh(i,pver) ! Saturation fraction in the lowest half-layer. END DO END SELECT RETURN END SUBROUTINE sfdiag !=============================================================================== ! ! ! !=============================================================================== ! SUBROUTINE austausch_atm( pcols, pver, ncol, ri, s2, kvf ) !---------------------------------------------------------------------- ! ! ! ! Purpose: Computes exchange coefficients for free turbulent flows. ! ! This is not used in the UW moist turbulence scheme. ! ! ! ! Method: ! ! ! ! The free atmosphere diffusivities are based on standard mixing length ! ! forms for the neutral diffusivity multiplied by functns of Richardson ! ! number. K = l^2 * |dV/dz| * f(Ri). The same functions are used for ! ! momentum, potential temperature, and constitutents. ! ! ! ! The stable Richardson num function (Ri>0) is taken from Holtslag and ! ! Beljaars (1989), ECMWF proceedings. f = 1 / (1 + 10*Ri*(1 + 8*Ri)) ! ! The unstable Richardson number function (Ri<0) is taken from CCM1. ! ! f = sqrt(1 - 18*Ri) ! ! ! ! Author: B. Stevens (rewrite, August 2000) ! ! ! !---------------------------------------------------------------------- ! IMPLICIT NONE ! --------------- ! ! Input arguments ! ! --------------- ! INTEGER, INTENT(in) :: pcols ! Number of atmospheric columns INTEGER, INTENT(in) :: pver ! Number of atmospheric layers INTEGER, INTENT(in) :: ncol ! Number of atmospheric columns REAL(r8), INTENT(in) :: s2(pcols,pver) ! Shear squared REAL(r8), INTENT(in) :: ri(pcols,pver) ! Richardson no ! ---------------- ! ! Output arguments ! ! ---------------- ! REAL(r8), INTENT(out) :: kvf(pcols,pver+1) ! Eddy diffusivity for heat and tracers ! --------------- ! ! Local Variables ! ! --------------- ! REAL(r8) :: fofri ! f(ri) REAL(r8) :: kvn ! Neutral Kv INTEGER :: i ! Longitude index INTEGER :: k ! Vertical index ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! DO k=1,pver+1 DO i=1,ncol kvf(i,k) = 0.0_r8 END DO END DO fofri=0.0_r8;kvn=0.0_r8 ! Compute the free atmosphere vertical diffusion coefficients: kvh = kvq = kvm. DO k = ntop_turb + 1, nbot_turb DO i = 1, ncol IF( ri(i,k) < 0.0_r8 ) THEN fofri = SQRT( MAX( 1._r8 - 18._r8 * ri(i,k), 0._r8 ) ) ELSE fofri = 1.0_r8 / ( 1.0_r8 + 10.0_r8 * ri(i,k) * ( 1.0_r8 + 8.0_r8 * ri(i,k) ) ) END IF kvn = ml2(k) * SQRT(s2(i,k)) kvf(i,k) = MAX( zkmin, kvn * fofri ) END DO END DO RETURN END SUBROUTINE austausch_atm ! ---------------------------------------------------------------------------- ! ! ! ! The University of Washington Moist Turbulence Scheme ! ! ! ! Authors : Chris Bretherton at the University of Washington, Seattle, WA ! ! Sungsu Park at the CGD/NCAR, Boulder, CO ! ! ! ! ---------------------------------------------------------------------------- ! SUBROUTINE caleddy( pcols , pver , ncol , & sl , qt , ql , slv , u , & v , pi , z , zi , & qflx , shflx , slslope , qtslope , & chu , chs , cmu , cms , sfuh , & sflh , n2 , s2 , ri , rrho , & pblh , ustar , & kvh_in , kvm_in , kvh , kvm , & tpert , qpert , qrlin , kvf , tke , & wstarent , bprod , sprod , minpblh , wpert , & tkes , turbtype_f , sm_aw , & kbase_o , ktop_o , ncvfin_o , & kbase_mg , ktop_mg , ncvfin_mg , & kbase_f , ktop_f , ncvfin_f , & wet_CL , web_CL , jtbu_CL , jbbu_CL , & evhc_CL , jt2slv_CL , n2ht_CL , n2hb_CL , lwp_CL , & opt_depth_CL , radinvfrac_CL, radf_CL , wstar_CL , wstar3fact_CL, & ebrk , wbrk , lbrk , ricl , ghcl , & shcl , smcl , & gh_a , sh_a , sm_a , ri_a , leng , & wcap , pblhp , cld ,landfrac , ipbl , & kpblh , wsedl ) !--------------------------------------------------------------------------------- ! ! ! ! Purpose : This is a driver routine to compute eddy diffusion coefficients ! ! for heat (sl), momentum (u, v), moisture (qt), and other trace ! ! constituents. This scheme uses first order closure for stable ! ! turbulent layers (STL). For convective layers (CL), entrainment ! ! closure is used at the CL external interfaces, which is coupled ! ! to the diagnosis of a CL regime mean TKE from the instantaneous ! ! thermodynamic and velocity profiles. The CLs are diagnosed by ! ! extending original CL layers of moist static instability into ! ! adjacent weakly stably stratified interfaces, stopping if the ! ! stability is too strong. This allows a realistic depiction of ! ! dry convective boundary layers with a downgradient approach. ! ! ! ! NOTE: This routine currently assumes ntop_turb = 1, nbot_turb = pver ! ! ( turbulent diffusivities computed at all interior interfaces ) ! ! and will require modification to handle a different ntop_turb. ! ! ! ! Authors: Sungsu Park and Chris Bretherton. 08/2006, 05/2008. ! ! ! ! For details, see ! ! ! ! 1. 'A new moist turbulence parametrization in the Community Atmosphere Model' ! ! by Christopher S. Bretherton & Sungsu Park. J. Climate. 22. 3422-3448. 2009. ! ! ! ! 2. 'The University of Washington shallow convection and moist turbulence schemes ! ! and their impact on climate simulations with the Community Atmosphere Model' ! ! by Sungsu Park & Christopher S. Bretherton. J. Climate. 22. 3449-3469. 2009. ! ! ! ! For questions on the scheme and code, send an email to ! ! sungsup@ucar.edu or breth@washington.edu ! ! ! !--------------------------------------------------------------------------------- ! ! ---------------- ! ! Inputs variables ! ! ---------------- ! IMPLICIT NONE INTEGER, INTENT(in) :: pcols ! Number of atmospheric columns INTEGER, INTENT(in) :: pver ! Number of atmospheric layers INTEGER, INTENT(in) :: ncol ! Number of atmospheric columns REAL(r8), INTENT(in) :: u(pcols,pver) ! U wind [ m/s ] REAL(r8), INTENT(in) :: v(pcols,pver) ! V wind [ m/s ] REAL(r8), INTENT(in) :: sl(pcols,pver) ! Liquid water static energy, cp * T + g * z - Lv * ql - Ls * qi [ J/kg ] REAL(r8), INTENT(in) :: slv(pcols,pver) ! Liquid water virtual static energy, sl * ( 1 + 0.608 * qt ) [ J/kg ] REAL(r8), INTENT(in) :: qt(pcols,pver) ! Total speccific humidity qv + ql + qi [ kg/kg ] REAL(r8), INTENT(in) :: ql(pcols,pver) ! Liquid water specific humidity [ kg/kg ] REAL(r8), INTENT(in) :: pi(pcols,pver+1) ! Interface pressures [ Pa ] REAL(r8), INTENT(in) :: z(pcols,pver) ! Layer midpoint height above surface [ m ] REAL(r8), INTENT(in) :: zi(pcols,pver+1) ! Interface height above surface, i.e., zi(pver+1) = 0 all over the globe [ m ] REAL(r8), INTENT(in) :: chu(pcols,pver+1) ! Buoyancy coeffi. unsaturated sl (heat) coef. at all interfaces. [ unit ? ] REAL(r8), INTENT(in) :: chs(pcols,pver+1) ! Buoyancy coeffi. saturated sl (heat) coef. at all interfaces. [ unit ? ] REAL(r8), INTENT(in) :: cmu(pcols,pver+1) ! Buoyancy coeffi. unsaturated qt (moisture) coef. at all interfaces [ unit ? ] REAL(r8), INTENT(in) :: cms(pcols,pver+1) ! Buoyancy coeffi. saturated qt (moisture) coef. at all interfaces [ unit ? ] REAL(r8), INTENT(in) :: sfuh(pcols,pver) ! Saturation fraction in upper half-layer [ fraction ] REAL(r8), INTENT(in) :: sflh(pcols,pver) ! Saturation fraction in lower half-layer [ fraction ] REAL(r8), INTENT(in) :: n2(pcols,pver) ! Interfacial (except surface) moist buoyancy frequency [ s-2 ] REAL(r8), INTENT(in) :: s2(pcols,pver) ! Interfacial (except surface) shear frequency [ s-2 ] REAL(r8), INTENT(in) :: ri(pcols,pver) ! Interfacial (except surface) Richardson number REAL(r8), INTENT(in) :: qflx(pcols) ! Kinematic surface constituent ( water vapor ) flux [ kg/m2/s ] REAL(r8), INTENT(in) :: shflx(pcols) ! Kinematic surface heat flux [ unit ? ] REAL(r8), INTENT(in) :: slslope(pcols,pver) ! Slope of 'sl' in each layer [ J/kg/Pa ] REAL(r8), INTENT(in) :: qtslope(pcols,pver) ! Slope of 'qt' in each layer [ kg/kg/Pa ] REAL(r8), INTENT(in) :: qrlin(pcols,pver) ! Input grid-mean LW heating rate : [ K/s ] * cpair * dp = [ W/kg*Pa ] REAL(r8), INTENT(in) :: wsedl(pcols,pver) ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] REAL(r8), INTENT(in) :: ustar(pcols) ! Surface friction velocity [ m/s ] REAL(r8), INTENT(in) :: rrho(pcols) ! 1./bottom mid-point density. Specific volume [ m3/kg ] REAL(r8), INTENT(in) :: kvf(pcols,pver+1) ! Free atmosphere eddy diffusivity [ m2/s ] LOGICAL, INTENT(in) :: wstarent ! Switch for choosing wstar3 entrainment parameterization REAL(r8), INTENT(in) :: minpblh(pcols) ! Minimum PBL height based on surface stress [ m ] REAL(r8), INTENT(in) :: kvh_in(pcols,pver+1) ! kvh saved from last timestep or last iterative step [ m2/s ] REAL(r8), INTENT(in) :: kvm_in(pcols,pver+1) ! kvm saved from last timestep or last iterative step [ m2/s ] REAL(r8), INTENT(in) :: cld(pcols,pver) ! Stratus Cloud Fraction [ fraction ] REAL(r8), INTENT(in) :: landfrac(pcols) ! ---------------- ! ! Output variables ! ! ---------------- ! REAL(r8), INTENT(out) :: kvh(pcols,pver+1) ! Eddy diffusivity for heat, moisture, and tracers [ m2/s ] REAL(r8), INTENT(out) :: kvm(pcols,pver+1) ! Eddy diffusivity for momentum [ m2/s ] REAL(r8), INTENT(out) :: pblh(pcols) ! PBL top height [ m ] REAL(r8), INTENT(out) :: pblhp(pcols) ! PBL top height pressure [ Pa ] REAL(r8), INTENT(out) :: tpert(pcols) ! Convective temperature excess [ K ] REAL(r8), INTENT(out) :: qpert(pcols) ! Convective humidity excess [ kg/kg ] REAL(r8), INTENT(out) :: wpert(pcols) ! Turbulent velocity excess [ m/s ] REAL(r8), INTENT(out) :: tke(pcols,pver+1) ! Turbulent kinetic energy [ m2/s2 ], 'tkes' at surface, pver+1. REAL(r8), INTENT(out) :: bprod(pcols,pver+1) ! Buoyancy production [ m2/s3 ], 'bflxs' at surface, pver+1. REAL(r8), INTENT(out) :: sprod(pcols,pver+1) ! Shear production [ m2/s3 ], (ustar(i)**3)/(vk*z(i,pver)) at surface, pver+1. REAL(r8), INTENT(out) :: turbtype_f(pcols,pver+1) ! Turbulence type at each interface: ! 0. = Non turbulence interface ! 1. = Stable turbulence interface ! 2. = CL interior interface ( if bflxs > 0, surface is this ) ! 3. = Bottom external interface of CL ! 4. = Top external interface of CL. ! 5. = Double entraining CL external interface REAL(r8), INTENT(out) :: sm_aw(pcols,pver+1) ! Galperin instability function of momentum for use in the microphysics [ no unit ] REAL(r8), INTENT(out) :: ipbl(pcols) ! If 1, PBL is CL, while if 0, PBL is STL. REAL(r8), INTENT(out) :: kpblh(pcols) ! Layer index containing PBL within or at the base interface ! --------------------------- ! ! Diagnostic output variables ! ! --------------------------- ! REAL(r8) :: tkes(pcols) ! TKE at surface [ m2/s2 ] REAL(r8) :: kbase_o(pcols,ncvmax) ! Original external base interface index of CL just after 'exacol' REAL(r8) :: ktop_o(pcols,ncvmax) ! Original external top interface index of CL just after 'exacol' REAL(r8) :: ncvfin_o(pcols) ! Original number of CLs just after 'exacol' REAL(r8) :: kbase_mg(pcols,ncvmax) ! kbase just after extending-merging (after 'zisocl') but without SRCL REAL(r8) :: ktop_mg(pcols,ncvmax) ! ktop just after extending-merging (after 'zisocl') but without SRCL REAL(r8) :: ncvfin_mg(pcols) ! ncvfin just after extending-merging (after 'zisocl') but without SRCL REAL(r8) :: kbase_f(pcols,ncvmax) ! Final kbase after adding SRCL REAL(r8) :: ktop_f(pcols,ncvmax) ! Final ktop after adding SRCL REAL(r8) :: ncvfin_f(pcols) ! Final ncvfin after adding SRCL REAL(r8) :: wet_CL(pcols,ncvmax) ! Entrainment rate at the CL top [ m/s ] REAL(r8) :: web_CL(pcols,ncvmax) ! Entrainment rate at the CL base [ m/s ] REAL(r8) :: jtbu_CL(pcols,ncvmax) ! Buoyancy jump across the CL top [ m/s2 ] REAL(r8) :: jbbu_CL(pcols,ncvmax) ! Buoyancy jump across the CL base [ m/s2 ] REAL(r8) :: evhc_CL(pcols,ncvmax) ! Evaporative enhancement factor at the CL top REAL(r8) :: jt2slv_CL(pcols,ncvmax) ! Jump of slv ( across two layers ) at CL top for use only in evhc [ J/kg ] REAL(r8) :: n2ht_CL(pcols,ncvmax) ! n2 defined at the CL top interface but using sfuh(kt) instead of sfi(kt) [ s-2 ] REAL(r8) :: n2hb_CL(pcols,ncvmax) ! n2 defined at the CL base interface but using sflh(kb-1) instead of sfi(kb) [ s-2 ] REAL(r8) :: lwp_CL(pcols,ncvmax) ! LWP in the CL top layer [ kg/m2 ] REAL(r8) :: opt_depth_CL(pcols,ncvmax) ! Optical depth of the CL top layer REAL(r8) :: radinvfrac_CL(pcols,ncvmax) ! Fraction of LW radiative cooling confined in the top portion of CL REAL(r8) :: radf_CL(pcols,ncvmax) ! Buoyancy production at the CL top due to radiative cooling [ m2/s3 ] REAL(r8) :: wstar_CL(pcols,ncvmax) ! Convective velocity of CL including entrainment contribution finally [ m/s ] REAL(r8) :: wstar3fact_CL(pcols,ncvmax) ! "wstar3fact" of CL. Entrainment enhancement of wstar3 (inverse) REAL(r8) :: gh_a(pcols,pver+1) ! Half of normalized buoyancy production, -l2n2/2e. [ no unit ] REAL(r8) :: sh_a(pcols,pver+1) ! Galperin instability function of heat-moisture at all interfaces [ no unit ] REAL(r8) :: sm_a(pcols,pver+1) ! Galperin instability function of momentum at all interfaces [ no unit ] REAL(r8) :: ri_a(pcols,pver+1) ! Interfacial Richardson number at all interfaces [ no unit ] REAL(r8) :: ebrk(pcols,ncvmax) ! Net CL mean TKE [ m2/s2 ] REAL(r8) :: wbrk(pcols,ncvmax) ! Net CL mean normalized TKE [ m2/s2 ] REAL(r8) :: lbrk(pcols,ncvmax) ! Net energetic integral thickness of CL [ m ] REAL(r8) :: ricl(pcols,ncvmax) ! Mean Richardson number of CL ( l2n2/l2s2 ) REAL(r8) :: ghcl(pcols,ncvmax) ! Half of normalized buoyancy production of CL REAL(r8) :: shcl(pcols,ncvmax) ! Instability function of heat and moisture of CL REAL(r8) :: smcl(pcols,ncvmax) ! Instability function of momentum of CL REAL(r8) :: leng(pcols,pver+1) ! Turbulent length scale [ m ], 0 at the surface. REAL(r8) :: wcap(pcols,pver+1) ! Normalized TKE [m2/s2], 'tkes/b1' at the surface and 'tke/b1' at ! the top/bottom entrainment interfaces of CL assuming no transport. ! ------------------------ ! ! Local Internal Variables ! ! ------------------------ ! LOGICAL :: belongcv(pcols,pver+1) ! True for interfaces in a CL (both interior and exterior are included) LOGICAL :: belongst(pcols,pver+1) ! True for stable turbulent layer interfaces (STL) LOGICAL :: in_CL ! True if interfaces k,k+1 both in same CL. LOGICAL :: extend ! True when CL is extended in zisocl LOGICAL :: extend_up ! True when CL is extended upward in zisocl LOGICAL :: extend_dn ! True when CL is extended downward in zisocl INTEGER :: i,m ! Longitude index INTEGER :: k ! Vertical index INTEGER :: ks ! Vertical index INTEGER :: ncvfin(pcols) ! Total number of CL in column INTEGER :: ncvf ! Total number of CL in column prior to adding SRCL INTEGER :: ncv ! Index of current CL INTEGER :: ncvnew ! Index of added SRCL appended after regular CLs from 'zisocl' INTEGER :: ncvsurf ! If nonzero, CL index based on surface (usually 1, but can be > 1 when SRCL is based at sfc) INTEGER :: kbase(pcols,ncvmax) ! Vertical index of CL base interface INTEGER :: ktop(pcols,ncvmax) ! Vertical index of CL top interface INTEGER :: kb, kt ! kbase and ktop for current CL INTEGER :: ktblw ! ktop of the CL located at just below the current CL INTEGER :: turbtype(pcols,pver+1) ! Interface turbulence type : ! 0 = Non turbulence interface ! 1 = Stable turbulence interface ! 2 = CL interior interface ( if bflxs > 0, sfc is this ) ! 3 = Bottom external interface of CL ! 4 = Top external interface of CL ! 5 = Double entraining CL external interface INTEGER :: ktopbl(pcols) ! PBL top height or interface index REAL(r8) :: bflxs(pcols) ! Surface buoyancy flux [ m2/s3 ] REAL(r8) :: rcap ! 'tke/ebrk' at all interfaces of CL. Set to 1 at the CL entrainment interfaces REAL(r8) :: jtzm ! Interface layer thickness of CL top interface [ m ] REAL(r8) :: jtsl ! Jump of s_l across CL top interface [ J/kg ] REAL(r8) :: jtqt ! Jump of q_t across CL top interface [ kg/kg ] REAL(r8) :: jtbu ! Jump of buoyancy across CL top interface [ m/s2 ] REAL(r8) :: jtu ! Jump of u across CL top interface [ m/s ] REAL(r8) :: jtv ! Jump of v across CL top interface [ m/s ] REAL(r8) :: jt2slv ! Jump of slv ( across two layers ) at CL top for use only in evhc [ J/kg ] REAL(r8) :: radf ! Buoyancy production at the CL top due to radiative cooling [ m2/s3 ] REAL(r8) :: jbzm ! Interface layer thickness of CL base interface [ m ] REAL(r8) :: jbsl ! Jump of s_l across CL base interface [ J/kg ] REAL(r8) :: jbqt ! Jump of q_t across CL top interface [ kg/kg ] REAL(r8) :: jbbu ! Jump of buoyancy across CL base interface [ m/s2 ] REAL(r8) :: jbu ! Jump of u across CL base interface [ m/s ] REAL(r8) :: jbv ! Jump of v across CL base interface [ m/s ] REAL(r8) :: ch ! Buoyancy coefficients defined at the CL top and base interfaces using CL internal REAL(r8) :: cm ! sfuh(kt) and sflh(kb-1) instead of sfi(kt) and sfi(kb), respectively. These are ! used for entrainment calculation at CL external interfaces and SRCL identification. REAL(r8) :: n2ht ! n2 defined at the CL top interface but using sfuh(kt) instead of sfi(kt) [ s-2 ] REAL(r8) :: n2hb ! n2 defined at the CL base interface but using sflh(kb-1) instead of sfi(kb) [ s-2 ] REAL(r8) :: n2htSRCL ! n2 defined at the upper-half layer of SRCL. This is used only for identifying SRCL. ! n2htSRCL use SRCL internal slope sl and qt as well as sfuh(kt) instead of sfi(kt) [ s-2 ] REAL(r8) :: gh ! Half of normalized buoyancy production ( -l2n2/2e ) [ no unit ] REAL(r8) :: sh ! Galperin instability function for heat and moisture REAL(r8) :: sm ! Galperin instability function for momentum REAL(r8) :: lbulk ! Depth of turbulent layer, Master length scale (not energetic length) REAL(r8) :: dzht ! Thickness of top half-layer [ m ] REAL(r8) :: dzhb ! Thickness of bottom half-layer [ m ] REAL(r8) :: rootp ! Sqrt(net CL-mean TKE including entrainment contribution) [ m/s ] REAL(r8) :: evhc ! Evaporative enhancement factor: (1+E) with E = evap. cool. efficiency [ no unit ] REAL(r8) :: kentr ! Effective entrainment diffusivity 'wet*dz', 'web*dz' [ m2/s ] REAL(r8) :: lwp ! Liquid water path in the layer kt [ kg/m2 ] REAL(r8) :: opt_depth ! Optical depth of the layer kt [ no unit ] REAL(r8) :: radinvfrac ! Fraction of LW cooling in the layer kt concentrated at the CL top [ no unit ] REAL(r8) :: wet ! CL top entrainment rate [ m/s ] REAL(r8) :: web ! CL bot entrainment rate [ m/s ]. Set to zero if CL is based at surface. REAL(r8) :: vyt ! n2ht/n2 at the CL top interface REAL(r8) :: vyb ! n2hb/n2 at the CL base interface REAL(r8) :: vut ! Inverse Ri (=s2/n2) at the CL top interface REAL(r8) :: vub ! Inverse Ri (=s2/n2) at the CL base interface REAL(r8) :: fact ! Factor relating TKE generation to entrainment [ no unit ] REAL(r8) :: trma ! Intermediate variables used for solving quadratic ( for gh from ri ) REAL(r8) :: trmb ! and cubic equations ( for ebrk: the net CL mean TKE ) REAL(r8) :: trmc ! REAL(r8) :: trmp ! REAL(r8) :: trmq ! REAL(r8) :: qq ! REAL(r8) :: det ! REAL(r8) :: gg ! Intermediate variable used for calculating stability functions of ! SRCL or SBCL based at the surface with bflxs > 0. REAL(r8) :: dzhb5 ! Half thickness of the bottom-most layer of current CL regime REAL(r8) :: dzht5 ! Half thickness of the top-most layer of adjacent CL regime just below current CL REAL(r8) :: qrlw(pcols,pver) ! Local grid-mean LW heating rate : [K/s] * cpair * dp = [ W/kg*Pa ] REAL(r8) :: cldeff(pcols,pver) ! Effective stratus fraction REAL(r8) :: qleff ! Used for computing evhc REAL(r8) :: tunlramp ! Ramping tunl REAL(r8) :: leng_imsi ! For Kv = max(Kv_STL, Kv_entrain) REAL(r8) :: tke_imsi ! REAL(r8) :: kvh_imsi ! REAL(r8) :: kvm_imsi ! REAL(r8) :: alph4exs ! For extended stability function in the stable regime REAL(r8) :: ghmin ! REAL(r8) :: sedfact ! For 'sedimentation-entrainment feedback' ! Local variables specific for 'wstar' entrainment closure REAL(r8) :: cet ! Proportionality coefficient between wet and wstar3 REAL(r8) :: ceb ! Proportionality coefficient between web and wstar3 REAL(r8) :: wstar ! Convective velocity for CL [ m/s ] REAL(r8) :: wstar3 ! Cubed convective velocity for CL [ m3/s3 ] REAL(r8) :: wstar3fact ! 1/(relative change of wstar^3 by entrainment) REAL(r8) :: rmin ! sqrt(p) REAL(r8) :: fmin ! f(rmin), where f(r) = r^3 - 3*p*r - 2q REAL(r8) :: rcrit ! ccrit*wstar REAL(r8) :: fcrit ! f(rcrit) LOGICAL noroot ! True if f(r) has no root r > rcrit !-----------------------! ! Start of Main Program ! !-----------------------! DO i = 1, ncol ipbl (i)=0.0_r8! If 1, PBL is CL, while if 0, PBL is STL. kpblh(i)=0.0_r8! Layer index containing PBL within or at the base interface pblh (i)=0.0_r8! PBL top height [ m ] pblhp(i)=0.0_r8! PBL top height pressure [ Pa ] tpert(i)=0.0_r8! Convective temperature excess [ K ] qpert(i)=0.0_r8! Convective humidity excess [ kg/kg ] wpert(i)=0.0_r8! Turbulent velocity excess [ m/s ] ktopbl(i) =0 ! PBL top height or interface index bflxs(i)=0.0_r8! Surface buoyancy flux [ m2/s3 ] ncvfin(i)=0 ! Total number of CL in column tkes(i) =0.0_r8 ! TKE at surface [ m2/s2 ] ncvfin_o(i)=0.0_r8! Original number of CLs just after 'exacol' ncvfin_mg(i)=0.0_r8! ncvfin just after extending-merging (after 'zisocl') but without SRCL ncvfin_f(i)=0.0_r8! Final ncvfin after adding SRCL END DO DO m = 1, ncvmax DO i = 1, ncol kbase (i,m) =0 ! Vertical index of CL base interface ktop (i,m) =0 ! Vertical index of CL top interface kbase_o (i,m) =0.0_r8! Original external base interface index of CL just after 'exacol' ktop_o (i,m) =0.0_r8! Original external top interface index of CL just after 'exacol' kbase_mg (i,m) =0.0_r8! kbase just after extending-merging (after 'zisocl') but without SRCL ktop_mg (i,m) =0.0_r8! ktop just after extending-merging (after 'zisocl') but without SRCL kbase_f (i,m) =0.0_r8! Final kbase after adding SRCL ktop_f (i,m) =0.0_r8! Final ktop after adding SRCL wet_CL (i,m) =0.0_r8! Entrainment rate at the CL top [ m/s ] web_CL (i,m) =0.0_r8! Entrainment rate at the CL base [ m/s ] jtbu_CL (i,m) =0.0_r8! Buoyancy jump across the CL top [ m/s2 ] jbbu_CL (i,m) =0.0_r8! Buoyancy jump across the CL base [ m/s2 ] evhc_CL (i,m) =0.0_r8! Evaporative enhancement factor at the CL top jt2slv_CL(i,m) =0.0_r8! Jump of slv ( across two layers ) at CL top for use only in evhc [ J/kg ] n2ht_CL (i,m) =0.0_r8! n2 defined at the CL top interface but using sfuh(kt) instead of sfi(kt) [ s-2 ] n2hb_CL (i,m) =0.0_r8! n2 defined at the CL base interface but using sflh(kb-1) instead of sfi(kb) [ s-2 ] lwp_CL (i,m) =0.0_r8! LWP in the CL top layer [ kg/m2 ] opt_depth_CL(i,m) =0.0_r8! Optical depth of the CL top layer radinvfrac_CL(i,m) =0.0_r8! Fraction of LW radiative cooling confined in the top portion of CL radf_CL(i,m) =0.0_r8! Buoyancy production at the CL top due to radiative cooling [ m2/s3 ] wstar_CL(i,m) =0.0_r8! Convective velocity of CL including entrainment contribution finally [ m/s ] wstar3fact_CL(i,m) =0.0_r8! "wstar3fact" of CL. Entrainment enhancement of wstar3 (inverse) ebrk(i,m) =0.0_r8! Net CL mean TKE [ m2/s2 ] wbrk(i,m) =0.0_r8! Net CL mean normalized TKE [ m2/s2 ] lbrk(i,m) =0.0_r8! Net energetic integral thickness of CL [ m ] ricl(i,m) =0.0_r8! Mean Richardson number of CL ( l2n2/l2s2 ) ghcl(i,m) =0.0_r8! Half of normalized buoyancy production of CL shcl(i,m) =0.0_r8! Instability function of heat and moisture of CL smcl(i,m) =0.0_r8! Instability function of momentum of CL END DO END DO !!!!!!!!!!!!!!!!!! ! 0. = Non turbulence interface ! 1. = Stable turbulence interface ! 2. = CL interior interface ( if bflxs > 0, surface is this ) ! 3. = Bottom external interface of CL ! 4. = Top external interface of CL. ! 5. = Double entraining CL external interface DO k = 1, pver+1 DO i = 1, ncol kvh (i,k)=0.0_r8! Eddy diffusivity for heat, moisture, and tracers [ m2/s ] kvm (i,k)=0.0_r8! Eddy diffusivity for momentum [ m2/s ] tke (i,k)=0.0_r8! Turbulent kinetic energy [ m2/s2 ], 'tkes' at surface, pver+1. bprod (i,k)=0.0_r8! Buoyancy production [ m2/s3 ],'bflxs' at surface, pver+1. sprod (i,k)=0.0_r8! Shear production [ m2/s3 ], (ustar(i)**3)/(vk*z(i,pver)) at surface, pver+1. turbtype_f(i,k)=0.0_r8! Turbulence type at each interface: sm_aw (i,k)=0.0_r8! Galperin instability function of momentum for use in the microphysics [ no unit ] turbtype (i,k)=0 ! Interface turbulence type : gh_a (i,k)=0.0_r8 ! Half of normalized buoyancy production, -l2n2/2e. [ no unit ] sh_a (i,k)=0.0_r8 ! Galperin instability function of heat-moisture at all interfaces [ no unit ] sm_a (i,k)=0.0_r8 ! Galperin instability function of momentum at all interfaces [ no unit ] ri_a (i,k)=0.0_r8 ! Interfacial Richardson number at all interfaces [ no unit ] leng (i,k)=0.0_r8! Turbulent length scale [ m ], 0 at the surface. wcap (i,k)=0.0_r8! Normalized TKE [m2/s2], 'tkes/b1' at the surface and 'tke/b1' at END DO END DO !!!!!!!!!!!!!!!!!! DO k = 1, pver DO i = 1, ncol qrlw (i,k)=0.0_r8! Local grid-mean LW heating rate : [K/s] * cpair * dp = [ W/kg*Pa ] cldeff(i,k)=0.0_r8! Effective stratus fraction END DO END DO ! the top/bottom entrainment interfaces of CL assuming no transport. ! ------------------------ ! ! Local Internal Variables ! ! ------------------------ ! ! LOGICAL :: belongcv(pcols,pver+1) ! True for interfaces in a CL (both interior and exterior are included) ! LOGICAL :: belongst(pcols,pver+1) ! True for stable turbulent layer interfaces (STL) ! LOGICAL :: in_CL ! True if interfaces k,k+1 both in same CL. ! LOGICAL :: extend ! True when CL is extended in zisocl ! LOGICAL :: extend_up ! True when CL is extended upward in zisocl ! LOGICAL :: extend_dn ! True when CL is extended downward in zisocl ! INTEGER :: i ! Longitude index ! INTEGER :: k ! Vertical index ! INTEGER :: ks ! Vertical index ncvf=0;ncv =0;ncvnew=0; ncvsurf =0;kb=0 ; kt =0;ktblw =0; rcap=0.0_r8;jtzm=0.0_r8; jtsl=0.0_r8;jtqt=0.0_r8;jtbu=0.0_r8;jtu=0.0_r8;jtv=0.0_r8;jt2slv=0.0_r8; radf=0.0_r8;jbzm=0.0_r8;jbsl=0.0_r8;jbqt=0.0_r8;jbbu=0.0_r8;jbu=0.0_r8; jbv=0.0_r8;ch=0.0_r8;cm=0.0_r8;n2ht=0.0_r8;n2hb=0.0_r8;n2htSRCL=0.0_r8; gh=0.0_r8;sh=0.0_r8;sm=0.0_r8;lbulk=0.0_r8;dzht=0.0_r8;dzhb=0.0_r8;rootp=0.0_r8; evhc=0.0_r8;kentr=0.0_r8;lwp=0.0_r8;opt_depth=0.0_r8;radinvfrac=0.0_r8;wet=0.0_r8; web=0.0_r8;vyt=0.0_r8;vyb=0.0_r8;vut=0.0_r8;vub=0.0_r8;fact=0.0_r8;trma=0.0_r8; trmb=0.0_r8;trmc=0.0_r8;trmp=0.0_r8;trmq=0.0_r8;qq=0.0_r8;det=0.0_r8;gg=0.0_r8;dzhb5=0.0_r8; dzht5=0.0_r8;qleff=0.0_r8;tunlramp=0.0_r8;leng_imsi=0.0_r8;tke_imsi=0.0_r8;kvh_imsi=0.0_r8; kvm_imsi=0.0_r8;alph4exs=0.0_r8;ghmin=0.0_r8;sedfact=0.0_r8;cet=0.0_r8;ceb=0.0_r8;wstar=0.0_r8; wstar3=0.0_r8;wstar3fact=0.0_r8;rmin=0.0_r8;fmin=0.0_r8;rcrit=0.0_r8;fcrit=0.0_r8; !---------- !------------------- ! Option: Turn-off LW radiative-turbulence interaction in PBL scheme ! by setting qrlw = 0. Logical parameter 'set_qrlzero' was ! defined in the first part of 'eddy_diff.F90' module. IF( set_qrlzero ) THEN qrlw(:,:) = 0._r8 ELSE DO k = 1, pver DO i = 1, ncol qrlw(i,k) = qrlin(i,k) END DO END DO ENDIF ! Define effective stratus fraction using the grid-mean ql. ! Modification : The contribution of ice should be carefully considered. ! This should be done in combination with the 'qrlw' and ! overlapping assumption of liquid and ice stratus. DO k = 1, pver DO i = 1, ncol IF( choice_evhc .EQ. 'ramp' .OR. choice_radf .EQ. 'ramp' ) THEN cldeff(i,k) = cld(i,k) * MIN( ql(i,k) / qmin(2), 1._r8 ) ELSE cldeff(i,k) = cld(i,k) ENDIF END DO END DO ! For an extended stability function in the stable regime, re-define ! alph4exe and ghmin. This is for future work. IF( ricrit .EQ. 0.19_r8 ) THEN alph4exs = alph4 ghmin = -3.5334_r8 ELSEIF( ricrit .GT. 0.19_r8 ) THEN alph4exs = -2._r8 * b1 * alph2 / ( alph3 - 2._r8 * b1 * alph5 ) / ricrit ghmin = -1.e10_r8 ELSE WRITE(iulog,*) 'Error : ricrit should be larger than 0.19 in UW PBL' STOP ENDIF ! ! Initialization of Diagnostic Output ! DO m = 1, ncvmax DO i = 1, ncol wet_CL(i,m) = 0._r8 web_CL(i,m) = 0._r8 jtbu_CL(i,m) = 0._r8 jbbu_CL(i,m) = 0._r8 evhc_CL(i,m) = 0._r8 jt2slv_CL(i,m) = 0._r8 n2ht_CL(i,m) = 0._r8 n2hb_CL(i,m) = 0._r8 lwp_CL(i,m) = 0._r8 opt_depth_CL(i,m) = 0._r8 radinvfrac_CL(i,m) = 0._r8 radf_CL(i,m) = 0._r8 wstar_CL(i,m) = 0._r8 wstar3fact_CL(i,m) = 0._r8 ricl(i,m) = 0._r8 ghcl(i,m) = 0._r8 shcl(i,m) = 0._r8 smcl(i,m) = 0._r8 ebrk(i,m) = 0._r8 wbrk(i,m) = 0._r8 lbrk(i,m) = 0._r8 END DO END DO DO k = 1, pver+1 DO i = 1, ncol gh_a(i,k) = 0._r8 sh_a(i,k) = 0._r8 sm_a(i,k) = 0._r8 ri_a(i,k) = 0._r8 sm_aw(i,k) = 0._r8 END DO END DO DO i = 1, ncol ipbl(i)= 0._r8 kpblh(i)= REAL(pver,r8) END DO ! kvh and kvm are stored over timesteps in 'vertical_diffusion.F90' and ! passed in as kvh_in and kvm_in. However, at the first timestep they ! need to be computed and these are done just before calling 'caleddy'. ! kvm and kvh are also stored over iterative time step in the first part ! of 'eddy_diff.F90' DO k = 1, pver + 1 DO i = 1, ncol ! Initialize kvh and kvm to zero or kvf IF( use_kvf ) THEN kvh(i,k) = kvf(i,k) kvm(i,k) = kvf(i,k) ELSE kvh(i,k) = 0._r8 kvm(i,k) = 0._r8 END IF ! Zero diagnostic quantities for the new diffusion step. wcap(i,k) = 0._r8 leng(i,k) = 0._r8 tke(i,k) = 0._r8 turbtype(i,k) = 0 END DO END DO ! Initialize 'bprod' [ m2/s3 ] and 'sprod' [ m2/s3 ] at all interfaces. ! Note this initialization is a hybrid initialization since 'n2' [s-2] and 's2' [s-2] ! are calculated from the given current initial profile, while 'kvh_in' [m2/s] and ! 'kvm_in' [m2/s] are from the previous iteration or previous time step. ! This initially guessed 'bprod' and 'sprod' will be updated at the end of this ! 'caleddy' subroutine for diagnostic output. ! This computation of 'brpod,sprod' below is necessary for wstar-based entrainment closure. DO k = 2, pver DO i = 1, ncol bprod(i,k) = -kvh_in(i,k) * n2(i,k) sprod(i,k) = kvm_in(i,k) * s2(i,k) END DO END DO ! Set 'bprod' and 'sprod' at top and bottom interface. ! In calculating 'surface' (actually lowest half-layer) buoyancy flux, ! 'chu' at surface is defined to be the same as 'chu' at the mid-point ! of lowest model layer (pver) at the end of 'trbind'. The same is for ! the other buoyancy coefficients. 'sprod(i,pver+1)' is defined in a ! consistent way as the definition of 'tkes' in the original code. ! ( Important Option ) If I want to isolate surface buoyancy flux from ! the other parts of CL regimes energetically even though bflxs > 0, ! all I should do is to re-define 'bprod(i,pver+1)=0' in the below 'do' ! block. Additionally for merging test of extending SBCL based on 'l2n2' ! in 'zisocl', I should use 'l2n2 = - wint / sh' for similar treatment ! as previous code. All other parts of the code are fully consistently ! treated by these change only. ! My future general convection scheme will use bflxs(i). DO i = 1, ncol bprod(i,1) = 0._r8 ! Top interface sprod(i,1) = 0._r8 ! Top interface ch = chu(i,pver+1) * ( 1._r8 - sflh(i,pver) ) + chs(i,pver+1) * sflh(i,pver) cm = cmu(i,pver+1) * ( 1._r8 - sflh(i,pver) ) + cms(i,pver+1) * sflh(i,pver) bflxs(i) = ch * shflx(i) * rrho(i) + cm * qflx(i) * rrho(i) IF( choice_tkes .EQ. 'ibprod' ) THEN bprod(i,pver+1) = bflxs(i) ELSE bprod(i,pver+1) = 0._r8 ENDIF sprod(i,pver+1) = (ustar(i)**3)/(vk*z(i,pver)) END DO ! Initially identify CL regimes in 'exacol' ! ktop : Interface index of the CL top external interface ! kbase : Interface index of the CL base external interface ! ncvfin: Number of total CLs ! Note that if surface buoyancy flux is positive ( bflxs = bprod(i,pver+1) > 0 ), ! surface interface is identified as an internal interface of CL. However, even ! though bflxs <= 0, if 'pver' interface is a CL internal interface (ri(pver)<0), ! surface interface is identified as an external interface of CL. If bflxs =< 0 ! and ri(pver) >= 0, then surface interface is identified as a stable turbulent ! intereface (STL) as shown at the end of 'caleddy'. Even though a 'minpblh' is ! passed into 'exacol', it is not used in the 'exacol'. CALL exacol( pcols, pver, ncol, ri, bflxs, minpblh, zi, ktop, kbase, ncvfin ) ! Diagnostic output of CL interface indices before performing 'extending-merging' ! of CL regimes in 'zisocl' DO i = 1, ncol DO k = 1, ncvmax kbase_o(i,k) = REAL(kbase(i,k),r8) ktop_o(i,k) = REAL(ktop(i,k),r8) ncvfin_o(i) = REAL(ncvfin(i),r8) END DO END DO ! ----------------------------------- ! ! Perform calculation for each column ! ! ----------------------------------- ! DO i = 1, ncol ! Define Surface Interfacial Layer TKE, 'tkes'. ! In the current code, 'tkes' is used as representing TKE of surface interfacial ! layer (low half-layer of surface-based grid layer). In the code, when bflxs>0, ! surface interfacial layer is assumed to be energetically coupled to the other ! parts of the CL regime based at the surface. In this sense, it is conceptually ! more reasonable to include both 'bprod' and 'sprod' in the definition of 'tkes'. ! Since 'tkes' cannot be negative, it is lower bounded by small positive number. ! Note that inclusion of 'bprod' in the definition of 'tkes' may increase 'ebrk' ! and 'wstar3', and eventually, 'wet' at the CL top, especially when 'bflxs>0'. ! This might help to solve the problem of too shallow PBLH over the overcast Sc ! regime. If I want to exclude 'bprod(i,pver+1)' in calculating 'tkes' even when ! bflxs > 0, all I should to do is to set 'bprod(i,pver+1) = 0' in the above ! initialization 'do' loop (explained above), NOT changing the formulation of ! tkes(i) in the below block. This is because for consistent treatment in the ! other parts of the code also. ! tkes(i) = (b1*vk*z(i,pver)*sprod(i,pver+1))**(2._r8/3._r8) tkes(i) = MAX(b1*vk*z(i,pver)*(bprod(i,pver+1)+sprod(i,pver+1)), 1.e-7_r8)**(2._r8/3._r8) tkes(i) = MIN(tkes(i), tkemax) tke(i,pver+1) = tkes(i) wcap(i,pver+1) = tkes(i)/b1 ! Extend and merge the initially identified CLs, relabel the CLs, and calculate ! CL internal mean energetics and stability functions in 'zisocl'. ! The CL nearest to the surface is CL(1) and the CL index, ncv, increases ! with height. The following outputs are from 'zisocl'. Here, the dimension ! of below outputs are (pcols,ncvmax) (except the 'ncvfin(pcols)' and ! 'belongcv(pcols,pver+1)) and 'ncv' goes from 1 to 'ncvfin'. ! For 'ncv = ncvfin+1, ncvmax', below output are already initialized to be zero. ! ncvfin : Total number of CLs ! kbase(ncv) : Base external interface index of CL ! ktop : Top external interface index of CL ! belongcv : True if the interface (either internal or external) is CL ! ricl : Mean Richardson number of internal CL ! ghcl : Normalized buoyancy production '-l2n2/2e' [no unit] of internal CL ! shcl : Galperin instability function of heat-moisture of internal CL ! smcl : Galperin instability function of momentum of internal CL ! lbrk, int : Thickness of (energetically) internal CL (lint, [m]) ! wbrk, int : Mean normalized TKE of internal CL ([m2/s2]) ! ebrk, int : Mean TKE of internal CL (b1*wbrk,[m2/s2]) ! The ncvsurf is an identifier saying which CL regime is based at the surface. ! If 'ncvsurf=1', then the first CL regime is based at the surface. If surface ! interface is not a part of CL (neither internal nor external), 'ncvsurf = 0'. ! After identifying and including SRCLs into the normal CL regimes (where newly ! identified SRCLs are simply appended to the normal CL regimes using regime ! indices of 'ncvfin+1','ncvfin+2' (as will be shown in the below SRCL part),.. ! where 'ncvfin' is the final CL regime index produced after extending-merging ! in 'zisocl' but before adding SRCLs), if any newly identified SRCL (e.g., ! 'ncvfin+1') is based at surface, then 'ncvsurf = ncvfin+1'. Thus 'ncvsurf' can ! be 0, 1, or >1. 'ncvsurf' can be a useful diagnostic output. ncvsurf = 0 IF( ncvfin(i) .GT. 0 ) THEN CALL zisocl( pcols , pver , i , & z , zi , n2 , s2 , & bprod , sprod , bflxs , tkes , landfrac,& ncvfin , kbase , ktop , belongcv, & ricl , ghcl , shcl , smcl , & lbrk , wbrk , ebrk , & extend , extend_up, extend_dn ) IF( kbase(i,1) .EQ. pver + 1 ) ncvsurf = 1 ELSE belongcv(i,:) = .FALSE. ENDIF ! Diagnostic output after finishing extending-merging process in 'zisocl' ! Since we are adding SRCL additionally, we need to print out these here. DO k = 1, ncvmax kbase_mg(i,k) = REAL(kbase(i,k)) ktop_mg(i,k) = REAL(ktop(i,k)) ncvfin_mg(i) = REAL(ncvfin(i)) END DO ! ----------------------- ! ! Identification of SRCLs ! ! ----------------------- ! ! Modification : This cannot identify the 'cirrus' layer due to the condition of ! ql(i,k) .gt. qmin. This should be modified in future to identify ! a single thin cirrus layer. ! Instead of ql, we may use cldn in future, including ice ! contribution. ! ------------------------------------------------------------------------------ ! ! Find single-layer radiatively-driven cloud-topped convective layers (SRCLs). ! ! SRCLs extend through a single model layer k, with entrainment at the top and ! ! bottom interfaces, unless bottom interface is the surface. ! ! The conditions for an SRCL is identified are: ! ! ! ! 1. Cloud in the layer, k : ql(i,k) .gt. qmin = 1.e-5 [ kg/kg ] ! ! 2. No cloud in the above layer (else assuming that some fraction of the LW ! ! flux divergence in layer k is concentrated at just below top interface ! ! of layer k is invalid). Then, this condition might be sensitive to the ! ! vertical resolution of grid. ! ! 3. LW radiative cooling (SW heating is assumed uniformly distributed through ! ! layer k, so not relevant to buoyancy production) in the layer k. However, ! ! SW production might also contribute, which may be considered in a future. ! ! 4. Internal stratification 'n2ht' of upper-half layer should be unstable. ! ! The 'n2ht' is pure internal stratification of upper half layer, obtained ! ! using internal slopes of sl, qt in layer k (in contrast to conventional ! ! interfacial slope) and saturation fraction in the upper-half layer, ! ! sfuh(k) (in contrast to sfi(k)). ! ! 5. Top and bottom interfaces not both in the same existing convective layer. ! ! If SRCL is within the previouisly identified CL regimes, we don't define ! ! a new SRCL. ! ! 6. k >= ntop_turb + 1 = 2 ! ! 7. Ri at the top interface > ricrit = 0.19 (otherwise turbulent mixing will ! ! broadly distribute the cloud top in the vertical, preventing localized ! ! radiative destabilization at the top interface). ! ! ! ! Note if 'k = pver', it identifies a surface-based single fog layer, possibly, ! ! warm advection fog. Note also the CL regime index of SRCLs itself increases ! ! with height similar to the regular CLs indices identified from 'zisocl'. ! ! ------------------------------------------------------------------------------ ! ncv = 1 ncvf = ncvfin(i) IF( choice_SRCL .EQ. 'remove' ) GOTO 222 DO k = nbot_turb, ntop_turb + 1, -1 ! 'k = pver, 2, -1' is a layer index. IF( ql(i,k) .GT. qmin(2) .AND. ql(i,k-1) .LT. qmin(2) .AND. qrlw(i,k) .LT. 0._r8 & .AND. ri(i,k) .GE. ricrit ) THEN ! In order to avoid any confliction with the treatment of ambiguous layer, ! I need to impose an additional constraint that ambiguous layer cannot be ! SRCL. So, I added constraint that 'k+1' interface (base interface of k ! layer) should not be a part of previously identified CL. Since 'belongcv' ! is even true for external entrainment interfaces, below constraint is ! fully sufficient. IF( choice_SRCL .EQ. 'nonamb' .AND. belongcv(i,k+1) ) THEN go to 220 ENDIF ch = ( 1._r8 - sfuh(i,k) ) * chu(i,k) + sfuh(i,k) * chs(i,k) cm = ( 1._r8 - sfuh(i,k) ) * cmu(i,k) + sfuh(i,k) * cms(i,k) n2htSRCL = ch * slslope(i,k) + cm * qtslope(i,k) IF( n2htSRCL .LE. 0._r8 ) THEN ! Test if bottom and top interfaces are part of the pre-existing CL. ! If not, find appropriate index for the new SRCL. Note that this ! calculation makes use of 'ncv set' obtained from 'zisocl'. The ! 'in_CL' is a parameter testing whether the new SRCL is already ! within the pre-existing CLs (.true.) or not (.false.). in_CL = .FALSE. DO WHILE ( ncv .LE. ncvf ) IF( ktop(i,ncv) .LE. k ) THEN IF( kbase(i,ncv) .GT. k ) THEN in_CL = .TRUE. ENDIF EXIT ! Exit from 'do while' loop if SRCL is within the CLs. ELSE ncv = ncv + 1 ! Go up one CL END IF END DO ! ncv IF( .NOT. in_CL ) THEN ! SRCL is not within the pre-existing CLs. ! Identify a new SRCL and add it to the pre-existing CL regime group. ncvfin(i) = ncvfin(i) + 1 ncvnew = ncvfin(i) ktop(i,ncvnew) = k kbase(i,ncvnew) = k+1 belongcv(i,k) = .TRUE. belongcv(i,k+1) = .TRUE. ! Calculate internal energy of SRCL. There is no internal energy if ! SRCL is elevated from the surface. Also, we simply assume neutral ! stability function. Note that this assumption of neutral stability ! does not influence numerical calculation- stability functions here ! are just for diagnostic output. In general SRCLs other than a SRCL ! based at surface with bflxs <= 0, there is no other way but to use ! neutral stability function. However, in case of SRCL based at the ! surface, we can explicitly calculate non-zero stability functions ! in a consistent way. Even though stability functions of SRCL are ! just diagnostic outputs not influencing numerical calculations, it ! would be informative to write out correct reasonable values rather ! than simply assuming neutral stability. I am doing this right now. ! Similar calculations were done for the SBCL and when surface inter ! facial layer was merged by overlying CL in 'ziscol'. IF( k .LT. pver ) THEN wbrk(i,ncvnew) = 0._r8 ebrk(i,ncvnew) = 0._r8 lbrk(i,ncvnew) = 0._r8 ghcl(i,ncvnew) = 0._r8 shcl(i,ncvnew) = 0._r8 smcl(i,ncvnew) = 0._r8 ricl(i,ncvnew) = 0._r8 ELSE ! Surface-based fog IF( bflxs(i) .GT. 0._r8 ) THEN ! Incorporate surface TKE into CL interior energy ! It is likely that this case cannot exist since ! if surface buoyancy flux is positive, it would ! have been identified as SBCL in 'zisocl' ahead. ebrk(i,ncvnew) = tkes(i) lbrk(i,ncvnew) = z(i,pver) wbrk(i,ncvnew) = tkes(i) / b1 WRITE(iulog,*) 'Major mistake in SRCL: bflxs > 0 for surface-based SRCL' WRITE(iulog,*) 'bflxs = ', bflxs(i) WRITE(iulog,*) 'ncvfin_o = ', ncvfin_o(i) WRITE(iulog,*) 'ncvfin_mg = ', ncvfin_mg(i) DO ks = 1, ncvmax WRITE(iulog,*) 'ncv =', ks, ' ', kbase_o(i,ks), ktop_o(i,ks), kbase_mg(i,ks), ktop_mg(i,ks) END DO STOP ELSE ! Don't incorporate surface interfacial TKE into CL interior energy ebrk(i,ncvnew) = 0._r8 lbrk(i,ncvnew) = 0._r8 wbrk(i,ncvnew) = 0._r8 ENDIF ! Calculate stability functions (ghcl, shcl, smcl, ricl) explicitly ! using an reverse procedure starting from tkes(i). Note that it is ! possible to calculate stability functions even when bflxs < 0. ! Previous code just assumed neutral stability functions. Note that ! since alph5 = 0.7 > 0, alph3 = -35 < 0, the denominator of gh is ! always positive if bflxs > 0. However, if bflxs < 0, denominator ! can be zero. For this case, we provide a possible maximum negative ! value (the most stable state) to gh. Note also tkes(i) is always a ! positive value by a limiter. Also, sprod(i,pver+1) > 0 by limiter. gg = 0.5_r8 * vk * z(i,pver) * bprod(i,pver+1) / ( tkes(i)**(3._r8/2._r8) ) IF( ABS(alph5-gg*alph3) .LE. 1.e-7_r8 ) THEN ! gh = -0.28_r8 ! gh = -3.5334_r8 gh = ghmin ELSE gh = gg / ( alph5 - gg * alph3 ) END IF ! gh = min(max(gh,-0.28_r8),0.0233_r8) ! gh = min(max(gh,-3.5334_r8),0.0233_r8) gh = MIN(MAX(gh,ghmin),0.0233_r8) ghcl(i,ncvnew) = gh shcl(i,ncvnew) = MAX(0._r8,alph5/(1._r8+alph3*gh)) smcl(i,ncvnew) = MAX(0._r8,(alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4exs*gh)) ricl(i,ncvnew) = -(smcl(i,ncvnew)/shcl(i,ncvnew))*(bprod(i,pver+1)/sprod(i,pver+1)) ! 'ncvsurf' is CL regime index based at the surface. If there is no ! such regime, then 'ncvsurf = 0'. ncvsurf = ncvnew END IF END IF END IF END IF 220 CONTINUE END DO ! End of 'k' loop where 'k' is a grid layer index running from 'pver' to 2 222 CONTINUE ! -------------------------------------------------------------------------- ! ! Up to this point, we identified all kinds of CL regimes : ! ! 1. A SBCL. By construction, 'bflxs > 0' for SBCL. ! ! 2. Surface-based CL with multiple layers and 'bflxs =< 0' ! ! 3. Surface-based CL with multiple layers and 'bflxs > 0' ! ! 4. Regular elevated CL with two entraining interfaces ! ! 5. SRCLs. If SRCL is based at surface, it will be bflxs < 0. ! ! '1-4' were identified from 'zisocl' while '5' were identified separately ! ! after performing 'zisocl'. CL regime index of '1-4' increases with height ! ! ( e.g., CL = 1 is the CL regime nearest to the surface ) while CL regime ! ! index of SRCL is simply appended after the final index of CL regimes from ! ! 'zisocl'. However, CL regime indices of SRCLs itself increases with height ! ! when there are multiple SRCLs, similar to the regular CLs from 'zisocl'. ! ! -------------------------------------------------------------------------- ! ! Diagnostic output of final CL regimes indices DO k = 1, ncvmax kbase_f(i,k) = REAL(kbase(i,k)) ktop_f(i,k) = REAL(ktop(i,k)) ncvfin_f(i) = REAL(ncvfin(i)) END DO ! ---------------------------------------- ! ! Perform do loop for individual CL regime ! ! ---------------------------------------- ! -------------------------------- ! ! For individual CLs, compute ! ! 1. Entrainment rates at the CL top and (if any) base interfaces using ! ! appropriate entrainment closure (current code use 'wstar' closure). ! ! 2. Net CL mean (i.e., including entrainment contribution) TKE (ebrk) ! ! and normalized TKE (wbrk). ! ! 3. TKE (tke) and normalized TKE (wcap) profiles at all CL interfaces. ! ! 4. ( kvm, kvh ) profiles at all CL interfaces. ! ! 5. ( bprod, sprod ) profiles at all CL interfaces. ! ! Also calculate ! ! 1. PBL height as the top external interface of surface-based CL, if any. ! ! 2. Characteristic excesses of convective 'updraft velocity (wpert)', ! ! 'temperature (tpert)', and 'moisture (qpert)' in the surface-based CL, ! ! if any, for use in the separate convection scheme. ! ! If there is no surface-based CL, 'PBL height' and 'convective excesses' are ! ! calculated later from surface-based STL (Stable Turbulent Layer) properties.! ! --------------------------------------------------------------------------- ! ktblw = 0 DO ncv = 1, ncvfin(i) kt = ktop(i,ncv) kb = kbase(i,ncv) ! Check whether surface interface is energetically interior or not. IF( kb .EQ. (pver+1) .AND. bflxs(i) .LE. 0._r8 ) THEN lbulk = zi(i,kt) - z(i,pver) ELSE lbulk = zi(i,kt) - zi(i,kb) END IF ! Calculate 'turbulent length scale (leng)' and 'normalized TKE (wcap)' ! at all CL interfaces except the surface. Note that below 'wcap' at ! external interfaces are not correct. However, it does not influence ! numerical calculation and correct normalized TKE at the entraining ! interfaces will be re-calculated at the end of this 'do ncv' loop. DO k = MIN(kb,pver), kt, -1 IF( choice_tunl .EQ. 'rampcl' ) THEN ! In order to treat the case of 'ricl(i,ncv) >> 0' of surface-based SRCL ! with 'bflxs(i) < 0._r8', I changed ricl(i,ncv) -> min(0._r8,ricl(i,ncv)) ! in the below exponential. This is necessary to prevent the model crash ! by too large values (e.g., 700) of ricl(i,ncv) tunlramp = ctunl*tunl*(1._r8-(1._r8-1._r8/ctunl)*EXP(MIN(0._r8,ricl(i,ncv)))) tunlramp = MIN(MAX(tunlramp,tunl),ctunl*tunl) ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = ctunl*tunl ! tunlramp = 0.765_r8 ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN leng(i,k) = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! leng(i,k) = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk)) ELSE leng(i,k) = MIN( vk*zi(i,k), tunlramp*lbulk ) ENDIF wcap(i,k) = (leng(i,k)**2) * (-shcl(i,ncv)*n2(i,k)+smcl(i,ncv)*s2(i,k)) END DO ! k ! Calculate basic cross-interface variables ( jump condition ) across the ! base external interface of CL. IF( kb .LT. pver+1 ) THEN jbzm = z(i,kb-1) - z(i,kb) ! Interfacial layer thickness [m] jbsl = sl(i,kb-1) - sl(i,kb) ! Interfacial jump of 'sl' [J/kg] jbqt = qt(i,kb-1) - qt(i,kb) ! Interfacial jump of 'qt' [kg/kg] jbbu = n2(i,kb) * jbzm ! Interfacial buoyancy jump [m/s2] considering saturation ( > 0 ) jbbu = MAX(jbbu,jbumin) ! Set minimum buoyancy jump, jbumin = 1.e-3 jbu = u(i,kb-1) - u(i,kb) ! Interfacial jump of 'u' [m/s] jbv = v(i,kb-1) - v(i,kb) ! Interfacial jump of 'v' [m/s] ch = (1._r8 -sflh(i,kb-1))*chu(i,kb) + sflh(i,kb-1)*chs(i,kb) ! Buoyancy coefficient just above the base interface cm = (1._r8 -sflh(i,kb-1))*cmu(i,kb) + sflh(i,kb-1)*cms(i,kb) ! Buoyancy coefficient just above the base interface n2hb = (ch*jbsl + cm*jbqt)/jbzm ! Buoyancy frequency [s-2] just above the base interface vyb = n2hb*jbzm/jbbu ! Ratio of 'n2hb/n2' at 'kb' interface vub = MIN(1._r8,(jbu**2+jbv**2)/(jbbu*jbzm) ) ! Ratio of 's2/n2 = 1/Ri' at 'kb' interface ELSE ! Below setting is necessary for consistent treatment when 'kb' is at the surface. jbbu = 0._r8 n2hb = 0._r8 vyb = 0._r8 vub = 0._r8 web = 0._r8 END IF ! Calculate basic cross-interface variables ( jump condition ) across the ! top external interface of CL. The meanings of variables are similar to ! the ones at the base interface. jtzm = z(i,kt-1) - z(i,kt) jtsl = sl(i,kt-1) - sl(i,kt) jtqt = qt(i,kt-1) - qt(i,kt) jtbu = n2(i,kt)*jtzm ! Note : 'jtbu' is guaranteed positive by definition of CL top. jtbu = MAX(jtbu,jbumin) ! But threshold it anyway to be sure. jtu = u(i,kt-1) - u(i,kt) jtv = v(i,kt-1) - v(i,kt) ch = (1._r8 -sfuh(i,kt))*chu(i,kt) + sfuh(i,kt)*chs(i,kt) cm = (1._r8 -sfuh(i,kt))*cmu(i,kt) + sfuh(i,kt)*cms(i,kt) n2ht = (ch*jtsl + cm*jtqt)/jtzm vyt = n2ht*jtzm/jtbu vut = MIN(1._r8,(jtu**2+jtv**2)/(jtbu*jtzm)) ! Evaporative enhancement factor of entrainment rate at the CL top interface, evhc. ! We take the full inversion strength to be 'jt2slv = slv(i,kt-2)-slv(i,kt)' ! where 'kt-1' is in the ambiguous layer. However, for a cloud-topped CL overlain ! by another CL, it is possible that 'slv(i,kt-2) < slv(i,kt)'. To avoid negative ! or excessive evhc, we lower-bound jt2slv and upper-bound evhc. Note 'jtslv' is ! used only for calculating 'evhc' : when calculating entrainment rate, we will ! use normal interfacial buoyancy jump across CL top interface. evhc = 1._r8 jt2slv = 0._r8 ! Modification : I should check whether below 'jbumin' produces reasonable limiting value. ! In addition, our current formulation does not consider ice contribution. IF( choice_evhc .EQ. 'orig' ) THEN IF( ql(i,kt) .GT. qmin(2) .AND. ql(i,kt-1) .LT. qmin(2) ) THEN jt2slv = slv(i,MAX(kt-2,1)) - slv(i,kt) jt2slv = MAX( jt2slv, jbumin*slv(i,kt-1)/g ) evhc = 1._r8 + a2l * a3l * latvap * ql(i,kt) / jt2slv evhc = MIN( evhc, evhcmax ) END IF ELSEIF( choice_evhc .EQ. 'ramp' ) THEN jt2slv = slv(i,MAX(kt-2,1)) - slv(i,kt) jt2slv = MAX( jt2slv, jbumin*slv(i,kt-1)/g ) evhc = 1._r8 + MAX(cldeff(i,kt)-cldeff(i,kt-1),0._r8) * a2l * a3l * latvap * ql(i,kt) / jt2slv evhc = MIN( evhc, evhcmax ) ELSEIF( choice_evhc .EQ. 'maxi' ) THEN qleff = MAX( ql(i,kt-1), ql(i,kt) ) jt2slv = slv(i,MAX(kt-2,1)) - slv(i,kt) jt2slv = MAX( jt2slv, jbumin*slv(i,kt-1)/g ) evhc = 1._r8 + a2l * a3l * latvap * qleff / jt2slv evhc = MIN( evhc, evhcmax ) ENDIF ! Calculate cloud-top radiative cooling contribution to buoyancy production. ! Here, 'radf' [m2/s3] is additional buoyancy flux at the CL top interface ! associated with cloud-top LW cooling being mainly concentrated near the CL ! top interface ( just below CL top interface ). Contribution of SW heating ! within the cloud is not included in this radiative buoyancy production ! since SW heating is more broadly distributed throughout the CL top layer. lwp = 0._r8 opt_depth = 0._r8 radinvfrac = 0._r8 radf = 0._r8 IF( choice_radf .EQ. 'orig' ) THEN IF( ql(i,kt) .GT. qmin(2) .AND. ql(i,kt-1) .LT. qmin(2) ) THEN lwp = ql(i,kt) * ( pi(i,kt+1) - pi(i,kt) ) / g opt_depth = 156._r8 * lwp ! Estimated LW optical depth in the CL top layer ! Approximate LW cooling fraction concentrated at the inversion by using ! polynomial approx to exact formula 1-2/opt_depth+2/(exp(opt_depth)-1)) radinvfrac = opt_depth * ( 4._r8 + opt_depth ) / ( 6._r8 * ( 4._r8 + opt_depth ) + opt_depth**2 ) radf = qrlw(i,kt) / ( pi(i,kt) - pi(i,kt+1) ) ! Cp*radiative cooling = [ W/kg ] radf = MAX( radinvfrac * radf * ( zi(i,kt) - zi(i,kt+1) ), 0._r8 ) * chs(i,kt) ! We can disable cloud LW cooling contribution to turbulence by uncommenting: ! radf = 0._r8 END IF ELSEIF( choice_radf .EQ. 'ramp' ) THEN lwp = ql(i,kt) * ( pi(i,kt+1) - pi(i,kt) ) / g opt_depth = 156._r8 * lwp ! Estimated LW optical depth in the CL top layer radinvfrac = opt_depth * ( 4._r8 + opt_depth ) / ( 6._r8 * ( 4._r8 + opt_depth ) + opt_depth**2 ) radinvfrac = MAX(cldeff(i,kt)-cldeff(i,kt-1),0._r8) * radinvfrac radf = qrlw(i,kt) / ( pi(i,kt) - pi(i,kt+1) ) ! Cp*radiative cooling [W/kg] radf = MAX( radinvfrac * radf * ( zi(i,kt) - zi(i,kt+1) ), 0._r8 ) * chs(i,kt) ELSEIF( choice_radf .EQ. 'maxi' ) THEN ! Radiative flux divergence both in 'kt' and 'kt-1' layers are included ! 1. From 'kt' layer lwp = ql(i,kt) * ( pi(i,kt+1) - pi(i,kt) ) / g opt_depth = 156._r8 * lwp ! Estimated LW optical depth in the CL top layer radinvfrac = opt_depth * ( 4._r8 + opt_depth ) / ( 6._r8 * ( 4._r8 + opt_depth ) + opt_depth**2 ) radf = MAX( radinvfrac * qrlw(i,kt) / ( pi(i,kt) - pi(i,kt+1) ) * ( zi(i,kt) - zi(i,kt+1) ), 0._r8 ) ! 2. From 'kt-1' layer and add the contribution from 'kt' layer lwp = ql(i,kt-1) * ( pi(i,kt) - pi(i,kt-1) ) / g opt_depth = 156._r8 * lwp ! Estimated LW optical depth in the CL top layer radinvfrac = opt_depth * ( 4._r8 + opt_depth ) / ( 6._r8 * ( 4._r8 + opt_depth) + opt_depth**2 ) radf = radf + MAX( radinvfrac * qrlw(i,kt-1) / ( pi(i,kt-1) - pi(i,kt) ) * & ( zi(i,kt-1) - zi(i,kt) ), 0.0_r8 ) radf = MAX( radf, 0._r8 ) * chs(i,kt) ENDIF ! ------------------------------------------------------------------- ! ! Calculate 'wstar3' by summing buoyancy productions within CL from ! ! 1. Interior buoyancy production ( bprod: fcn of TKE ) ! ! 2. Cloud-top radiative cooling ! ! 3. Surface buoyancy flux contribution only when bflxs > 0. ! ! Note that master length scale, lbulk, has already been ! ! corrctly defined at the first part of this 'do ncv' loop ! ! considering the sign of bflxs. ! ! This 'wstar3' is used for calculation of entrainment rate. ! ! Note that this 'wstar3' formula does not include shear production ! ! and the effect of drizzle, which should be included later. ! ! Q : Strictly speaking, in calculating interior buoyancy production, ! ! the use of 'bprod' is not correct, since 'bprod' is not correct ! ! value but initially guessed value. More reasonably, we should ! ! use '-leng(i,k)*sqrt(b1*wcap(i,k))*shcl(i,ncv)*n2(i,k)' instead ! ! of 'bprod(i,k)', although this is still an approximation since ! ! tke(i,k) is not exactly 'b1*wcap(i,k)' due to a transport term.! ! However since iterative calculation will be performed after all,! ! below might also be OK. But I should test this alternative. ! ! ------------------------------------------------------------------- ! dzht = zi(i,kt) - z(i,kt) ! Thickness of CL top half-layer dzhb = z(i,kb-1) - zi(i,kb) ! Thickness of CL bot half-layer wstar3 = radf * dzht DO k = kt + 1, kb - 1 ! If 'kt = kb - 1', this loop will not be performed. wstar3 = wstar3 + bprod(i,k) * ( z(i,k-1) - z(i,k) ) ! Below is an alternative which may speed up convergence. ! However, for interfaces merged into original CL, it can ! be 'wcap(i,k)<0' since 'n2(i,k)>0'. Thus, I should use ! the above original one. ! wstar3 = wstar3 - leng(i,k)*sqrt(b1*wcap(i,k))*shcl(i,ncv)*n2(i,k)* & ! (z(i,k-1) - z(i,k)) END DO IF( kb .EQ. (pver+1) .AND. bflxs(i) .GT. 0._r8 ) THEN wstar3 = wstar3 + bflxs(i) * dzhb ! wstar3 = wstar3 + bprod(i,pver+1) * dzhb END IF wstar3 = MAX( 2.5_r8 * wstar3, 0._r8 ) ! -------------------------------------------------------------- ! ! Below single block is for 'sedimentation-entrainment feedback' ! ! -------------------------------------------------------------- ! IF( id_sedfact ) THEN ! wsed = 7.8e5_r8*(ql(i,kt)/ncliq(i,kt))**(2._r8/3._r8) sedfact = EXP(-ased*wsedl(i,kt)/(wstar3**(1._r8/3._r8)+1.e-6)) IF( choice_evhc .EQ. 'orig' ) THEN IF (ql(i,kt).GT.qmin(2) .AND. ql(i,kt-1).LT.qmin(2)) THEN jt2slv = slv(i,MAX(kt-2,1)) - slv(i,kt) jt2slv = MAX(jt2slv, jbumin*slv(i,kt-1)/g) evhc = 1._r8+sedfact*a2l*a3l*latvap*ql(i,kt) / jt2slv evhc = MIN(evhc,evhcmax) END IF ELSEIF( choice_evhc .EQ. 'ramp' ) THEN jt2slv = slv(i,MAX(kt-2,1)) - slv(i,kt) jt2slv = MAX(jt2slv, jbumin*slv(i,kt-1)/g) evhc = 1._r8+MAX(cldeff(i,kt)-cldeff(i,kt-1),0._r8)*sedfact*a2l*a3l*latvap*ql(i,kt) / jt2slv evhc = MIN(evhc,evhcmax) ELSEIF( choice_evhc .EQ. 'maxi' ) THEN qleff = MAX(ql(i,kt-1),ql(i,kt)) jt2slv = slv(i,MAX(kt-2,1)) - slv(i,kt) jt2slv = MAX(jt2slv, jbumin*slv(i,kt-1)/g) evhc = 1._r8+sedfact*a2l*a3l*latvap*qleff / jt2slv evhc = MIN(evhc,evhcmax) ENDIF ENDIF ! -------------------------------------------------------------------------- ! ! Now diagnose CL top and bottom entrainment rates (and the contribution of ! ! top/bottom entrainments to wstar3) using entrainment closures of the form ! ! ! ! wet = cet*wstar3, web = ceb*wstar3 ! ! ! ! where cet and ceb depend on the entrainment interface jumps, ql, etc. ! ! No entrainment is diagnosed unless the wstar3 > 0. Note '1/wstar3fact' is ! ! a factor indicating the enhancement of wstar3 due to entrainment process. ! ! Q : Below setting of 'wstar3fact = max(..,0.5)'might prevent the possible ! ! case when buoyancy consumption by entrainment is stronger than cloud ! ! top radiative cooling production. Is that OK ? No. According to bulk ! ! modeling study, entrainment buoyancy consumption was always a certain ! ! fraction of other net productions, rather than a separate sum. Thus, ! ! below max limit of wstar3fact is correct. 'wstar3fact = max(.,0.5)' ! ! prevents unreasonable enhancement of CL entrainment rate by cloud-top ! ! entrainment instability, CTEI. ! ! Q : Use of the same dry entrainment coefficient, 'a1i' both at the CL top ! ! and base interfaces may result in too small 'wstar3' and 'ebrk' below, ! ! as was seen in my generalized bulk modeling study. This should be re- ! ! considered later ! ! -------------------------------------------------------------------------- ! IF( wstar3 .GT. 0._r8 ) THEN cet = a1i * evhc / ( jtbu * lbulk ) IF( kb .EQ. pver + 1 ) THEN wstar3fact = MAX( 1._r8 + 2.5_r8 * cet * n2ht * jtzm * dzht, wstar3factcrit ) ELSE ceb = a1i / ( jbbu * lbulk ) wstar3fact = MAX( 1._r8 + 2.5_r8 * cet * n2ht * jtzm * dzht & + 2.5_r8 * ceb * n2hb * jbzm * dzhb, wstar3factcrit ) END IF wstar3 = wstar3 / wstar3fact ELSE ! wstar3 == 0 wstar3fact = 0._r8 ! This is just for dianostic output cet = 0._r8 ceb = 0._r8 END IF ! ---------------------------------------------------------------------------- ! ! Calculate net CL mean TKE including entrainment contribution by solving a ! ! canonical cubic equation. The solution of cubic equ. is 'rootp**2 = ebrk' ! ! where 'ebrk' originally (before solving cubic eq.) was interior CL mean TKE, ! ! but after solving cubic equation, it is replaced by net CL mean TKE in the ! ! same variable 'ebrk'. ! ! ---------------------------------------------------------------------------- ! ! Solve cubic equation (canonical form for analytic solution) ! ! r^3 - 3*trmp*r - 2*trmq = 0, r = sqrt ! ! to estimate for CL, derived from layer-mean TKE balance: ! ! ! ! ^(3/2)/(b_1*) \approx (*) ! ! = (_int * l_int + _et * dzt + _eb * dzb)/lbulk ! ! _int = ^(1/2)/(b_1*)*_int ! ! _et = (-vyt+vut)*wet*jtbu + radf ! ! _eb = (-vyb+vub)*web*jbbu ! ! ! ! where: ! ! <> denotes a vertical avg (over the whole CL unless indicated) ! ! l_int (called lbrk below) is aggregate thickness of interior CL layers ! ! dzt = zi(i,kt)-z(i,kt) is thickness of top entrainment layer ! ! dzb = z(i,kb-1)-zi(i,kb) is thickness of bot entrainment layer ! ! _int (called ebrk below) is the CL-mean TKE if only interior ! ! interfaces contributed. ! ! wet, web are top. bottom entrainment rates ! ! ! ! For a single-level radiatively-driven convective layer, there are no ! ! interior interfaces so 'ebrk' = 'lbrk' = 0. If the CL goes to the ! ! surface, 'vyb' and 'vub' are set to zero before and 'ebrk' and 'lbrk' ! ! have already incorporated the surface interfacial layer contribution, ! ! so the same formulas still apply. ! ! ! ! In the original formulation based on TKE, ! ! wet*jtbu = a1l*evhc*^3/2/leng(i,kt) ! ! web*jbbu = a1l*^3/2/leng(i,kt) ! ! ! ! In the wstar formulation ! ! wet*jtbu = a1i*evhc*wstar3/lbulk ! ! web*jbbu = a1i*wstar3/lbulk, ! ! ---------------------------------------------------------------------------- ! fact = ( evhc * ( -vyt + vut ) * dzht + ( -vyb + vub ) * dzhb * leng(i,kb) / leng(i,kt) ) / lbulk IF( wstarent ) THEN ! (Option 1) 'wstar' entrainment formulation ! Here trmq can have either sign, and will usually be nonzero even for non- ! cloud topped CLs. If trmq > 0, there will be two positive roots r; we take ! the larger one. Why ? If necessary, we limit entrainment and wstar to prevent ! a solution with r < ccrit*wstar ( Why ? ) where we take ccrit = 0.5. trma = 1._r8 trmp = ebrk(i,ncv) * ( lbrk(i,ncv) / lbulk ) / 3._r8 + ntzero trmq = 0.5_r8 * b1 * ( leng(i,kt) / lbulk ) * ( radf * dzht + a1i * fact * wstar3 ) ! Check if there is an acceptable root with r > rcrit = ccrit*wstar. ! To do this, first find local minimum fmin of the cubic f(r) at sqrt(p), ! and value fcrit = f(rcrit). rmin = SQRT(trmp) fmin = rmin * ( rmin * rmin - 3._r8 * trmp ) - 2._r8 * trmq wstar = wstar3**onet rcrit = ccrit * wstar fcrit = rcrit * ( rcrit * rcrit - 3._r8 * trmp ) - 2._r8 * trmq ! No acceptable root exists (noroot = .true.) if either: ! 1) rmin < rcrit (in which case cubic is monotone increasing for r > rcrit) ! and f(rcrit) > 0. ! or 2) rmin > rcrit (in which case min of f(r) in r > rcrit is at rmin) ! and f(rmin) > 0. ! In this case, we reduce entrainment and wstar3 such that r/wstar = ccrit; ! this changes the coefficients of the cubic. It might be informative to ! check when and how many 'noroot' cases occur, since when 'noroot', we ! will impose arbitrary limit on 'wstar3, wet, web, and ebrk' using ccrit. noroot = ( ( rmin .LT. rcrit ) .AND. ( fcrit .GT. 0._r8 ) ) & .OR. ( ( rmin .GE. rcrit ) .AND. ( fmin .GT. 0._r8 ) ) IF( noroot ) THEN ! Solve cubic for r trma = 1._r8 - b1 * ( leng(i,kt) / lbulk ) * a1i * fact / ccrit**3 trma = MAX( trma, 0.5_r8 ) ! Limit entrainment enhancement of ebrk trmp = trmp / trma trmq = 0.5_r8 * b1 * ( leng(i,kt) / lbulk ) * radf * dzht / trma END IF ! noroot ! Solve the cubic equation qq = trmq**2 - trmp**3 IF( qq .GE. 0._r8 ) THEN rootp = ( trmq + SQRT(qq) )**(1._r8/3._r8) + ( MAX( trmq - SQRT(qq), 0._r8 ) )**(1._r8/3._r8) ELSE rootp = 2._r8 * SQRT(trmp) * COS( ACOS( trmq / SQRT(trmp**3) ) / 3._r8 ) END IF ! Adjust 'wstar3' only if there is 'noroot'. ! And calculate entrainment rates at the top and base interfaces. IF( noroot ) wstar3 = ( rootp / ccrit )**3 ! Adjust wstar3 wet = cet * wstar3 ! Find entrainment rates IF( kb .LT. pver + 1 ) web = ceb * wstar3 ! When 'kb.eq.pver+1', it was set to web=0. ELSE ! ! (Option.2) wstarentr = .false. Use original entrainment formulation. ! trmp > 0 if there are interior interfaces in CL, trmp = 0 otherwise. ! trmq > 0 if there is cloudtop radiative cooling, trmq = 0 otherwise. trma = 1._r8 - b1 * a1l * fact trma = MAX( trma, 0.5_r8 ) ! Prevents runaway entrainment instability trmp = ebrk(i,ncv) * ( lbrk(i,ncv) / lbulk ) / ( 3._r8 * trma ) trmq = 0.5_r8 * b1 * ( leng(i,kt) / lbulk ) * radf * dzht / trma qq = trmq**2 - trmp**3 IF( qq .GE. 0._r8 ) THEN rootp = ( trmq + SQRT(qq) )**(1._r8/3._r8) + ( MAX( trmq - SQRT(qq), 0._r8 ) )**(1._r8/3._r8) ELSE ! Also part of case 3 rootp = 2._r8 * SQRT(trmp) * COS( ACOS( trmq / SQRT(trmp**3) ) / 3._r8 ) END IF ! qq ! Find entrainment rates and limit them by free-entrainment values a1l*sqrt(e) wet = a1l * rootp * MIN( evhc * rootp**2 / ( leng(i,kt) * jtbu ), 1._r8 ) IF( kb .LT. pver + 1 ) web = a1l * rootp * MIN( evhc * rootp**2 / ( leng(i,kb) * jbbu ), 1._r8 ) END IF ! wstarentr ! ---------------------------------------------------- ! ! Finally, get the net CL mean TKE and normalized TKE ! ! ---------------------------------------------------- ! ebrk(i,ncv) = rootp**2 ebrk(i,ncv) = MIN(ebrk(i,ncv),tkemax) ! Limit CL-avg TKE used for entrainment wbrk(i,ncv) = ebrk(i,ncv)/b1 ! The only way ebrk = 0 is for SRCL which are actually radiatively cooled ! at top interface. In this case, we remove 'convective' label from the ! interfaces around this layer. This case should now be impossible, so ! we flag it. Q: I can't understand why this case is impossible now. Maybe, ! due to various limiting procedures used in solving cubic equation ? ! In case of SRCL, 'ebrk' should be positive due to cloud top LW radiative ! cooling contribution, although 'ebrk(internal)' of SRCL before including ! entrainment contribution (which include LW cooling contribution also) is ! zero. IF( ebrk(i,ncv) .LE. 0._r8 ) THEN WRITE(iulog,*) 'CALEDDY: Warning, CL with zero TKE, i, kt, kb ', i, kt, kb belongcv(i,kt) = .FALSE. belongcv(i,kb) = .FALSE. END IF ! ----------------------------------------------------------------------- ! ! Calculate complete TKE profiles at all CL interfaces, capped by tkemax. ! ! We approximate TKE = at entrainment interfaces. However when CL is ! ! based at surface, correct 'tkes' will be inserted to tke(i,pver+1). ! ! Note that this approximation at CL external interfaces do not influence ! ! numerical calculation since 'e' at external interfaces are not used in ! ! actual numerical calculation afterward. In addition in order to extract ! ! correct TKE averaged over the PBL in the cumulus scheme,it is necessary ! ! to set e = at the top entrainment interface. Since net CL mean TKE ! ! 'ebrk' obtained by solving cubic equation already includes tkes ( tkes ! ! is included when bflxs > 0 but not when bflxs <= 0 into internal ebrk ),! ! 'tkes' should be written to tke(i,pver+1) ! ! ----------------------------------------------------------------------- ! ! 1. At internal interfaces DO k = kb - 1, kt + 1, -1 rcap = ( b1 * ae + wcap(i,k) / wbrk(i,ncv) ) / ( b1 * ae + 1._r8 ) rcap = MIN( MAX(rcap,rcapmin), rcapmax ) tke(i,k) = ebrk(i,ncv) * rcap tke(i,k) = MIN( tke(i,k), tkemax ) kvh(i,k) = leng(i,k) * SQRT(tke(i,k)) * shcl(i,ncv) kvm(i,k) = leng(i,k) * SQRT(tke(i,k)) * smcl(i,ncv) bprod(i,k) = -kvh(i,k) * n2(i,k) sprod(i,k) = kvm(i,k) * s2(i,k) turbtype(i,k) = 2 ! CL interior interfaces. sm_aw(i,k) = smcl(i,ncv)/alph1 ! Diagnostic output for microphysics END DO ! 2. At CL top entrainment interface kentr = wet * jtzm kvh(i,kt) = kentr kvm(i,kt) = kentr bprod(i,kt) = -kentr * n2ht + radf ! I must use 'n2ht' not 'n2' sprod(i,kt) = kentr * s2(i,kt) turbtype(i,kt) = 4 ! CL top entrainment interface trmp = -b1 * ae / ( 1._r8 + b1 * ae ) trmq = -(bprod(i,kt)+sprod(i,kt))*b1*leng(i,kt)/(1._r8+b1*ae)/(ebrk(i,ncv)**(3._r8/2._r8)) rcap = compute_cubic(0._r8,trmp,trmq)**2._r8 rcap = MIN( MAX(rcap,rcapmin), rcapmax ) tke(i,kt) = ebrk(i,ncv) * rcap tke(i,kt) = MIN( tke(i,kt), tkemax ) sm_aw(i,kt) = smcl(i,ncv) / alph1 ! Diagnostic output for microphysics ! 3. At CL base entrainment interface and double entraining interfaces ! When current CL base is also the top interface of CL regime below, ! simply add the two contributions for calculating eddy diffusivity ! and buoyancy/shear production. Below code correctly works because ! we (CL regime index) always go from surface upward. IF( kb .LT. pver + 1 ) THEN kentr = web * jbzm IF( kb .NE. ktblw ) THEN kvh(i,kb) = kentr kvm(i,kb) = kentr bprod(i,kb) = -kvh(i,kb)*n2hb ! I must use 'n2hb' not 'n2' sprod(i,kb) = kvm(i,kb)*s2(i,kb) turbtype(i,kb) = 3 ! CL base entrainment interface trmp = -b1*ae/(1._r8+b1*ae) trmq = -(bprod(i,kb)+sprod(i,kb))*b1*leng(i,kb)/(1._r8+b1*ae)/(ebrk(i,ncv)**(3._r8/2._r8)) rcap = compute_cubic(0._r8,trmp,trmq)**2._r8 rcap = MIN( MAX(rcap,rcapmin), rcapmax ) tke(i,kb) = ebrk(i,ncv) * rcap tke(i,kb) = MIN( tke(i,kb),tkemax ) ELSE kvh(i,kb) = kvh(i,kb) + kentr kvm(i,kb) = kvm(i,kb) + kentr ! dzhb5 : Half thickness of the lowest layer of current CL regime ! dzht5 : Half thickness of the highest layer of adjacent CL regime just below current CL. dzhb5 = z(i,kb-1) - zi(i,kb) dzht5 = zi(i,kb) - z(i,kb) bprod(i,kb) = ( dzht5*bprod(i,kb) - dzhb5*kentr*n2hb ) / ( dzhb5 + dzht5 ) sprod(i,kb) = ( dzht5*sprod(i,kb) + dzhb5*kentr*s2(i,kb) ) / ( dzhb5 + dzht5 ) trmp = -b1*ae/(1._r8+b1*ae) trmq = -kentr*(s2(i,kb)-n2hb)*b1*leng(i,kb)/(1._r8+b1*ae)/(ebrk(i,ncv)**(3._r8/2._r8)) rcap = compute_cubic(0._r8,trmp,trmq)**2._r8 rcap = MIN( MAX(rcap,rcapmin), rcapmax ) tke_imsi = ebrk(i,ncv) * rcap tke_imsi = MIN( tke_imsi, tkemax ) tke(i,kb) = ( dzht5*tke(i,kb) + dzhb5*tke_imsi ) / ( dzhb5 + dzht5 ) tke(i,kb) = MIN(tke(i,kb),tkemax) turbtype(i,kb) = 5 ! CL double entraining interface END IF ELSE ! If CL base interface is surface, compute similarly using wcap(i,kb)=tkes/b1 ! Even when bflx < 0, use the same formula in order to impose consistency of ! tke(i,kb) at bflx = 0._r8 rcap = (b1*ae + wcap(i,kb)/wbrk(i,ncv))/(b1*ae + 1._r8) rcap = MIN( MAX(rcap,rcapmin), rcapmax ) tke(i,kb) = ebrk(i,ncv) * rcap tke(i,kb) = MIN( tke(i,kb),tkemax ) END IF ! For double entraining interface, simply use smcl(i,ncv) of the overlying CL. ! Below 'sm_aw' is a diagnostic output for use in the microphysics. ! When 'kb' is surface, 'sm' will be over-written later below. sm_aw(i,kb) = smcl(i,ncv)/alph1 ! Calculate wcap at all interfaces of CL. Put a minimum threshold on TKE ! to prevent possible division by zero. 'wcap' at CL internal interfaces ! are already calculated in the first part of 'do ncv' loop correctly. ! When 'kb.eq.pver+1', below formula produces the identical result to the ! 'tkes(i)/b1' if leng(i,kb) is set to vk*z(i,pver). Note wcap(i,pver+1) ! is already defined as 'tkes(i)/b1' at the first part of caleddy. wcap(i,kt) = (bprod(i,kt)+sprod(i,kt))*leng(i,kt)/SQRT(MAX(tke(i,kt),1.e-6_r8)) IF( kb .LT. pver + 1 ) THEN wcap(i,kb) = (bprod(i,kb)+sprod(i,kb))*leng(i,kb)/SQRT(MAX(tke(i,kb),1.e-6_r8)) END IF ! Save the index of upper external interface of current CL-regime in order to ! handle the case when this interface is also the lower external interface of ! CL-regime located just above. ktblw = kt ! Diagnostic Output wet_CL(i,ncv) = wet web_CL(i,ncv) = web jtbu_CL(i,ncv) = jtbu jbbu_CL(i,ncv) = jbbu evhc_CL(i,ncv) = evhc jt2slv_CL(i,ncv) = jt2slv n2ht_CL(i,ncv) = n2ht n2hb_CL(i,ncv) = n2hb lwp_CL(i,ncv) = lwp opt_depth_CL(i,ncv) = opt_depth radinvfrac_CL(i,ncv) = radinvfrac radf_CL(i,ncv) = radf wstar_CL(i,ncv) = wstar wstar3fact_CL(i,ncv) = wstar3fact END DO ! ncv ! Calculate PBL height and characteristic cumulus excess for use in the ! cumulus convection shceme. Also define turbulence type at the surface ! when the lowest CL is based at the surface. These are just diagnostic ! outputs, not influencing numerical calculation of current PBL scheme. ! If the lowest CL is based at the surface, define the PBL depth as the ! CL top interface. The same rule is applied for all CLs including SRCL. IF( ncvsurf .GT. 0 ) THEN ktopbl(i) = ktop(i,ncvsurf) pblh(i) = zi(i, ktopbl(i)) pblhp(i) = pi(i, ktopbl(i)) wpert(i) = MAX(wfac*SQRT(ebrk(i,ncvsurf)),wpertmin) tpert(i) = MAX(ABS(shflx(i)*rrho(i)/cpair)*tfac/wpert(i),0._r8) qpert(i) = MAX(ABS(qflx(i)*rrho(i))*tfac/wpert(i),0._r8) IF( bflxs(i) .GT. 0._r8 ) THEN turbtype(i,pver+1) = 2 ! CL interior interface ELSE turbtype(i,pver+1) = 3 ! CL external base interface ENDIF ipbl(i) = 1._r8 kpblh(i) = ktopbl(i) - 1._r8 END IF ! End of the calculationf of te properties of surface-based CL. ! -------------------------------------------- ! ! Treatment of Stable Turbulent Regime ( STL ) ! ! -------------------------------------------- ! ! Identify top and bottom most (internal) interfaces of STL except surface. ! Also, calculate 'turbulent length scale (leng)' at each STL interfaces. belongst(i,1) = .FALSE. ! k = 1 (top interface) is assumed non-turbulent DO k = 2, pver ! k is an interface index belongst(i,k) = ( ri(i,k) .LT. ricrit ) .AND. ( .NOT. belongcv(i,k) ) IF( belongst(i,k) .AND. ( .NOT. belongst(i,k-1) ) ) THEN kt = k ! Top interface index of STL ELSEIF( .NOT. belongst(i,k) .AND. belongst(i,k-1) ) THEN kb = k - 1 ! Base interface index of STL lbulk = z(i,kt-1) - z(i,kb) DO ks = kt, kb IF( choice_tunl .EQ. 'rampcl' ) THEN tunlramp = tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = MAX( 1.e-3_r8, ctunl * tunl * EXP(-LOG(ctunl)*ri(i,ks)/ricrit) ) ! tunlramp = 0.065_r8 + 0.7_r8 * exp(-20._r8*ri(i,ks)) ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN leng(i,ks) = ( (vk*zi(i,ks))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! leng(i,ks) = vk*zi(i,ks) / (1._r8+vk*zi(i,ks)/(tunlramp*lbulk)) ELSE leng(i,ks) = MIN( vk*zi(i,ks), tunlramp*lbulk ) ENDIF END DO END IF END DO ! k ! Now look whether STL extends to ground. If STL extends to surface, ! re-define master length scale,'lbulk' including surface interfacial ! layer thickness, and re-calculate turbulent length scale, 'leng' at ! all STL interfaces again. Note that surface interface is assumed to ! always be STL if it is not CL. belongst(i,pver+1) = .NOT. belongcv(i,pver+1) IF( belongst(i,pver+1) ) THEN ! kb = pver+1 (surface STL) turbtype(i,pver+1) = 1 ! Surface is STL interface IF( belongst(i,pver) ) THEN ! STL includes interior ! 'kt' already defined above as the top interface of STL lbulk = z(i,kt-1) ELSE ! STL with no interior turbulence kt = pver+1 lbulk = z(i,kt-1) END IF ! PBL height : Layer mid-point just above the highest STL interface ! Note in contrast to the surface based CL regime where PBL height ! was defined at the top external interface, PBL height of surface ! based STL is defined as the layer mid-point. ktopbl(i) = kt - 1 pblh(i) = z(i,ktopbl(i)) pblhp(i) = 0.5_r8 * ( pi(i,ktopbl(i)) + pi(i,ktopbl(i)+1) ) ! Re-calculate turbulent length scale including surface interfacial ! layer contribution to lbulk. DO ks = kt, pver IF( choice_tunl .EQ. 'rampcl' ) THEN tunlramp = tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = MAX(1.e-3_r8,ctunl*tunl*EXP(-LOG(ctunl)*ri(i,ks)/ricrit)) ! tunlramp = 0.065_r8 + 0.7_r8 * exp(-20._r8*ri(i,ks)) ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN leng(i,ks) = ( (vk*zi(i,ks))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! leng(i,ks) = vk*zi(i,ks) / (1._r8+vk*zi(i,ks)/(tunlramp*lbulk)) ELSE leng(i,ks) = MIN( vk*zi(i,ks), tunlramp*lbulk ) ENDIF END DO ! ks ! Characteristic cumulus excess of surface-based STL. ! We may be able to use ustar for wpert. wpert(i) = 0._r8 tpert(i) = MAX(shflx(i)*rrho(i)/cpair*fak/ustar(i),0._r8) ! CCM stable-layer forms qpert(i) = MAX(qflx(i)*rrho(i)*fak/ustar(i),0._r8) ipbl(i) = 0._r8 kpblh(i) = ktopbl(i) END IF ! Calculate stability functions and energetics at the STL interfaces ! except the surface. Note that tke(i,pver+1) and wcap(i,pver+1) are ! already calculated in the first part of 'caleddy', kvm(i,pver+1) & ! kvh(i,pver+1) were already initialized to be zero, bprod(i,pver+1) ! & sprod(i,pver+1) were direcly calculated from the bflxs and ustar. ! Note transport term is assumed to be negligible at STL interfaces. DO k = 2, pver IF( belongst(i,k) ) THEN turbtype(i,k) = 1 ! STL interfaces trma = alph3*alph4exs*ri(i,k) + 2._r8*b1*(alph2-alph4exs*alph5*ri(i,k)) trmb = (alph3+alph4exs)*ri(i,k) + 2._r8*b1*(-alph5*ri(i,k)+alph1) trmc = ri(i,k) det = MAX(trmb*trmb-4._r8*trma*trmc,0._r8) ! Sanity Check IF( det .LT. 0._r8 ) THEN WRITE(iulog,*) 'The det < 0. for the STL in UW eddy_diff' STOP END IF gh = (-trmb + SQRT(det))/(2._r8*trma) ! gh = min(max(gh,-0.28_r8),0.0233_r8) ! gh = min(max(gh,-3.5334_r8),0.0233_r8) gh = MIN(MAX(gh,ghmin),0.0233_r8) sh = MAX(0._r8,alph5/(1._r8+alph3*gh)) sm = MAX(0._r8,(alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4exs*gh)) tke(i,k) = b1*(leng(i,k)**2)*(-sh*n2(i,k)+sm*s2(i,k)) tke(i,k) = MIN(tke(i,k),tkemax) wcap(i,k) = tke(i,k)/b1 kvh(i,k) = leng(i,k) * SQRT(tke(i,k)) * sh kvm(i,k) = leng(i,k) * SQRT(tke(i,k)) * sm bprod(i,k) = -kvh(i,k) * n2(i,k) sprod(i,k) = kvm(i,k) * s2(i,k) sm_aw(i,k) = sm/alph1 ! This is diagnostic output for use in the microphysics END IF END DO ! k ! --------------------------------------------------- ! ! End of treatment of Stable Turbulent Regime ( STL ) ! ! --------------------------------------------------- ! ! --------------------------------------------------------------- ! ! Re-computation of eddy diffusivity at the entrainment interface ! ! assuming that it is purely STL (00.19, ! ! turbulent can exist at the entrainment interface since 'Sh,Sm' ! ! do not necessarily go to zero even when Ri>0.19. Since Ri can ! ! be fairly larger than 0.19 at the entrainment interface, I ! ! should set minimum value of 'tke' to be 0. in order to prevent ! ! sqrt(tke) from being imaginary. ! ! --------------------------------------------------------------- ! ! goto 888 DO k = 2, pver IF( ( turbtype(i,k) .EQ. 3 ) .OR. ( turbtype(i,k) .EQ. 4 ) .OR. & ( turbtype(i,k) .EQ. 5 ) ) THEN trma = alph3*alph4exs*ri(i,k) + 2._r8*b1*(alph2-alph4exs*alph5*ri(i,k)) trmb = (alph3+alph4exs)*ri(i,k) + 2._r8*b1*(-alph5*ri(i,k)+alph1) trmc = ri(i,k) det = MAX(trmb*trmb-4._r8*trma*trmc,0._r8) gh = (-trmb + SQRT(det))/(2._r8*trma) ! gh = min(max(gh,-0.28_r8),0.0233_r8) ! gh = min(max(gh,-3.5334_r8),0.0233_r8) gh = MIN(MAX(gh,ghmin),0.0233_r8) sh = MAX(0._r8,alph5/(1._r8+alph3*gh)) sm = MAX(0._r8,(alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4exs*gh)) lbulk = z(i,k-1) - z(i,k) IF( choice_tunl .EQ. 'rampcl' ) THEN tunlramp = tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = MAX(1.e-3_r8,ctunl*tunl*EXP(-LOG(ctunl)*ri(i,k)/ricrit)) ! tunlramp = 0.065_r8 + 0.7_r8*exp(-20._r8*ri(i,k)) ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN leng_imsi = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! leng_imsi = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk)) ELSE leng_imsi = MIN( vk*zi(i,k), tunlramp*lbulk ) ENDIF tke_imsi = b1*(leng_imsi**2)*(-sh*n2(i,k)+sm*s2(i,k)) tke_imsi = MIN(MAX(tke_imsi,0._r8),tkemax) kvh_imsi = leng_imsi * SQRT(tke_imsi) * sh kvm_imsi = leng_imsi * SQRT(tke_imsi) * sm IF( kvh(i,k) .LT. kvh_imsi ) THEN kvh(i,k) = kvh_imsi kvm(i,k) = kvm_imsi leng(i,k) = leng_imsi tke(i,k) = tke_imsi wcap(i,k) = tke_imsi / b1 bprod(i,k) = -kvh_imsi * n2(i,k) sprod(i,k) = kvm_imsi * s2(i,k) sm_aw(i,k) = sm/alph1 ! This is diagnostic output for use in the microphysics turbtype(i,k) = 1 ! This was added on Dec.10.2009 for use in microphysics. ENDIF END IF END DO ! 888 continue ! ------------------------------------------------------------------ ! ! End of recomputation of eddy diffusivity at entrainment interfaces ! ! ------------------------------------------------------------------ ! ! As an option, we can impose a certain minimum back-ground diffusivity. ! do k = 1, pver+1 ! kvh(i,k) = max(0.01_r8,kvh(i,k)) ! kvm(i,k) = max(0.01_r8,kvm(i,k)) ! enddo ! --------------------------------------------------------------------- ! ! Diagnostic Output ! ! Just for diagnostic purpose, calculate stability functions at each ! ! interface including surface. Instead of assuming neutral stability, ! ! explicitly calculate stability functions using an reverse procedure ! ! starting from tkes(i) similar to the case of SRCL and SBCL in zisocl. ! ! Note that it is possible to calculate stability functions even when ! ! bflxs < 0. Note that this inverse method allows us to define Ri even ! ! at the surface. Note also tkes(i) and sprod(i,pver+1) are always ! ! positive values by limiters (e.g., ustar_min = 0.01). ! ! Dec.12.2006 : Also just for diagnostic output, re-set ! ! 'bprod(i,pver+1)= bflxs(i)' here. Note that this setting does not ! ! influence numerical calculation at all - it is just for diagnostic ! ! output. ! ! --------------------------------------------------------------------- ! bprod(i,pver+1) = bflxs(i) gg = 0.5_r8*vk*z(i,pver)*bprod(i,pver+1)/(tkes(i)**(3._r8/2._r8)) IF( ABS(alph5-gg*alph3) .LE. 1.e-7_r8 ) THEN ! gh = -0.28_r8 IF( bprod(i,pver+1) .GT. 0._r8 ) THEN gh = -3.5334_r8 ELSE gh = ghmin ENDIF ELSE gh = gg/(alph5-gg*alph3) END IF ! gh = min(max(gh,-0.28_r8),0.0233_r8) IF( bprod(i,pver+1) .GT. 0._r8 ) THEN gh = MIN(MAX(gh,-3.5334_r8),0.0233_r8) ELSE gh = MIN(MAX(gh,ghmin),0.0233_r8) ENDIF gh_a(i,pver+1) = gh sh_a(i,pver+1) = MAX(0._r8,alph5/(1._r8+alph3*gh)) IF( bprod(i,pver+1) .GT. 0._r8 ) THEN sm_a(i,pver+1) = MAX(0._r8,(alph1+alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh)) ELSE sm_a(i,pver+1) = MAX(0._r8,(alph1+alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4exs*gh)) ENDIF sm_aw(i,pver+1) = sm_a(i,pver+1)/alph1 ri_a(i,pver+1) = -(sm_a(i,pver+1)/sh_a(i,pver+1))*(bprod(i,pver+1)/sprod(i,pver+1)) DO k = 1, pver IF( ri(i,k) .LT. 0._r8 ) THEN trma = alph3*alph4*ri(i,k) + 2._r8*b1*(alph2-alph4*alph5*ri(i,k)) trmb = (alph3+alph4)*ri(i,k) + 2._r8*b1*(-alph5*ri(i,k)+alph1) trmc = ri(i,k) det = MAX(trmb*trmb-4._r8*trma*trmc,0._r8) gh = (-trmb + SQRT(det))/(2._r8*trma) gh = MIN(MAX(gh,-3.5334_r8),0.0233_r8) gh_a(i,k) = gh sh_a(i,k) = MAX(0._r8,alph5/(1._r8+alph3*gh)) sm_a(i,k) = MAX(0._r8,(alph1+alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh)) ri_a(i,k) = ri(i,k) ELSE IF( ri(i,k) .GT. ricrit ) THEN gh_a(i,k) = ghmin sh_a(i,k) = 0._r8 sm_a(i,k) = 0._r8 ri_a(i,k) = ri(i,k) ELSE trma = alph3*alph4exs*ri(i,k) + 2._r8*b1*(alph2-alph4exs*alph5*ri(i,k)) trmb = (alph3+alph4exs)*ri(i,k) + 2._r8*b1*(-alph5*ri(i,k)+alph1) trmc = ri(i,k) det = MAX(trmb*trmb-4._r8*trma*trmc,0._r8) gh = (-trmb + SQRT(det))/(2._r8*trma) gh = MIN(MAX(gh,ghmin),0.0233_r8) gh_a(i,k) = gh sh_a(i,k) = MAX(0._r8,alph5/(1._r8+alph3*gh)) sm_a(i,k) = MAX(0._r8,(alph1+alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4exs*gh)) ri_a(i,k) = ri(i,k) ENDIF ENDIF END DO DO k = 1, pver + 1 turbtype_f(i,k) = REAL(turbtype(i,k)) END DO END DO ! End of column index loop, i RETURN END SUBROUTINE caleddy ! ! exacol ! !============================================================================== ! ! ! !============================================================================== ! SUBROUTINE exacol( pcols, pver, ncol, ri, bflxs, minpblh, zi, ktop, kbase, ncvfin ) ! ---------------------------------------------------------------------------- ! ! Object : Find unstable CL regimes and determine the indices ! ! kbase, ktop which delimit these unstable layers : ! ! ri(kbase) > 0 and ri(ktop) > 0, but ri(k) < 0 for ktop < k < kbase. ! ! Author : Chris Bretherton 08/2000, ! ! Sungsu Park 08/2006, 11/2008 ! !----------------------------------------------------------------------------- ! IMPLICIT NONE ! --------------- ! ! Input variables ! ! --------------- ! INTEGER, INTENT(in) :: pcols ! Number of atmospheric columns INTEGER, INTENT(in) :: pver ! Number of atmospheric vertical layers INTEGER, INTENT(in) :: ncol ! Number of atmospheric columns REAL(r8), INTENT(in) :: ri(pcols,pver) ! Moist gradient Richardson no. REAL(r8), INTENT(in) :: bflxs(pcols) ! Buoyancy flux at surface REAL(r8), INTENT(in) :: minpblh(pcols) ! Minimum PBL height based on surface stress REAL(r8), INTENT(in) :: zi(pcols,pver+1) ! Interface heights ! ---------------- ! ! Output variables ! ! ---------------- ! INTEGER, INTENT(out) :: kbase(pcols,ncvmax) ! External interface index of CL base INTEGER, INTENT(out) :: ktop(pcols,ncvmax) ! External interface index of CL top INTEGER, INTENT(out) :: ncvfin(pcols) ! Total number of CLs ! --------------- ! ! Local variables ! ! --------------- ! INTEGER :: i INTEGER :: k INTEGER :: ncv REAL(r8) :: rimaxentr REAL(r8) :: riex(pver+1) ! Column Ri profile extended to surface ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! rimaxentr=0.0_r8 riex(1:pver+1)=0.0_r8 DO i = 1, ncol ncvfin(i) = 0 END DO DO ncv = 1, ncvmax DO i = 1, ncol ktop(i,ncv) = 0 kbase(i,ncv) = 0 END DO END DO ! ------------------------------------------------------ ! ! Find CL regimes starting from the surface going upward ! ! ------------------------------------------------------ ! rimaxentr = 0._r8 DO i = 1, ncol riex(2:pver) = ri(i,2:pver) ! Below allows consistent treatment of surface and other interfaces. ! Simply, if surface buoyancy flux is positive, Ri of surface is set to be negative. riex(pver+1) = rimaxentr - bflxs(i) ncv = 0 k = pver + 1 ! Work upward from surface interface DO WHILE ( k .GT. ntop_turb + 1 ) ! Below means that if 'bflxs > 0' (do not contain '=' sign), surface ! interface is energetically interior surface. IF( riex(k) .LT. rimaxentr ) THEN ! Identify a new CL ncv = ncv + 1 ! First define 'kbase' as the first interface below the lower-most unstable interface ! Thus, Richardson number at 'kbase' is positive. kbase(i,ncv) = MIN(k+1,pver+1) ! Decrement k until top unstable level DO WHILE( riex(k) .LT. rimaxentr .AND. k .GT. ntop_turb + 1 ) k = k - 1 END DO ! ktop is the first interface above upper-most unstable interface ! Thus, Richardson number at 'ktop' is positive. ktop(i,ncv) = k ELSE ! Search upward for a CL. k = k - 1 END IF END DO ! End of CL regime finding for each atmospheric column ncvfin(i) = ncv END DO ! End of atmospheric column do loop RETURN END SUBROUTINE exacol ! ! zisocl ! !============================================================================== ! ! ! !============================================================================== ! SUBROUTINE zisocl( pcols , pver , long , & z , zi , n2 , s2 , & bprod , sprod , bflxs, tkes ,landfrac, & ncvfin , kbase , ktop , belongcv, & ricl , ghcl , shcl , smcl , & lbrk , wbrk , ebrk , extend , extend_up, extend_dn ) !------------------------------------------------------------------------ ! ! Object : This 'zisocl' vertically extends original CLs identified from ! ! 'exacol' using a merging test based on either 'wint' or 'l2n2' ! ! and identify new CL regimes. Similar to the case of 'exacol', ! ! CL regime index increases with height. After identifying new ! ! CL regimes ( kbase, ktop, ncvfin ),calculate CL internal mean ! ! energetics (lbrk : energetic thickness integral, wbrk, ebrk ) ! ! and stability functions (ricl, ghcl, shcl, smcl) by including ! ! surface interfacial layer contribution when bflxs > 0. Note ! ! that there are two options in the treatment of the energetics ! ! of surface interfacial layer (use_dw_surf= 'true' or 'false') ! ! Author : Sungsu Park 08/2006, 11/2008 ! !------------------------------------------------------------------------ ! IMPLICIT NONE ! --------------- ! ! Input variables ! ! --------------- ! INTEGER, INTENT(in) :: long ! Longitude of the column INTEGER, INTENT(in) :: pcols ! Number of atmospheric columns INTEGER, INTENT(in) :: pver ! Number of atmospheric vertical layers REAL(r8), INTENT(in) :: z(pcols, pver) ! Layer mid-point height [ m ] REAL(r8), INTENT(in) :: zi(pcols, pver+1) ! Interface height [ m ] REAL(r8), INTENT(in) :: n2(pcols, pver) ! Buoyancy frequency at interfaces except surface [ s-2 ] REAL(r8), INTENT(in) :: s2(pcols, pver) ! Shear frequency at interfaces except surface [ s-2 ] REAL(r8), INTENT(in) :: bprod(pcols,pver+1) ! Buoyancy production [ m2/s3 ]. bprod(i,pver+1) = bflxs REAL(r8), INTENT(in) :: sprod(pcols,pver+1) ! Shear production [ m2/s3 ]. sprod(i,pver+1) = usta**3/(vk*z(i,pver)) REAL(r8), INTENT(in) :: bflxs(pcols) ! Surface buoyancy flux [ m2/s3 ]. bprod(i,pver+1) = bflxs REAL(r8), INTENT(in) :: tkes(pcols) ! TKE at the surface [ s2/s2 ] REAL(r8), INTENT(in) :: landfrac(pcols) ! ---------------------- ! ! Input/output variables ! ! ---------------------- ! INTEGER, INTENT(inout) :: kbase(pcols,ncvmax) ! Base external interface index of CL INTEGER, INTENT(inout) :: ktop(pcols,ncvmax) ! Top external interface index of CL INTEGER, INTENT(inout) :: ncvfin(pcols) ! Total number of CLs ! ---------------- ! ! Output variables ! ! ---------------- ! LOGICAL, INTENT(out) :: belongcv(pcols,pver+1) ! True if interface is in a CL ( either internal or external ) REAL(r8), INTENT(out) :: ricl(pcols,ncvmax) ! Mean Richardson number of internal CL REAL(r8), INTENT(out) :: ghcl(pcols,ncvmax) ! Half of normalized buoyancy production of internal CL REAL(r8), INTENT(out) :: shcl(pcols,ncvmax) ! Galperin instability function of heat-moisture of internal CL REAL(r8), INTENT(out) :: smcl(pcols,ncvmax) ! Galperin instability function of momentum of internal CL REAL(r8), INTENT(out) :: lbrk(pcols,ncvmax) ! Thickness of (energetically) internal CL ( lint, [m] ) REAL(r8), INTENT(out) :: wbrk(pcols,ncvmax) ! Mean normalized TKE of internal CL [ m2/s2 ] REAL(r8), INTENT(out) :: ebrk(pcols,ncvmax) ! Mean TKE of internal CL ( b1*wbrk, [m2/s2] ) ! ------------------ ! ! Internal variables ! ! ------------------ ! LOGICAL :: extend ! True when CL is extended in zisocl LOGICAL :: extend_up ! True when CL is extended upward in zisocl LOGICAL :: extend_dn ! True when CL is extended downward in zisocl LOGICAL :: bottom ! True when CL base is at surface ( kb = pver + 1 ) INTEGER :: i ! Local index for the longitude INTEGER :: ncv ! CL Index increasing with height INTEGER :: incv INTEGER :: k INTEGER :: kb ! Local index for kbase INTEGER :: kt ! Local index for ktop INTEGER :: ncvinit ! Value of ncv at routine entrance INTEGER :: cntu ! Number of merged CLs during upward extension of individual CL INTEGER :: cntd ! Number of merged CLs during downward extension of individual CL INTEGER :: kbinc ! Index for incorporating underlying CL INTEGER :: ktinc ! Index for incorporating overlying CL REAL(r8) :: wint ! Normalized TKE of internal CL REAL(r8) :: dwinc ! Normalized TKE of CL external interfaces REAL(r8) :: dw_surf ! Normalized TKE of surface interfacial layer REAL(r8) :: dzinc REAL(r8) :: gh REAL(r8) :: sh REAL(r8) :: sm REAL(r8) :: gh_surf ! Half of normalized buoyancy production in surface interfacial layer REAL(r8) :: sh_surf ! Galperin instability function in surface interfacial layer REAL(r8) :: sm_surf ! Galperin instability function in surface interfacial layer REAL(r8) :: l2n2 ! Vertical integral of 'l^2N^2' over CL. Include thickness product REAL(r8) :: l2s2 ! Vertical integral of 'l^2S^2' over CL. Include thickness product REAL(r8) :: dl2n2 ! Vertical integration of 'l^2*N^2' of CL external interfaces REAL(r8) :: dl2s2 ! Vertical integration of 'l^2*S^2' of CL external interfaces REAL(r8) :: dl2n2_surf ! 'dl2n2' defined in the surface interfacial layer REAL(r8) :: dl2s2_surf ! 'dl2s2' defined in the surface interfacial layer REAL(r8) :: lint ! Thickness of (energetically) internal CL REAL(r8) :: dlint ! Interfacial layer thickness of CL external interfaces REAL(r8) :: dlint_surf ! Surface interfacial layer thickness REAL(r8) :: lbulk ! Master Length Scale : Whole CL thickness from top to base external interface REAL(r8) :: lz ! Turbulent length scale REAL(r8) :: ricll ! Mean Richardson number of internal CL REAL(r8) :: trma REAL(r8) :: trmb REAL(r8) :: trmc REAL(r8) :: det REAL(r8) :: zbot ! Height of CL base REAL(r8) :: l2rat ! Square of ratio of actual to initial CL (not used) REAL(r8) :: gg ! Intermediate variable used for calculating stability functions of SBCL REAL(r8) :: tunlramp ! Ramping tunl ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! i = long ! Initialize main output variables DO k = 1, ncvmax ricl(i,k) = 0._r8 ghcl(i,k) = 0._r8 shcl(i,k) = 0._r8 smcl(i,k) = 0._r8 lbrk(i,k) = 0._r8 wbrk(i,k) = 0._r8 ebrk(i,k) = 0._r8 END DO belongcv(i,1:pver+1)=.TRUE. extend = .FALSE. extend_up = .FALSE. extend_dn = .FALSE. ! ----------------------------------------------------------- ! ! Loop over each CL to see if any of them need to be extended ! ! ----------------------------------------------------------- ! ncv = 1 DO WHILE( ncv .LE. ncvfin(i) ) ncvinit = ncv cntu = 0 cntd = 0 kb = kbase(i,ncv) kt = ktop(i,ncv) ! ---------------------------------------------------------------------------- ! ! Calculation of CL interior energetics including surface before extension ! ! ---------------------------------------------------------------------------- ! ! Note that the contribution of interior interfaces (not surface) to 'wint' is ! ! accounted by using '-sh*l2n2 + sm*l2s2' while the contribution of surface is ! ! accounted by using 'dwsurf = tkes/b1' when bflxs > 0. This approach is fully ! ! reasonable. Another possible alternative, which seems to be also consistent ! ! is to calculate 'dl2n2_surf' and 'dl2s2_surf' of surface interfacial layer ! ! separately, and this contribution is explicitly added by initializing 'l2n2' ! ! 'l2s2' not by zero, but by 'dl2n2_surf' and 'ds2n2_surf' below. At the same ! ! time, 'dwsurf' should be excluded in 'wint' calculation below. The only diff.! ! between two approaches is that in case of the latter approach, contributions ! ! of surface interfacial layer to the CL mean stability function (ri,gh,sh,sm) ! ! are explicitly included while the first approach is not. In this sense, the ! ! second approach seems to be more conceptually consistent, but currently, I ! ! (Sungsu) will keep the first default approach. There is a switch ! ! 'use_dw_surf' at the first part of eddy_diff.F90 chosing one of ! ! these two options. ! ! ---------------------------------------------------------------------------- ! ! ------------------------------------------------------ ! ! Step 0: Calculate surface interfacial layer energetics ! ! ------------------------------------------------------ ! lbulk = zi(i,kt) - zi(i,kb) dlint_surf = 0._r8 dl2n2_surf = 0._r8 dl2s2_surf = 0._r8 dw_surf = 0._r8 IF( kb .EQ. pver+1 ) THEN IF( bflxs(i) .GT. 0._r8 ) THEN ! Calculate stability functions of surface interfacial layer ! from the given 'bprod(i,pver+1)' and 'sprod(i,pver+1)' using ! inverse approach. Since alph5>0 and alph3<0, denominator of ! gg is always positive if bprod(i,pver+1)>0. gg = 0.5_r8*vk*z(i,pver)*bprod(i,pver+1)/(tkes(i)**(3._r8/2._r8)) gh = gg/(alph5-gg*alph3) ! gh = min(max(gh,-0.28_r8),0.0233_r8) gh = MIN(MAX(gh,-3.5334_r8),0.0233_r8) sh = alph5/(1._r8+alph3*gh) sm = (alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh) ricll = MIN(-(sm/sh)*(bprod(i,pver+1)/sprod(i,pver+1)),ricrit) ! Calculate surface interfacial layer contribution to CL internal ! energetics. By construction, 'dw_surf = -dl2n2_surf + ds2n2_surf' ! is exactly satisfied, which corresponds to assuming turbulent ! length scale of surface interfacial layer = vk * z(i,pver). Note ! 'dl2n2_surf','dl2s2_surf','dw_surf' include thickness product. dlint_surf = z(i,pver) dl2n2_surf = -vk*(z(i,pver)**2)*bprod(i,pver+1)/(sh*SQRT(tkes(i))) dl2s2_surf = vk*(z(i,pver)**2)*sprod(i,pver+1)/(sm*SQRT(tkes(i))) dw_surf = (tkes(i)/b1)*z(i,pver) ELSE ! Note that this case can happen when surface is an external ! interface of CL. lbulk = zi(i,kt) - z(i,pver) END IF END IF ! ------------------------------------------------------ ! ! Step 1: Include surface interfacial layer contribution ! ! ------------------------------------------------------ ! lint = dlint_surf l2n2 = dl2n2_surf l2s2 = dl2s2_surf wint = dw_surf IF( use_dw_surf ) THEN l2n2 = 0._r8 l2s2 = 0._r8 ELSE IF(landfrac(i) > 0.5_r8 ) THEN l2n2 = 0._r8 l2s2 = 0._r8 END IF wint = 0._r8 END IF ! --------------------------------------------------------------------------------- ! ! Step 2. Include the contribution of 'pure internal interfaces' other than surface ! ! --------------------------------------------------------------------------------- ! IF( kt .LT. kb - 1 ) THEN ! The case of non-SBCL. DO k = kb - 1, kt + 1, -1 IF( choice_tunl .EQ. 'rampcl' ) THEN ! Modification : I simply used the average tunlramp between the two limits. tunlramp = 0.5_r8*(1._r8+ctunl)*tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = ctunl*tunl ! tunlramp = 0.765_r8 ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN lz = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! lz = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk)) ELSE lz = MIN( vk*zi(i,k), tunlramp*lbulk ) ENDIF dzinc = z(i,k-1) - z(i,k) l2n2 = l2n2 + lz*lz*n2(i,k)*dzinc l2s2 = l2s2 + lz*lz*s2(i,k)*dzinc lint = lint + dzinc END DO ! Calculate initial CL stability functions (gh,sh,sm) and net ! internal energy of CL including surface contribution if any. ! Modification : It seems that below cannot be applied when ricrit > 0.19. ! May need future generalization. ricll = MIN(l2n2/MAX(l2s2,ntzero),ricrit) ! Mean Ri of internal CL trma = alph3*alph4*ricll+2._r8*b1*(alph2-alph4*alph5*ricll) trmb = ricll*(alph3+alph4)+2._r8*b1*(-alph5*ricll+alph1) trmc = ricll det = MAX(trmb*trmb-4._r8*trma*trmc,0._r8) gh = (-trmb + SQRT(det))/2._r8/trma ! gh = min(max(gh,-0.28_r8),0.0233_r8) gh = MIN(MAX(gh,-3.5334_r8),0.0233_r8) sh = alph5/(1._r8+alph3*gh) sm = (alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh) wint = wint - sh*l2n2 + sm*l2s2 ELSE ! The case of SBCL ! If there is no pure internal interface, use only surface interfacial ! values. However, re-set surface interfacial values such that it can ! be used in the merging tests (either based on 'wint' or 'l2n2') and ! in such that surface interfacial energy is not double-counted. ! Note that regardless of the choise of 'use_dw_surf', below should be ! kept as it is below, for consistent merging test of extending SBCL. lint = dlint_surf l2n2 = dl2n2_surf l2s2 = dl2s2_surf wint = dw_surf ! Aug.29.2006 : Only for the purpose of merging test of extending SRCL ! based on 'l2n2', re-define 'l2n2' of surface interfacial layer using ! 'wint'. This part is designed for similar treatment of merging as in ! the original 'eddy_diff.F90' code, where 'l2n2' of SBCL was defined ! as 'l2n2 = - wint / sh'. Note that below block is used only when (1) ! surface buoyancy production 'bprod(i,pver+1)' is NOT included in the ! calculation of surface TKE in the initialization of 'bprod(i,pver+1)' ! in the main subroutine ( even though bflxs > 0 ), and (2) to force ! current scheme be similar to the previous scheme in the treatment of ! extending-merging test of SBCL based on 'l2n2'. Otherwise below line ! must be commented out. Note at this stage, correct non-zero value of ! 'sh' has been already computed. IF( choice_tkes .EQ. 'ebprod' ) THEN l2n2 = - wint / sh ENDIF ENDIF ! Set consistent upper limits on 'l2n2' and 'l2s2'. Below limits are ! reasonable since l2n2 of CL interior interface is always negative. l2n2 = -MIN(-l2n2, tkemax*lint/(b1*sh)) l2s2 = MIN( l2s2, tkemax*lint/(b1*sm)) ! Note that at this stage, ( gh, sh, sm ) are the values of surface ! interfacial layer if there is no pure internal interface, while if ! there is pure internal interface, ( gh, sh, sm ) are the values of ! pure CL interfaces or the values that include both the CL internal ! interfaces and surface interfaces, depending on the 'use_dw_surf'. ! ----------------------------------------------------------------------- ! ! Perform vertical extension-merging process ! ! ----------------------------------------------------------------------- ! ! During the merging process, we assumed ( lbulk, sh, sm ) of CL external ! ! interfaces are the same as the ones of the original merging CL. This is ! ! an inevitable approximation since we don't know ( sh, sm ) of external ! ! interfaces at this stage. Note that current default merging test is ! ! purely based on buoyancy production without including shear production, ! ! since we used 'l2n2' instead of 'wint' as a merging parameter. However, ! ! merging test based on 'wint' maybe conceptually more attractable. ! ! Downward CL merging process is identical to the upward merging process, ! ! but when the base of extended CL reaches to the surface, surface inter ! ! facial layer contribution to the energetic of extended CL must be done ! ! carefully depending on the sign of surface buoyancy flux. The contribu ! ! tion of surface interfacial layer energetic is included to the internal ! ! energetics of merging CL only when bflxs > 0. ! ! ----------------------------------------------------------------------- ! ! ---------------------------- ! ! Step 1. Extend the CL upward ! ! ---------------------------- ! extend = .FALSE. ! This will become .true. if CL top or base is extended ! Calculate contribution of potentially incorporable CL top interface IF( choice_tunl .EQ. 'rampcl' ) THEN tunlramp = 0.5_r8*(1._r8+ctunl)*tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = ctunl*tunl ! tunlramp = 0.765_r8 ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN lz = ( (vk*zi(i,kt))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! lz = vk*zi(i,kt) / (1._r8+vk*zi(i,kt)/(tunlramp*lbulk)) ELSE lz = MIN( vk*zi(i,kt), tunlramp*lbulk ) ENDIF dzinc = z(i,kt-1)-z(i,kt) dl2n2 = lz*lz*n2(i,kt)*dzinc dl2s2 = lz*lz*s2(i,kt)*dzinc dwinc = -sh*dl2n2 + sm*dl2s2 ! ------------ ! ! Merging Test ! ! ------------ ! ! do while ( dwinc .gt. ( rinc*dzinc*wint/(lint+(1._r8-rinc)*dzinc)) ) ! Merging test based on wint ! do while ( -dl2n2 .gt. (-rinc*dzinc*l2n2/(lint+(1._r8-rinc)*dzinc)) ) ! Merging test based on l2n2 DO WHILE ( -dl2n2 .GT. (-rinc*l2n2/(1._r8-rinc)) ) ! Integral merging test ! Add contribution of top external interface to interior energy. ! Note even when we chose 'use_dw_surf='true.', the contribution ! of surface interfacial layer to 'l2n2' and 'l2s2' are included ! here. However it is not double counting of surface interfacial ! energy : surface interfacial layer energy is counted in 'wint' ! formula and 'l2n2' is just used for performing merging test in ! this 'do while' loop. lint = lint + dzinc l2n2 = l2n2 + dl2n2 l2n2 = -MIN(-l2n2, tkemax*lint/(b1*sh)) l2s2 = l2s2 + dl2s2 wint = wint + dwinc ! Extend top external interface of CL upward after merging kt = kt - 1 extend = .TRUE. extend_up = .TRUE. IF( kt .EQ. ntop_turb ) THEN WRITE(iulog,*) 'zisocl: Error: Tried to extend CL to the model top' STOP END IF ! If the top external interface of extending CL is the same as the ! top interior interface of the overlying CL, overlying CL will be ! automatically merged. Then,reduce total number of CL regime by 1. ! and increase 'cntu'(number of merged CLs during upward extension) ! by 1. ktinc = kbase(i,ncv+cntu+1) - 1 ! Lowest interior interface of overlying CL IF( kt .EQ. ktinc ) THEN DO k = kbase(i,ncv+cntu+1) - 1, ktop(i,ncv+cntu+1) + 1, -1 IF( choice_tunl .EQ. 'rampcl' ) THEN tunlramp = 0.5_r8*(1._r8+ctunl)*tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = ctunl*tunl ! tunlramp = 0.765_r8 ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN lz = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! lz = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk)) ELSE lz = MIN( vk*zi(i,k), tunlramp*lbulk ) ENDIF dzinc = z(i,k-1)-z(i,k) dl2n2 = lz*lz*n2(i,k)*dzinc dl2s2 = lz*lz*s2(i,k)*dzinc dwinc = -sh*dl2n2 + sm*dl2s2 lint = lint + dzinc l2n2 = l2n2 + dl2n2 l2n2 = -MIN(-l2n2, tkemax*lint/(b1*sh)) l2s2 = l2s2 + dl2s2 wint = wint + dwinc END DO kt = ktop(i,ncv+cntu+1) ncvfin(i) = ncvfin(i) - 1 cntu = cntu + 1 END IF ! Again, calculate the contribution of potentially incorporatable CL ! top external interface of CL regime. IF( choice_tunl .EQ. 'rampcl' ) THEN tunlramp = 0.5_r8*(1._r8+ctunl)*tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = ctunl*tunl ! tunlramp = 0.765_r8 ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN lz = ( (vk*zi(i,kt))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! lz = vk*zi(i,kt) / (1._r8+vk*zi(i,kt)/(tunlramp*lbulk)) ELSE lz = MIN( vk*zi(i,kt), tunlramp*lbulk ) ENDIF dzinc = z(i,kt-1)-z(i,kt) dl2n2 = lz*lz*n2(i,kt)*dzinc dl2s2 = lz*lz*s2(i,kt)*dzinc dwinc = -sh*dl2n2 + sm*dl2s2 END DO ! End of upward merging test 'do while' loop ! Update CL interface indices appropriately if any CL was merged. ! Note that below only updated the interface index of merged CL, ! not the original merging CL. Updates of 'kbase' and 'ktop' of ! the original merging CL will be done after finishing downward ! extension also later. IF( cntu .GT. 0 ) THEN DO incv = 1, ncvfin(i) - ncv kbase(i,ncv+incv) = kbase(i,ncv+cntu+incv) ktop(i,ncv+incv) = ktop(i,ncv+cntu+incv) END DO END IF ! ------------------------------ ! ! Step 2. Extend the CL downward ! ! ------------------------------ ! IF( kb .NE. pver + 1 ) THEN ! Calculate contribution of potentially incorporable CL base interface IF( choice_tunl .EQ. 'rampcl' ) THEN tunlramp = 0.5_r8*(1._r8+ctunl)*tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = ctunl*tunl ! tunlramp = 0.765_r8 ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN lz = ( (vk*zi(i,kb))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! lz = vk*zi(i,kb) / (1._r8+vk*zi(i,kb)/(tunlramp*lbulk)) ELSE lz = MIN( vk*zi(i,kb), tunlramp*lbulk ) ENDIF dzinc = z(i,kb-1)-z(i,kb) dl2n2 = lz*lz*n2(i,kb)*dzinc dl2s2 = lz*lz*s2(i,kb)*dzinc dwinc = -sh*dl2n2 + sm*dl2s2 ! ------------ ! ! Merging test ! ! ------------ ! ! In the below merging tests, I must keep '.and.(kb.ne.pver+1)', ! since 'kb' is continuously updated within the 'do while' loop ! whenever CL base is merged. ! do while( ( dwinc .gt. ( rinc*dzinc*wint/(lint+(1._r8-rinc)*dzinc)) ) & ! Merging test based on wint ! do while( ( -dl2n2 .gt. (-rinc*dzinc*l2n2/(lint+(1._r8-rinc)*dzinc)) ) & ! Merging test based on l2n2 ! .and.(kb.ne.pver+1)) DO WHILE( ( -dl2n2 .GT. (-rinc*l2n2/(1._r8-rinc)) ) & ! Integral merging test .AND.(kb.NE.pver+1)) ! Add contributions from interfacial layer kb to CL interior lint = lint + dzinc l2n2 = l2n2 + dl2n2 l2n2 = -MIN(-l2n2, tkemax*lint/(b1*sh)) l2s2 = l2s2 + dl2s2 wint = wint + dwinc ! Extend the base external interface of CL downward after merging kb = kb + 1 extend = .TRUE. extend_dn = .TRUE. ! If the base external interface of extending CL is the same as the ! base interior interface of the underlying CL, underlying CL will ! be automatically merged. Then, reduce total number of CL by 1. ! For a consistent treatment with 'upward' extension, I should use ! 'kbinc = kbase(i,ncv-1) - 1' instead of 'ktop(i,ncv-1) + 1' below. ! However, it seems that these two methods produce the same results. ! Note also that in contrast to upward merging, the decrease of ncv ! should be performed here. ! Note that below formula correctly works even when upperlying CL ! regime incorporates below SBCL. kbinc = 0 IF( ncv .GT. 1 ) kbinc = ktop(i,ncv-1) + 1 IF( kb .EQ. kbinc ) THEN DO k = ktop(i,ncv-1) + 1, kbase(i,ncv-1) - 1 IF( choice_tunl .EQ. 'rampcl' ) THEN tunlramp = 0.5_r8*(1._r8+ctunl)*tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = ctunl*tunl ! tunlramp = 0.765_r8 ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN lz = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! lz = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk)) ELSE lz = MIN( vk*zi(i,k), tunlramp*lbulk ) ENDIF dzinc = z(i,k-1)-z(i,k) dl2n2 = lz*lz*n2(i,k)*dzinc dl2s2 = lz*lz*s2(i,k)*dzinc dwinc = -sh*dl2n2 + sm*dl2s2 lint = lint + dzinc l2n2 = l2n2 + dl2n2 l2n2 = -MIN(-l2n2, tkemax*lint/(b1*sh)) l2s2 = l2s2 + dl2s2 wint = wint + dwinc END DO ! We are incorporating interior of CL ncv-1, so merge ! this CL into the current CL. kb = kbase(i,ncv-1) ncv = ncv - 1 ncvfin(i) = ncvfin(i) -1 cntd = cntd + 1 END IF ! Calculate the contribution of potentially incorporatable CL ! base external interface. Calculate separately when the base ! of extended CL is surface and non-surface. IF( kb .EQ. pver + 1 ) THEN IF( bflxs(i) .GT. 0._r8 ) THEN ! Calculate stability functions of surface interfacial layer gg = 0.5_r8*vk*z(i,pver)*bprod(i,pver+1)/(tkes(i)**(3._r8/2._r8)) gh_surf = gg/(alph5-gg*alph3) ! gh_surf = min(max(gh_surf,-0.28_r8),0.0233_r8) gh_surf = MIN(MAX(gh_surf,-3.5334_r8),0.0233_r8) sh_surf = alph5/(1._r8+alph3*gh_surf) sm_surf = (alph1 + alph2*gh_surf)/(1._r8+alph3*gh_surf)/(1._r8+alph4*gh_surf) ! Calculate surface interfacial layer contribution. By construction, ! it exactly becomes 'dw_surf = -dl2n2_surf + ds2n2_surf' dlint_surf = z(i,pver) dl2n2_surf = -vk*(z(i,pver)**2._r8)*bprod(i,pver+1)/(sh_surf*SQRT(tkes(i))) dl2s2_surf = vk*(z(i,pver)**2._r8)*sprod(i,pver+1)/(sm_surf*SQRT(tkes(i))) dw_surf = (tkes(i)/b1)*z(i,pver) ELSE dlint_surf = 0._r8 dl2n2_surf = 0._r8 dl2s2_surf = 0._r8 dw_surf = 0._r8 END IF ! If (kb.eq.pver+1), updating of CL internal energetics should be ! performed here inside of 'do while' loop, since 'do while' loop ! contains the constraint of '.and.(kb.ne.pver+1)',so updating of ! CL internal energetics cannot be performed within this do while ! loop when kb.eq.pver+1. Even though I updated all 'l2n2','l2s2', ! 'wint' below, only the updated 'wint' is used in the following ! numerical calculation. lint = lint + dlint_surf l2n2 = l2n2 + dl2n2_surf l2n2 = -MIN(-l2n2, tkemax*lint/(b1*sh)) l2s2 = l2s2 + dl2s2_surf wint = wint + dw_surf ELSE IF( choice_tunl .EQ. 'rampcl' ) THEN tunlramp = 0.5_r8*(1._r8+ctunl)*tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = ctunl*tunl ! tunlramp = 0.765_r8 ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN lz = ( (vk*zi(i,kb))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! lz = vk*zi(i,kb) / (1._r8+vk*zi(i,kb)/(tunlramp*lbulk)) ELSE lz = MIN( vk*zi(i,kb), tunlramp*lbulk ) ENDIF dzinc = z(i,kb-1)-z(i,kb) dl2n2 = lz*lz*n2(i,kb)*dzinc dl2s2 = lz*lz*s2(i,kb)*dzinc dwinc = -sh*dl2n2 + sm*dl2s2 END IF END DO ! End of merging test 'do while' loop IF( (kb.EQ.pver+1) .AND. (ncv.NE.1) ) THEN WRITE(iulog,*) 'Major mistake zisocl: the CL based at surface is not indexed 1' STOP END IF END IF ! Done with bottom extension of CL ! Update CL interface indices appropriately if any CL was merged. ! Note that below only updated the interface index of merged CL, ! not the original merging CL. Updates of 'kbase' and 'ktop' of ! the original merging CL will be done later below. I should ! check in detail if below index updating is correct or not. IF( cntd .GT. 0 ) THEN DO incv = 1, ncvfin(i) - ncv kbase(i,ncv+incv) = kbase(i,ncvinit+incv) ktop(i,ncv+incv) = ktop(i,ncvinit+incv) END DO END IF ! Sanity check for positive wint. IF( wint .LT. 0.01_r8 ) THEN wint = 0.01_r8 END IF ! -------------------------------------------------------------------------- ! ! Finally update CL mean internal energetics including surface contribution ! ! after finishing all the CL extension-merging process. As mentioned above, ! ! there are two possible ways in the treatment of surface interfacial layer, ! ! either through 'dw_surf' or 'dl2n2_surf and dl2s2_surf' by setting logical ! ! variable 'use_dw_surf' =.true. or .false. In any cases, we should avoid ! ! double counting of surface interfacial layer and one single consistent way ! ! should be used throughout the program. ! ! -------------------------------------------------------------------------- ! IF( extend ) THEN ktop(i,ncv) = kt kbase(i,ncv) = kb ! ------------------------------------------------------ ! ! Step 1: Include surface interfacial layer contribution ! ! ------------------------------------------------------ ! lbulk = zi(i,kt) - zi(i,kb) dlint_surf = 0._r8 dl2n2_surf = 0._r8 dl2s2_surf = 0._r8 dw_surf = 0._r8 IF( kb .EQ. pver + 1 ) THEN IF( bflxs(i) .GT. 0._r8 ) THEN ! Calculate stability functions of surface interfacial layer gg = 0.5_r8*vk*z(i,pver)*bprod(i,pver+1)/(tkes(i)**(3._r8/2._r8)) gh = gg/(alph5-gg*alph3) ! gh = min(max(gh,-0.28_r8),0.0233_r8) gh = MIN(MAX(gh,-3.5334_r8),0.0233_r8) sh = alph5/(1._r8+alph3*gh) sm = (alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh) ! Calculate surface interfacial layer contribution. By construction, ! it exactly becomes 'dw_surf = -dl2n2_surf + ds2n2_surf' dlint_surf = z(i,pver) dl2n2_surf = -vk*(z(i,pver)**2._r8)*bprod(i,pver+1)/(sh*SQRT(tkes(i))) dl2s2_surf = vk*(z(i,pver)**2._r8)*sprod(i,pver+1)/(sm*SQRT(tkes(i))) dw_surf = (tkes(i)/b1)*z(i,pver) ELSE lbulk = zi(i,kt) - z(i,pver) END IF END IF lint = dlint_surf l2n2 = dl2n2_surf l2s2 = dl2s2_surf wint = dw_surf IF( use_dw_surf ) THEN l2n2 = 0._r8 l2s2 = 0._r8 ELSE IF(landfrac(i) > 0.5_r8) THEN l2n2 = 0.0_r8 l2s2 = 0.0_r8 END IF wint = 0._r8 END IF ! -------------------------------------------------------------- ! ! Step 2. Include the contribution of 'pure internal interfaces' ! ! -------------------------------------------------------------- ! DO k = kt + 1, kb - 1 IF( choice_tunl .EQ. 'rampcl' ) THEN tunlramp = 0.5_r8*(1._r8+ctunl)*tunl ELSEIF( choice_tunl .EQ. 'rampsl' ) THEN tunlramp = ctunl*tunl ! tunlramp = 0.765_r8 ELSE tunlramp = tunl ENDIF IF( choice_leng .EQ. 'origin' ) THEN lz = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng) ! lz = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk)) ELSE lz = MIN( vk*zi(i,k), tunlramp*lbulk ) ENDIF dzinc = z(i,k-1) - z(i,k) lint = lint + dzinc l2n2 = l2n2 + lz*lz*n2(i,k)*dzinc l2s2 = l2s2 + lz*lz*s2(i,k)*dzinc END DO ricll = MIN(l2n2/MAX(l2s2,ntzero),ricrit) trma = alph3*alph4*ricll+2._r8*b1*(alph2-alph4*alph5*ricll) trmb = ricll*(alph3+alph4)+2._r8*b1*(-alph5*ricll+alph1) trmc = ricll det = MAX(trmb*trmb-4._r8*trma*trmc,0._r8) gh = (-trmb + SQRT(det))/2._r8/trma ! gh = min(max(gh,-0.28_r8),0.0233_r8) gh = MIN(MAX(gh,-3.5334_r8),0.0233_r8) sh = alph5 / (1._r8+alph3*gh) sm = (alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh) ! Even though the 'wint' after finishing merging was positive, it is ! possible that re-calculated 'wint' here is negative. In this case, ! correct 'wint' to be a small positive number wint = MAX( wint - sh*l2n2 + sm*l2s2, 0.01_r8 ) END IF ! ---------------------------------------------------------------------- ! ! Calculate final output variables of each CL (either has merged or not) ! ! ---------------------------------------------------------------------- ! lbrk(i,ncv) = lint wbrk(i,ncv) = wint/lint ebrk(i,ncv) = b1*wbrk(i,ncv) ebrk(i,ncv) = MIN(ebrk(i,ncv),tkemax) ricl(i,ncv) = ricll ghcl(i,ncv) = gh shcl(i,ncv) = sh smcl(i,ncv) = sm ! Increment counter for next CL. I should check if the increament of 'ncv' ! below is reasonable or not, since whenever CL is merged during downward ! extension process, 'ncv' is lowered down continuously within 'do' loop. ! But it seems that below 'ncv = ncv + 1' is perfectly correct. ncv = ncv + 1 END DO ! End of loop over each CL regime, ncv. ! ---------------------------------------------------------- ! ! Re-initialize external interface indices which are not CLs ! ! ---------------------------------------------------------- ! DO ncv = ncvfin(i) + 1, ncvmax ktop(i,ncv) = 0 kbase(i,ncv) = 0 END DO ! ------------------------------------------------ ! ! Update CL interface identifiers, 'belongcv' ! ! CL external interfaces are also identified as CL ! ! ------------------------------------------------ ! DO k = 1, pver + 1 belongcv(i,k) = .FALSE. END DO DO ncv = 1, ncvfin(i) DO k = ktop(i,ncv), kbase(i,ncv) belongcv(i,k) = .TRUE. END DO END DO RETURN END SUBROUTINE zisocl ! ! compute_cubic ! REAL(Kind=r8) FUNCTION compute_cubic(a,b,c) ! ------------------------------------------------------------------------- ! ! Solve canonical cubic : x^3 + a*x^2 + b*x + c = 0, x = sqrt(e)/sqrt() ! ! Set x = max(xmin,x) at the end ! ! ------------------------------------------------------------------------- ! IMPLICIT NONE REAL(Kind=r8), INTENT(in) :: a REAL(Kind=r8), INTENT(in) :: b REAL(Kind=r8), INTENT(in) :: c REAL(Kind=r8) :: qq, rr, dd, theta, aa, bb, x1, x2, x3 REAL(Kind=r8), PARAMETER :: xmin = 1.e-2_r8 qq = (a**2-3.0_r8*b)/9.0_r8 rr = (2.0_r8*a**3 - 9.0_r8*a*b + 27.0_r8*c)/54.0_r8 dd = rr**2 - qq**3 IF( dd .LE. 0._r8 ) THEN theta = ACOS(rr/qq**(3.0_r8/2.0_r8)) x1 = -2.0_r8*SQRT(qq)*COS(theta/3.0_r8) - a/3.0_r8 x2 = -2.0_r8*SQRT(qq)*COS((theta+2.0_r8*3.141592)/3.0_r8) - a/3.0_r8 x3 = -2.0_r8*SQRT(qq)*COS((theta-2.0_r8*3.141592)/3.0_r8) - a/3.0_r8 compute_cubic = MAX(MAX(MAX(x1,x2),x3),xmin) RETURN ELSE IF( rr .GE. 0.0_r8 ) THEN aa = -(SQRT(rr**2-qq**3)+rr)**(1.0_r8/3.0_r8) ELSE aa = (SQRT(rr**2-qq**3)-rr)**(1.0_r8/3.0_r8) ENDIF IF( aa .EQ. 0.0_r8 ) THEN bb = 0.0_r8 ELSE bb = qq/aa ENDIF compute_cubic = MAX((aa+bb)-a/3.0_r8,xmin) RETURN ENDIF RETURN END FUNCTION compute_cubic !=============================================================================== SUBROUTINE ubc_get_vals (lchnk,pcols, ncol,pverp, ntop_molec, pint, zi, msis_temp, ubc_mmr) !----------------------------------------------------------------------- ! interface routine for vertical diffusion and pbl scheme !----------------------------------------------------------------------- !------------------------------Arguments-------------------------------- INTEGER, INTENT(in) :: lchnk ! chunk identifier INTEGER, INTENT(in) :: ncol ! number of atmospheric columns INTEGER, INTENT(in) :: pcols INTEGER, INTENT(in) :: pverp INTEGER, INTENT(in) :: ntop_molec ! top of molecular diffusion region (=1) REAL(r8), INTENT(in) :: pint(pcols,pverp) ! interface pressures REAL(r8), INTENT(in) :: zi(pcols,pverp) ! interface geoptl height above sfc REAL(r8), INTENT(out) :: ubc_mmr(pcols,pcnst) ! upper bndy mixing ratios (kg/kg) REAL(r8), INTENT(out) :: msis_temp(pcols) ! upper bndy temperature (K) END SUBROUTINE ubc_get_vals !============================================================================ ! ! ! !============================================================================ ! subroutine init_molec_diff( kind, ncnst, rair_in, ntop_molec_in, nbot_molec_in, & mw_dry_in, n_avog_in, gravit_in, cpair_in, kbtz_in ) ! use constituents, only : cnst_mw !use upper_bc, only : ubc_init integer, intent(in) :: kind ! Kind of reals being passed in integer, intent(in) :: ncnst ! Number of constituents integer, intent(in) :: ntop_molec_in ! Top interface level to which molecular vertical diffusion is applied ( = 1 ) integer, intent(in) :: nbot_molec_in ! Bottom interface level to which molecular vertical diffusion is applied. real(r8), intent(in) :: rair_in real(r8), intent(in) :: mw_dry_in ! Molecular weight of dry air real(r8), intent(in) :: n_avog_in ! Avogadro's number [ molec/kmol ] real(r8), intent(in) :: gravit_in real(r8), intent(in) :: cpair_in real(r8), intent(in) :: kbtz_in ! Boltzman constant integer :: m ! Constituent index if( kind .ne. r8 ) then write(0,*) 'KIND of reals passed to init_molec_diff -- exiting.' stop 'init_molec_diff' endif !rair = rair_in !mw_dry = mw_dry_in !n_avog = n_avog_in !gravit = gravit_in !cpair = cpair_in !kbtz = kbtz_in !ntop_molec = ntop_molec_in !nbot_molec = nbot_molec_in ! Initialize upper boundary condition variables call ubc_init() ! Molecular weight factor in constitutent diffusivity ! ***** FAKE THIS FOR NOW USING MOLECULAR WEIGHT OF DRY AIR FOR ALL TRACERS **** ! !d0=> Diffusion factor [ m-1 s-1 ] molec sqrt(kg/kmol/K) [ unit ? ] allocate(mw_fac(ncnst)) do m = 1, ncnst mw_fac(m) = d0 * mw_dry_in * sqrt(1._r8/mw_dry_in + 1._r8/cnst_mw(m)) / n_avog_in end do end subroutine init_molec_diff !============================================================================ ! ! ! !============================================================================ ! INTEGER FUNCTION compute_molec_diff( lchnk , & pcols , pver , ncnst , ncol , t , pmid , pint , & zi , ztodt , kvh , kvm , tint , rhoi , tmpi2 , & kq_scal , ubc_t , ubc_mmr , dse_top , cc_top , cd_top , cnst_mw_out , & cnst_fixed_ubc_out , mw_fac_out , ntop_molec_out , nbot_molec_out ) !use upper_bc, only : ubc_get_vals !use constituents, only : cnst_mw, cnst_fixed_ubc ! --------------------- ! ! Input-Output Argument ! ! --------------------- ! INTEGER, INTENT(in) :: pcols INTEGER, INTENT(in) :: pver INTEGER, INTENT(in) :: ncnst INTEGER, INTENT(in) :: ncol ! Number of atmospheric columns INTEGER, INTENT(in) :: lchnk ! Chunk identifier REAL(r8), INTENT(in) :: t(pcols,pver) ! Temperature input REAL(r8), INTENT(in) :: pmid(pcols,pver) ! Midpoint pressures REAL(r8), INTENT(in) :: pint(pcols,pver+1) ! Interface pressures REAL(r8), INTENT(in) :: zi(pcols,pver+1) ! Interface heights REAL(r8), INTENT(in) :: ztodt ! 2 delta-t REAL(r8), INTENT(inout) :: kvh(pcols,pver+1) ! Diffusivity for heat REAL(r8), INTENT(inout) :: kvm(pcols,pver+1) ! Viscosity ( diffusivity for momentum ) REAL(r8), INTENT(inout) :: tint(pcols,pver+1) ! Interface temperature REAL(r8), INTENT(inout) :: rhoi(pcols,pver+1) ! Density ( rho ) at interfaces REAL(r8), INTENT(inout) :: tmpi2(pcols,pver+1) ! dt*(g*rho)**2/dp at interfaces REAL(r8), INTENT(out) :: kq_scal(pcols,pver+1) ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity REAL(r8), INTENT(out) :: ubc_mmr(pcols,ncnst) ! Upper boundary mixing ratios [ kg/kg ] REAL(r8), INTENT(out) :: cnst_mw_out(ncnst) LOGICAL, INTENT(out) :: cnst_fixed_ubc_out(ncnst) REAL(r8), INTENT(out) :: mw_fac_out(ncnst) REAL(r8), INTENT(out) :: dse_top(pcols) ! dse on top boundary REAL(r8), INTENT(out) :: cc_top(pcols) ! Lower diagonal at top interface REAL(r8), INTENT(out) :: cd_top(pcols) ! cc_top * dse ubc value INTEGER, INTENT(out) :: ntop_molec_out INTEGER, INTENT(out) :: nbot_molec_out ! --------------- ! ! Local variables ! ! --------------- ! INTEGER :: m ! Constituent index INTEGER :: i ! Column index INTEGER :: k ! Level index REAL(r8) :: mkvisc ! Molecular kinematic viscosity c*tint**(2/3)/rho REAL(r8) :: ubc_t(pcols) ! Upper boundary temperature (K) REAL(r8), PARAMETER :: pwr = 2._r8/3._r8 ! Exponentiation factor [ unit ? ] REAL(r8), PARAMETER :: pr_num = 1._r8 ! Prandtl number [ no unit ] REAL(r8), PARAMETER :: km_fac = 3.55E-7_r8 ! Molecular viscosity constant [ unit ? ] ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! kq_scal(1:pcols,1:pver+1) =0.0_r8 ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity ubc_mmr(1:pcols,1:ncnst) =0.0_r8 ! Upper boundary mixing ratios [ kg/kg ] cnst_mw_out(1:ncnst) =0.0_r8 cnst_fixed_ubc_out(1:ncnst)=.TRUE. mw_fac_out(1:ncnst)=0.0_r8 dse_top(1:pcols)=0.0_r8 ! dse on top boundary cc_top(1:pcols)=0.0_r8 ! Lower diagonal at top interface cd_top(1:pcols)=0.0_r8 ! cc_top * dse ubc value ntop_molec_out=0 nbot_molec_out=0 mkvisc=0.0_r8 ubc_t(1:pcols)=0.0_r8 ! Get upper boundary values CALL ubc_get_vals( lchnk,pcols, ncol,pver+1, ntop_molec, pint, zi, ubc_t, ubc_mmr ) ! Below are already computed, just need to be copied for output DO m=1,ncnst cnst_mw_out (m) = cnst_mw(m) cnst_fixed_ubc_out(m) = cnst_fixed_ubc(m) mw_fac_out (m) = mw_fac(m) END DO ntop_molec_out = ntop_molec nbot_molec_out = nbot_molec ! Density and related factors for moecular diffusion and ubc. ! Always have a fixed upper boundary T if molecular diffusion is active. Why ? DO i=1,ncol tint (i,ntop_molec) = ubc_t(i) rhoi (i,ntop_molec) = pint(i,ntop_molec) / ( rair * tint(i,ntop_molec) ) tmpi2(i,ntop_molec) = ztodt * ( gravit * rhoi(i,ntop_molec))**2 & / ( pmid(i,ntop_molec) - pint(i,ntop_molec) ) END DO ! Compute molecular kinematic viscosity, heat diffusivity and factor for constituent diffusivity ! This is a key part of the code. DO k=1,ntop_molec-1 DO i=1,ncol kq_scal(i,k) = 0._r8 END DO END DO DO k = ntop_molec, nbot_molec DO i = 1, ncol mkvisc = km_fac * tint(i,k)**pwr / rhoi(i,k) kvm(i,k) = kvm(i,k) + mkvisc kvh(i,k) = kvh(i,k) + mkvisc * pr_num kq_scal(i,k) = SQRT(tint(i,k)) / rhoi(i,k) END DO END DO DO k=nbot_molec+1,pver+1 DO i = 1, ncol kq_scal(i,k) = 0._r8 END DO END DO ! Top boundary condition for dry static energy DO i = 1, ncol dse_top(i) = cpair * tint(i,ntop_molec) + gravit * zi(i,ntop_molec) END DO ! Top value of cc for dry static energy DO i = 1, ncol cc_top(i) = ztodt * gravit**2 * rhoi(i,ntop_molec) * km_fac * ubc_t(i)**pwr / & ( ( pint(i,2) - pint(i,1) ) * ( pmid(i,1) - pint(i,1) ) ) ENDDO DO i = 1, ncol cd_top(i) = cc_top(i) * dse_top(i) END DO compute_molec_diff = 1 RETURN END FUNCTION compute_molec_diff ! =============================================================================== ! ! ! ! =============================================================================== ! SUBROUTINE compute_vdiff( & lchnk ,& !integer, intent(in) :: lchnk pcols ,& !integer, intent(in) :: pcols pver ,& !integer, intent(in) :: pver ncnst ,& !integer, intent(in) :: ncnst ncol ,& !integer, intent(in) :: ncol ! Number of atmospheric columns pmid ,& !real(r8), intent(in) :: pmid(pcols,pver) ! Mid-point pressures [ Pa ] pint ,& !real(r8), intent(in) :: pint(pcols,pver+1) ! Interface pressures [ Pa ] rpdel ,& !real(r8), intent(in) :: rpdel(pcols,pver) ! 1./pdel t ,& !real(r8), intent(in) :: t(pcols,pver) ! Temperature [ K ] ztodt ,& !real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] taux ,& !real(r8), intent(in) :: taux(pcols) ! Surface zonal stress. Input u-momentum per unit time per unit area into the atmosphere [ N/m2 ] tauy ,& !real(r8), intent(in) :: tauy(pcols) ! Surface meridional stress. Input v-momentum per unit time per unit area into the atmosphere [ N/m2 ] shflx ,& !real(r8), intent(in) :: shflx(pcols) ! Surface sensible heat flux [ W/m2 ] cflx ,& !real(r8), intent(in) :: cflx(pcols,ncnst) ! Surface constituent flux [ kg/m2/s ] ntop ,& !integer, intent(in) :: ntop ! Top interface level to which vertical diffusion is applied ( = 1 ). nbot ,& !integer, intent(in) :: nbot ! Bottom interface level to which vertical diffusion is applied ( = pver ). kvh ,& !real(r8), intent(inout) :: kvh(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] kvm ,& !real(r8), intent(inout) :: kvm(pcols,pver+1) ! Eddy viscosity ( Eddy diffusivity for momentum ) [ m2/s ] kvq ,& !real(r8), intent(inout) :: kvq(pcols,pver+1) ! Eddy diffusivity for constituents cgs ,& !real(r8), intent(inout) :: cgs(pcols,pver+1) ! Counter-gradient star [ cg/flux ] cgh ,& !real(r8), intent(inout) :: cgh(pcols,pver+1) ! Counter-gradient term for heat zi ,& !real(r8), intent(in) :: zi(pcols,pver+1) ! Interface heights [ m ] ksrftms ,& !real(r8), intent(in) :: ksrftms(pcols) ! Surface drag coefficient for turbulent mountain stress. > 0. [ kg/s/m2 ] qmincg ,& !real(r8), intent(in) :: qmincg(ncnst) ! Minimum constituent mixing ratios from cg fluxes fieldlist ,& !type(vdiff_selector), intent(in) :: fieldlist ! Array of flags selecting which fields to diffuse u ,& !real(r8), intent(inout) :: u(pcols,pver) ! U wind. This input is the 'raw' input wind to PBL scheme without iterative provisional update. [ m/s ] v ,& !real(r8), intent(inout) :: v(pcols,pver) ! V wind. This input is the 'raw' input wind to PBL scheme without iterative provisional update. [ m/s ] q ,& !real(r8), intent(inout) :: q(pcols,pver,ncnst) ! Moisture and trace constituents [ kg/kg, #/kg ? ] dse ,& !real(r8), intent(inout) :: dse(pcols,pver) ! Dry static energy [ J/kg ] tautmsx ,& !real(r8), intent(inout) :: tauresx(pcols) ! Input : Reserved surface stress at previous time step tautmsy ,& !real(r8), intent(inout) :: tauresy(pcols) ! Output : Reserved surface stress at current time step dtk ,& !real(r8), intent(out) :: dtk(pcols,pver) ! T tendency from KE dissipation topflx ,& !real(r8), intent(out) :: topflx(pcols) ! Molecular heat flux at the top interface errstring ,& !character(128), intent(out) :: errstring ! Output status tauresx ,& !real(r8), intent(out) :: tautmsx(pcols) ! Implicit zonal turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ] tauresy ,& !real(r8), intent(out) :: tautmsy(pcols) ! Implicit meridional turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ] itaures )!,& !integer, intent(in) :: itaures ! Indicator determining whether 'tauresx,tauresy' is updated (1) or non-updated (0) in this subroutine. ! do_molec_diff ,& ! ! compute_molec_diff ,& ! ! compute_molec_diff ) !integer, external, optional :: compute_molec_diff ! Constituent-independent moleculuar diffusivity routine !-------------------------------------------------------------------------- ! ! Driver routine to compute vertical diffusion of momentum, moisture, trace ! ! constituents and dry static energy. The new temperature is computed from ! ! the diffused dry static energy. ! ! Turbulent diffusivities and boundary layer nonlocal transport terms are ! ! obtained from the turbulence module. ! !-------------------------------------------------------------------------- ! !use phys_debug_util, only : phys_debug_col !use time_manager, only : is_first_step, get_nstep !use phys_control, only : phys_getopts ! Modification : Ideally, we should diffuse 'liquid-ice static energy' (sl), not the dry static energy. ! Also, vertical diffusion of cloud droplet number concentration and aerosol number ! concentration should be done very carefully in the future version. ! --------------- ! ! Input Arguments ! ! --------------- ! INTEGER, INTENT(in) :: lchnk INTEGER, INTENT(in) :: pcols INTEGER, INTENT(in) :: pver INTEGER, INTENT(in) :: ncnst INTEGER, INTENT(in) :: ncol ! Number of atmospheric columns INTEGER, INTENT(in) :: ntop ! Top interface level to which vertical diffusion is applied ( = 1 ). INTEGER, INTENT(in) :: nbot ! Bottom interface level to which vertical diffusion is applied ( = pver ). INTEGER, INTENT(in) :: itaures ! Indicator determining whether 'tauresx,tauresy' is updated (1) or non-updated (0) in this subroutine. REAL(r8), INTENT(in) :: pmid(pcols,pver) ! Mid-point pressures [ Pa ] REAL(r8), INTENT(in) :: pint(pcols,pver+1) ! Interface pressures [ Pa ] REAL(r8), INTENT(in) :: rpdel(pcols,pver) ! 1./pdel REAL(r8), INTENT(in) :: t(pcols,pver) ! Temperature [ K ] REAL(r8), INTENT(in) :: ztodt ! 2 delta-t [ s ] REAL(r8), INTENT(in) :: taux(pcols) ! Surface zonal stress. Input u-momentum per unit time per unit area into the atmosphere [ N/m2 ] REAL(r8), INTENT(in) :: tauy(pcols) ! Surface meridional stress. Input v-momentum per unit time per unit area into the atmosphere [ N/m2 ] REAL(r8), INTENT(in) :: shflx(pcols) ! Surface sensible heat flux [ W/m2 ] REAL(r8), INTENT(in) :: cflx(pcols,ncnst) ! Surface constituent flux [ kg/m2/s ] REAL(r8), INTENT(in) :: zi(pcols,pver+1) ! Interface heights [ m ] REAL(r8), INTENT(in) :: ksrftms(pcols) ! Surface drag coefficient for turbulent mountain stress. > 0. [ kg/s/m2 ] REAL(r8), INTENT(in) :: qmincg(ncnst) ! Minimum constituent mixing ratios from cg fluxes !logical, intent(in) :: do_molec_diff ! Flag indicating multiple constituent diffusivities !integer, external, optional :: compute_molec_diff ! Constituent-independent moleculuar diffusivity routine TYPE(vdiff_selector), INTENT(in) :: fieldlist ! Array of flags selecting which fields to diffuse ! ---------------------- ! ! Input-Output Arguments ! ! ---------------------- ! REAL(r8), INTENT(inout) :: kvh(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] REAL(r8), INTENT(inout) :: kvm(pcols,pver+1) ! Eddy viscosity ( Eddy diffusivity for momentum ) [ m2/s ] REAL(r8), INTENT(inout) :: kvq(pcols,pver+1) ! Eddy diffusivity for constituents REAL(r8), INTENT(inout) :: cgs(pcols,pver+1) ! Counter-gradient star [ cg/flux ] REAL(r8), INTENT(inout) :: cgh(pcols,pver+1) ! Counter-gradient term for heat REAL(r8), INTENT(inout) :: u(pcols,pver) ! U wind. This input is the 'raw' input wind to PBL scheme without iterative provisional update. [ m/s ] REAL(r8), INTENT(inout) :: v(pcols,pver) ! V wind. This input is the 'raw' input wind to PBL scheme without iterative provisional update. [ m/s ] REAL(r8), INTENT(inout) :: q(pcols,pver,ncnst) ! Moisture and trace constituents [ kg/kg, #/kg ? ] REAL(r8), INTENT(inout) :: dse(pcols,pver) ! Dry static energy [ J/kg ] REAL(r8), INTENT(inout) :: tauresx(pcols) ! Input : Reserved surface stress at previous time step REAL(r8), INTENT(inout) :: tauresy(pcols) ! Output : Reserved surface stress at current time step ! ---------------- ! ! Output Arguments ! ! ---------------- ! REAL(r8), INTENT(out) :: dtk(pcols,pver) ! T tendency from KE dissipation REAL(r8), INTENT(out) :: tautmsx(pcols) ! Implicit zonal turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ] REAL(r8), INTENT(out) :: tautmsy(pcols) ! Implicit meridional turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ] REAL(r8), INTENT(out) :: topflx(pcols) ! Molecular heat flux at the top interface CHARACTER(128), INTENT(out) :: errstring ! Output status ! --------------- ! ! Local Variables ! ! --------------- ! INTEGER :: i, k, m, icol ! Longitude, level, constituent indices INTEGER :: status ! Status indicator INTEGER :: ntop_molec ! Top level where molecular diffusivity is applied LOGICAL :: lqtst(pcols) ! Adjust vertical profiles LOGICAL :: need_decomp ! Whether to compute a new decomposition LOGICAL :: cnst_fixed_ubc(ncnst) ! Whether upper boundary condition is fixed !logical :: do_iss ! Use implicit turbulent surface stress computation REAL(r8) :: tmpm(pcols,pver) ! Potential temperature, ze term in tri-diag sol'n REAL(r8) :: ca(pcols,pver) ! - Upper diag of tri-diag matrix REAL(r8) :: cc(pcols,pver) ! - Lower diag of tri-diag matrix REAL(r8) :: dnom(pcols,pver) ! 1./(1. + ca(k) + cc(k) - cc(k)*ze(k-1)) REAL(r8) :: tmp1(pcols) ! Temporary storage REAL(r8) :: tmpi1(pcols,pver+1) ! Interface KE dissipation REAL(r8) :: tint(pcols,pver+1) ! Interface temperature REAL(r8) :: rhoi(pcols,pver+1) ! rho at interfaces REAL(r8) :: tmpi2(pcols,pver+1) ! dt*(g*rho)**2/dp at interfaces REAL(r8) :: rrho(pcols) ! 1./bottom level density REAL(r8) :: zero(pcols) ! Zero array for surface heat exchange coefficients REAL(r8) :: tautotx(pcols) ! Total surface stress ( zonal ) REAL(r8) :: tautoty(pcols) ! Total surface stress ( meridional ) REAL(r8) :: dinp_u(pcols,pver+1) ! Vertical difference at interfaces, input u REAL(r8) :: dinp_v(pcols,pver+1) ! Vertical difference at interfaces, input v REAL(r8) :: dout_u ! Vertical difference at interfaces, output u REAL(r8) :: dout_v ! Vertical difference at interfaces, output v REAL(r8) :: dse_top(pcols) ! dse on top boundary REAL(r8) :: cc_top(pcols) ! Lower diagonal at top interface REAL(r8) :: cd_top(pcols) ! REAL(r8) :: rghd(pcols,pver+1) ! (1/H_i - 1/H) *(g*rho)^(-1) REAL(r8) :: qtm(pcols,pver) ! Temporary copy of q REAL(r8) :: kq_scal(pcols,pver+1) ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity REAL(r8) :: mw_fac(ncnst) ! sqrt(1/M_q + 1/M_d) for this constituent REAL(r8) :: cnst_mw(ncnst) ! Molecular weight [ kg/kmole ] REAL(r8) :: ubc_mmr(pcols,ncnst) ! Upper boundary mixing ratios [ kg/kg ] REAL(r8) :: ubc_t(pcols) ! Upper boundary temperature [ K ] REAL(r8) :: ws(pcols) ! Lowest-level wind speed [ m/s ] REAL(r8) :: tau(pcols) ! Turbulent surface stress ( not including mountain stress ) REAL(r8) :: ksrfturb(pcols) ! Surface drag coefficient of 'normal' stress. > 0. Virtual mass input per unit time per unit area [ kg/s/m2 ] REAL(r8) :: ksrf(pcols) ! Surface drag coefficient of 'normal' stress + Surface drag coefficient of 'tms' stress. > 0. [ kg/s/m2 ] REAL(r8) :: usum_in(pcols) ! Vertical integral of input u-momentum. Total zonal momentum per unit area in column [ sum of u*dp/g = kg m/s m-2 ] REAL(r8) :: vsum_in(pcols) ! Vertical integral of input v-momentum. Total meridional momentum per unit area in column [ sum of v*dp/g = kg m/s m-2 ] REAL(r8) :: usum_mid(pcols) ! Vertical integral of u-momentum after adding explicit residual stress REAL(r8) :: vsum_mid(pcols) ! Vertical integral of v-momentum after adding explicit residual stress REAL(r8) :: usum_out(pcols) ! Vertical integral of u-momentum after doing implicit diffusion REAL(r8) :: vsum_out(pcols) ! Vertical integral of v-momentum after doing implicit diffusion REAL(r8) :: tauimpx(pcols) ! Actual net stress added at the current step other than mountain stress REAL(r8) :: tauimpy(pcols) ! Actual net stress added at the current step other than mountain stress REAL(r8) :: wsmin ! Minimum sfc wind speed for estimating frictional transfer velocity ksrf. [ m/s ] REAL(r8) :: ksrfmin ! Minimum surface drag coefficient [ kg/s/m^2 ] REAL(r8) :: timeres ! Relaxation time scale of residual stress ( >= dt ) [ s ] REAL(r8) :: ramda ! dt/timeres [ no unit ] REAL(r8) :: psum REAL(r8) :: u_in, u_res, tauresx_in REAL(r8) :: v_in, v_res, tauresy_in ! ------------------------------------------------ ! ! Parameters for implicit surface stress treatment ! ! ------------------------------------------------ ! ntop_molec=0 wsmin = 1._r8 ! Minimum wind speed for ksrfturb computation [ m/s ] ksrfmin = 1.e-4_r8 ! Minimum surface drag coefficient [ kg/s/m^2 ] timeres = 7200._r8 ! Relaxation time scale of residual stress ( >= dt ) [ s ] !call phys_getopts( do_iss_out = do_iss ) dtk=0.0_r8 ! T tendency from KE dissipation tautmsx=0.0_r8 ! Implicit zonal turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ] tautmsy=0.0_r8 ! Implicit meridional turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ] topflx=0.0_r8 ! Molecular heat flux at the top interface DO k=1,pver+1 DO i=1,pcols tmpi1 (i,k)=0.0_r8! Interface KE dissipation tint (i,k)=0.0_r8! Interface temperature rhoi (i,k)=0.0_r8! rho at interfaces tmpi2 (i,k)=0.0_r8! dt*(g*rho)**2/dp at interfaces dinp_u(i,k)=0.0_r8! Vertical difference at interfaces, input u dinp_v(i,k)=0.0_r8! Vertical difference at interfaces, input v rghd (i,k)=0.0_r8! (1/H_i - 1/H) *(g*rho)^(-1) kq_scal(i,k)=0.0_r8! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity END DO END DO DO k=1,pver DO i=1,pcols tmpm(i,k)=0.0_r8! Potential temperature, ze term in tri-diag sol'n ca (i,k)=0.0_r8! - Upper diag of tri-diag matrix cc (i,k)=0.0_r8! - Lower diag of tri-diag matrix dnom(i,k)=0.0_r8! 1./(1. + ca(k) + cc(k) - cc(k)*ze(k-1)) qtm (i,k)=0.0_r8! Temporary copy of q END DO END DO DO i=1,pcols tmp1 (i) =0.0_r8! Temporary storage rrho (i) =0.0_r8! 1./bottom level density zero (i) =0.0_r8! Zero array for surface heat exchange coefficients tautotx (i) =0.0_r8! Total surface stress ( zonal ) tautoty (i) =0.0_r8! Total surface stress ( meridional ) dse_top (i) =0.0_r8! dse on top boundary cc_top (i) =0.0_r8! Lower diagonal at top interface cd_top (i) =0.0_r8! ws (i) =0.0_r8! Lowest-level wind speed [ m/s ] tau (i) =0.0_r8! Turbulent surface stress ( not including mountain stress ) ksrfturb(i) =0.0_r8! Surface drag coefficient of 'normal' stress. > 0. Virtual mass input per unit time per unit area [ kg/s/m2 ] ksrf (i) =0.0_r8! Surface drag coefficient of 'normal' stress + Surface drag coefficient of 'tms' stress. > 0. [ kg/s/m2 ] usum_in (i) =0.0_r8! Vertical integral of input u-momentum. Total zonal momentum per unit area in column [ sum of u*dp/g = kg m/s m-2 ] vsum_in (i) =0.0_r8! Vertical integral of input v-momentum. Total meridional momentum per unit area in column [ sum of v*dp/g = kg m/s m-2 ] usum_mid(i) =0.0_r8! Vertical integral of u-momentum after adding explicit residual stress vsum_mid(i) =0.0_r8! Vertical integral of v-momentum after adding explicit residual stress usum_out(i) =0.0_r8! Vertical integral of u-momentum after doing implicit diffusion vsum_out(i) =0.0_r8! Vertical integral of v-momentum after doing implicit diffusion tauimpx (i) =0.0_r8! Actual net stress added at the current step other than mountain stress tauimpy (i) =0.0_r8! Actual net stress added at the current step other than mountain stress ubc_t (i) =0.0_r8! Upper boundary temperature [ K ] END DO DO m=1,ncnst mw_fac (m) =0.0_r8 ! sqrt(1/M_q + 1/M_d) for this constituent cnst_mw (m) =0.0_r8 ! Molecular weight [ kg/kmole ] DO i=1,pcols ubc_mmr (i,m)=0.0_r8 ! Upper boundary mixing ratios [ kg/kg ] END DO END DO ramda=0.0_r8 ! dt/timeres [ no unit ] psum=0.0_r8 u_in=0.0_r8 ; u_res=0.0_r8 ; tauresx_in=0.0_r8 v_in=0.0_r8 ; v_res=0.0_r8 ; tauresy_in=0.0_r8 dout_u=0.0_r8 ! Vertical difference at interfaces, output u dout_v=0.0_r8 ! Vertical difference at interfaces, output v ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! errstring = '' IF( ( diffuse(fieldlist,'u') .OR. diffuse(fieldlist,'v') ) .AND. .NOT. diffuse(fieldlist,'s') ) THEN errstring = 'diffusion_solver.compute_vdiff: must diffuse s if diffusing u or v' RETURN END IF zero(:) = 0._r8 ! Compute 'rho' and 'dt*(g*rho)^2/dp' at interfaces DO i = 1, ncol tint(i,1) = t(i,1) rhoi(i,1) = pint(i,1) / (rair*tint(i,1)) END DO DO k = 2, pver DO i = 1, ncol tint(i,k) = 0.5_r8 * ( t(i,k) + t(i,k-1) ) rhoi(i,k) = pint(i,k) / (rair*tint(i,k)) tmpi2(i,k) = ztodt * ( gravit*rhoi(i,k) )**2 / ( pmid(i,k) - pmid(i,k-1) ) END DO END DO DO i = 1, ncol tint(i,pver+1) = t(i,pver) rhoi(i,pver+1) = pint(i,pver+1) / ( rair*tint(i,pver+1) ) END DO DO i = 1, ncol rrho(i) = rair * t(i,pver) / pmid(i,pver) tmp1(i) = ztodt * gravit * rpdel(i,pver) END DO !--------------------------------------- ! ! Computation of Molecular Diffusivities ! !--------------------------------------- ! ! Modification : Why 'kvq' is not changed by molecular diffusion ? IF( do_molec_diff ) THEN !if( (.not.present(compute_molec_diff)) ) then ! errstring = 'compute_vdiff: do_molec_diff true but compute_molec_diff or vd_lu_qdecomp missing' ! return !endif ! The next subroutine 'compute_molec_diff' : ! Modifies : kvh, kvm, tint, rhoi, and tmpi2 ! Returns : kq_scal, ubc_t, ubc_mmr, dse_top, cc_top, cd_top, cnst_mw, ! cnst_fixed_ubc , mw_fac , ntop_molec status = compute_molec_diff( lchnk , & pcols , pver , ncnst , ncol , t , pmid , pint , & zi , ztodt , kvh , kvm , tint , rhoi , tmpi2 , & kq_scal , ubc_t , ubc_mmr , dse_top , cc_top , cd_top , cnst_mw , & cnst_fixed_ubc , mw_fac , ntop_molec , nbot_molec ) ELSE kq_scal(:,:) = 0._r8 cd_top(:) = 0._r8 cc_top(:) = 0._r8 ENDIF !---------------------------- ! ! Diffuse Horizontal Momentum ! !---------------------------- ! IF( diffuse(fieldlist,'u') .OR. diffuse(fieldlist,'v') ) THEN ! Compute the vertical upward differences of the input u,v for KE dissipation ! at each interface. ! Velocity = 0 at surface, so difference at the bottom interface is -u,v(pver) ! These 'dinp_u, dinp_v' are computed using the non-diffused input wind. DO i = 1, ncol dinp_u(i,1) = 0._r8 dinp_v(i,1) = 0._r8 dinp_u(i,pver+1) = -u(i,pver) dinp_v(i,pver+1) = -v(i,pver) END DO DO k = 2, pver DO i = 1, ncol dinp_u(i,k) = u(i,k) - u(i,k-1) dinp_v(i,k) = v(i,k) - v(i,k-1) END DO END DO ! -------------------------------------------------------------- ! ! Do 'Implicit Surface Stress' treatment for numerical stability ! ! in the lowest model layer. ! ! -------------------------------------------------------------- ! IF( do_iss ) THEN ! Compute surface drag coefficient for implicit diffusion ! including turbulent turbulent mountain stress. DO i = 1, ncol ws(i) = MAX( SQRT( u(i,pver)**2._r8 + v(i,pver)**2._r8 ), wsmin ) tau(i) = SQRT( taux(i)**2._r8 + tauy(i)**2._r8 ) ksrfturb(i) = MAX( tau(i) / ws(i), ksrfmin ) END DO DO i = 1, ncol ksrf(i) = ksrfturb(i) + ksrftms(i) ! Do all surface stress ( normal + tms ) implicitly END DO ! Vertical integration of input momentum. ! This is total horizontal momentum per unit area [ kg*m/s/m2 ] in each column. ! Note (u,v) are the raw input to the PBL scheme, not the ! provisionally-marched ones within the iteration loop of the PBL scheme. DO i = 1, ncol usum_in(i) = 0._r8 vsum_in(i) = 0._r8 DO k = 1, pver usum_in(i) = usum_in(i) + (1._r8/gravit)*u(i,k)/rpdel(i,k) vsum_in(i) = vsum_in(i) + (1._r8/gravit)*v(i,k)/rpdel(i,k) END DO END DO ! Add residual stress of previous time step explicitly into the lowest ! model layer with a relaxation time scale of 'timeres'. ramda = ztodt / timeres DO i = 1, ncol u(i,pver) = u(i,pver) + tmp1(i)*tauresx(i)*ramda v(i,pver) = v(i,pver) + tmp1(i)*tauresy(i)*ramda END DO ! Vertical integration of momentum after adding explicit residual stress ! into the lowest model layer. DO i = 1, ncol usum_mid(i) = 0._r8 vsum_mid(i) = 0._r8 DO k = 1, pver usum_mid(i) = usum_mid(i) + (1._r8/gravit)*u(i,k)/rpdel(i,k) vsum_mid(i) = vsum_mid(i) + (1._r8/gravit)*v(i,k)/rpdel(i,k) END DO END DO ! Debug ! icol = phys_debug_col(lchnk) ! if ( icol > 0 .and. get_nstep() .ge. 1 ) then ! tauresx_in = tauresx(icol) ! tauresy_in = tauresy(icol) ! u_in = u(icol,pver) - tmp1(icol) * tauresx(icol) * ramda ! v_in = v(icol,pver) - tmp1(icol) * tauresy(icol) * ramda ! u_res = u(icol,pver) ! v_res = v(icol,pver) ! endif ! Debug ELSE ! In this case, do 'turbulent mountain stress' implicitly, ! but do 'normal turbulent stress' explicitly. ! In this case, there is no 'redisual stress' as long as 'tms' is ! treated in a fully implicit wway, which is true. ! 1. Do 'tms' implicitly DO i = 1, ncol ksrf(i) = ksrftms(i) END DO ! 2. Do 'normal stress' explicitly DO i = 1, ncol u(i,pver) = u(i,pver) + tmp1(i)*taux(i) v(i,pver) = v(i,pver) + tmp1(i)*tauy(i) END DO END IF ! End of 'do iss' ( implicit surface stress ) ! --------------------------------------------------------------------------------------- ! ! Diffuse horizontal momentum implicitly using tri-diagnonal matrix. ! ! The 'u,v' are input-output: the output 'u,v' are implicitly diffused winds. ! ! For implicit 'normal' stress : ksrf = ksrftms + ksrfturb, ! ! u(pver) : explicitly include 'redisual normal' stress ! ! For explicit 'normal' stress : ksrf = ksrftms ! ! u(pver) : explicitly include 'normal' stress ! ! Note that in all the two cases above, 'tms' is fully implicitly treated. ! ! --------------------------------------------------------------------------------------- ! CALL vd_lu_decomp( pcols , pver , ncol , & ksrf , kvm , tmpi2 , rpdel , ztodt , zero , & ca , cc , dnom , tmpm , ntop , nbot ) CALL vd_lu_solve( pcols , pver , ncol , & u , ca , tmpm , dnom , ntop , nbot , zero ) CALL vd_lu_solve( pcols , pver , ncol , & v , ca , tmpm , dnom , ntop , nbot , zero ) ! ---------------------------------------------------------------------- ! ! Calculate 'total' ( tautotx ) and 'tms' ( tautmsx ) stresses that ! ! have been actually added into the atmosphere at the current time step. ! ! Also, update residual stress, if required. ! ! ---------------------------------------------------------------------- ! DO i = 1, ncol ! Compute the implicit 'tms' using the updated winds. ! Below 'tautmsx(i),tautmsy(i)' are pure implicit mountain stresses ! that has been actually added into the atmosphere both for explicit ! and implicit approach. tautmsx(i) = -ksrftms(i)*u(i,pver) tautmsy(i) = -ksrftms(i)*v(i,pver) IF( do_iss ) THEN ! Compute vertical integration of final horizontal momentum usum_out(i) = 0._r8 vsum_out(i) = 0._r8 DO k = 1, pver usum_out(i) = usum_out(i) + (1._r8/gravit)*u(i,k)/rpdel(i,k) vsum_out(i) = vsum_out(i) + (1._r8/gravit)*v(i,k)/rpdel(i,k) END DO ! Compute net stress added into the atmosphere at the current time step. ! Note that the difference between 'usum_in' and 'usum_out' are induced ! by 'explicit residual stress + implicit total stress' for implicit case, while ! by 'explicit normal stress + implicit tms stress' for explicit case. ! Here, 'tautotx(i)' is net stress added into the air at the current time step. tauimpx(i) = ( usum_out(i) - usum_in(i) ) / ztodt tauimpy(i) = ( vsum_out(i) - vsum_in(i) ) / ztodt tautotx(i) = tauimpx(i) tautoty(i) = tauimpy(i) ! Compute redisual stress and update if required. ! Note that the total stress we should have added at the current step is ! the sum of 'taux(i) - ksrftms(i)*u(i,pver) + tauresx(i)'. IF( itaures .EQ. 1 ) THEN tauresx(i) = taux(i) + tautmsx(i) + tauresx(i) - tauimpx(i) tauresy(i) = tauy(i) + tautmsy(i) + tauresy(i) - tauimpy(i) ENDIF ELSE tautotx(i) = tautmsx(i) + taux(i) tautoty(i) = tautmsy(i) + tauy(i) tauresx(i) = 0._r8 tauresy(i) = 0._r8 END IF ! End of 'do_iss' routine END DO ! End of 'do i = 1, ncol' routine ! Debug ! icol = phys_debug_col(lchnk) ! if ( icol > 0 .and. get_nstep() .ge. 1 ) then ! write(iulog,*) ! write(iulog,*) 'diffusion_solver debug' ! write(iulog,*) ! write(iulog,*) 'u_in, u_res, u_out' ! write(iulog,*) u_in, u_res, u(icol,pver) ! write(iulog,*) 'tauresx_in, tautmsx, tauimpx(actual), tauimpx(derived), tauresx_out, taux' ! write(iulog,*) tauresx_in, tautmsx(icol), tauimpx(icol), -ksrf(icol)*u(icol,pver), tauresx(icol), taux(icol) ! write(iulog,*) ! write(iulog,*) 'v_in, v_res, v_out' ! write(iulog,*) v_in, v_res, v(icol,pver) ! write(iulog,*) 'tauresy_in, tautmsy, tauimpy(actual), tauimpy(derived), tauresy_out, tauy' ! write(iulog,*) tauresy_in, tautmsy(icol), tauimpy(icol), -ksrf(icol)*v(icol,pver), tauresy(icol), tauy(icol) ! write(iulog,*) ! write(iulog,*) 'itaures, ksrf, ksrfturb, ksrftms' ! write(iulog,*) itaures, ksrf(icol), ksrfturb(icol), ksrftms(icol) ! write(iulog,*) ! endif ! Debug ! ------------------------------------ ! ! Calculate kinetic energy dissipation ! ! ------------------------------------ ! ! Modification : In future, this should be set exactly same as ! the ones in the convection schemes ! 1. Compute dissipation term at interfaces ! Note that 'u,v' are already diffused wind, and 'tautotx,tautoty' are ! implicit stress that has been actually added. On the other hand, ! 'dinp_u, dinp_v' were computed using non-diffused input wind. ! Modification : I should check whether non-consistency between 'u' and 'dinp_u' ! is correctly intended approach. I think so. k = pver + 1 DO i = 1, ncol tmpi1(i,1) = 0._r8 tmpi1(i,k) = 0.5_r8 * ztodt * gravit * & ( (-u(i,k-1) + dinp_u(i,k))*tautotx(i) + (-v(i,k-1) + dinp_v(i,k))*tautoty(i) ) END DO DO k = 2, pver DO i = 1, ncol dout_u = u(i,k) - u(i,k-1) dout_v = v(i,k) - v(i,k-1) tmpi1(i,k) = 0.25_r8 * tmpi2(i,k) * kvm(i,k) * & ( dout_u**2 + dout_v**2 + dout_u*dinp_u(i,k) + dout_v*dinp_v(i,k) ) END DO END DO ! 2. Compute dissipation term at midpoints, add to dry static energy DO k = 1, pver DO i = 1, ncol dtk(i,k) = ( tmpi1(i,k+1) + tmpi1(i,k) ) * rpdel(i,k) dse(i,k) = dse(i,k) + dtk(i,k) END DO END DO END IF ! End of diffuse horizontal momentum, diffuse(fieldlist,'u') routine !-------------------------- ! ! Diffuse Dry Static Energy ! !-------------------------- ! ! Modification : In future, we should diffuse the fully conservative ! moist static energy,not the dry static energy. IF( diffuse(fieldlist,'s') ) THEN ! Add counter-gradient to input static energy profiles DO k = 1, pver DO i=1,ncol dse(i,k) = dse(i,k) + ztodt * rpdel(i,k) * gravit * & ( rhoi(i,k+1) * kvh(i,k+1) * cgh(i,k+1) & - rhoi(i,k ) * kvh(i,k ) * cgh(i,k ) ) END DO END DO ! Add the explicit surface fluxes to the lowest layer DO i=1,ncol dse(i,pver) = dse(i,pver) + tmp1(i) * shflx(i) END DO ! Diffuse dry static energy CALL vd_lu_decomp( pcols , pver , ncol , & zero , kvh , tmpi2 , rpdel , ztodt , cc_top, & ca , cc , dnom , tmpm , ntop , nbot ) CALL vd_lu_solve( pcols , pver , ncol , & dse , ca , tmpm , dnom , ntop , nbot , cd_top ) ! Calculate flux at top interface ! Modification : Why molecular diffusion does not work for dry static energy in all layers ? IF( do_molec_diff ) THEN DO i=1,ncol topflx(i) = - kvh(i,ntop_molec) * tmpi2(i,ntop_molec) / (ztodt*gravit) * & ( dse(i,ntop_molec) - dse_top(i) ) END DO END IF ENDIF !---------------------------- ! ! Diffuse Water Vapor Tracers ! !---------------------------- ! ! Modification : For aerosols, I need to use separate treatment ! for aerosol mass and aerosol number. ! Loop through constituents need_decomp = .TRUE. DO m = 1, ncnst IF( diffuse(fieldlist,'q',m) ) THEN ! Add the nonlocal transport terms to constituents in the PBL. ! Check for neg q's in each constituent and put the original vertical ! profile back if a neg value is found. A neg value implies that the ! quasi-equilibrium conditions assumed for the countergradient term are ! strongly violated. DO k = 1, pver DO i=1,ncol qtm(i,k) = q(i,k,m) END DO END DO DO k = 1, pver DO i=1,ncol q(i,k,m) = q(i,k,m) + & ztodt * rpdel(i,k) * gravit * ( cflx(i,m) * rrho(i) ) * & ( rhoi(i,k+1) * kvh(i,k+1) * cgs(i,k+1) & - rhoi(i,k ) * kvh(i,k ) * cgs(i,k ) ) END DO END DO DO i=1,ncol lqtst(i) = ALL(q(i,1:pver,m) >= qmincg(m)) END DO DO k = 1, pver DO i=1,ncol q(i,k,m) = MERGE( q(i,k,m), qtm(i,k), lqtst(i) ) END DO END DO ! Add the explicit surface fluxes to the lowest layer DO i=1,ncol q(i,pver,m) = q(i,pver,m) + tmp1(i) * cflx(i,m) END DO ! Diffuse constituents. IF( need_decomp ) THEN CALL vd_lu_decomp( pcols , pver , ncol , & zero , kvq , tmpi2 , rpdel , ztodt , zero , & ca , cc , dnom , tmpm , ntop , nbot ) IF( do_molec_diff ) THEN ! Update decomposition in molecular diffusion range, include separation velocity term status = vd_lu_qdecomp( pcols , pver , ncol , cnst_fixed_ubc(m), cnst_mw(m), ubc_mmr(:,m), & kvq , kq_scal, mw_fac(m) , tmpi2 , rpdel , & ca , cc , dnom , tmpm , rhoi , & tint , ztodt , ntop_molec, nbot_molec , cd_top ) ELSE need_decomp = .FALSE. ENDIF END IF CALL vd_lu_solve( pcols , pver , ncol , & q(1:ncol,1:pver,m) , ca, tmpm , dnom , ntop , nbot , cd_top ) END IF END DO RETURN END SUBROUTINE compute_vdiff ! ! !============================================================================ ! INTEGER FUNCTION vd_lu_qdecomp( pcols , pver , ncol , fixed_ubc , mw , ubc_mmr , & kv , kq_scal, mw_facm , tmpi , rpdel , & ca , cc , dnom , ze , rhoi , & tint , ztodt , ntop_molec , nbot_molec , cd_top ) !------------------------------------------------------------------------------ ! ! Add the molecular diffusivity to the turbulent diffusivity for a consitutent. ! ! Update the superdiagonal (ca(k)), diagonal (cb(k)) and subdiagonal (cc(k)) ! ! coefficients of the tridiagonal diffusion matrix, also ze and denominator. ! !------------------------------------------------------------------------------ ! ! ---------------------- ! ! Input-Output Arguments ! ! ---------------------- ! INTEGER, INTENT(in) :: pcols INTEGER, INTENT(in) :: pver INTEGER, INTENT(in) :: ncol ! Number of atmospheric columns INTEGER, INTENT(in) :: ntop_molec INTEGER, INTENT(in) :: nbot_molec LOGICAL, INTENT(in) :: fixed_ubc ! Fixed upper boundary condition flag REAL(r8), INTENT(in) :: kv(pcols,pver+1) ! Eddy diffusivity REAL(r8), INTENT(in) :: kq_scal(pcols,pver+1) ! Molecular diffusivity ( kq_fac*sqrt(T)*m_d/rho ) REAL(r8), INTENT(in) :: mw ! Molecular weight for this constituent REAL(r8), INTENT(in) :: ubc_mmr(pcols) ! Upper boundary mixing ratios [ kg/kg ] REAL(r8), INTENT(in) :: mw_facm ! sqrt(1/M_q + 1/M_d) for this constituent REAL(r8), INTENT(in) :: tmpi(pcols,pver+1) ! dt*(g/R)**2/dp*pi(k+1)/(.5*(tm(k+1)+tm(k))**2 REAL(r8), INTENT(in) :: rpdel(pcols,pver) ! 1./pdel ( thickness bet interfaces ) REAL(r8), INTENT(in) :: rhoi(pcols,pver+1) ! Density at interfaces [ kg/m3 ] REAL(r8), INTENT(in) :: tint(pcols,pver+1) ! Interface temperature [ K ] REAL(r8), INTENT(in) :: ztodt ! 2 delta-t [ s ] REAL(r8), INTENT(inout) :: ca(pcols,pver) ! -Upper diagonal REAL(r8), INTENT(inout) :: cc(pcols,pver) ! -Lower diagonal REAL(r8), INTENT(inout) :: dnom(pcols,pver) ! 1./(1. + ca(k) + cc(k) - cc(k)*ze(k-1)) , 1./(b(k) - c(k)*e(k-1)) REAL(r8), INTENT(inout) :: ze(pcols,pver) ! Term in tri-diag. matrix system REAL(r8), INTENT(out) :: cd_top(pcols) ! Term for updating top level with ubc ! --------------- ! ! Local Variables ! ! --------------- ! INTEGER :: i ! Longitude index INTEGER :: k, kp1 ! Vertical indicies REAL(r8) :: rghd(pcols,pver+1) ! (1/H_i - 1/H) * (rho*g)^(-1) REAL(r8) :: kmq(ncol) ! Molecular diffusivity for constituent REAL(r8) :: wrk0(ncol) ! Work variable REAL(r8) :: wrk1(ncol) ! Work variable REAL(r8) :: cb(pcols,pver) ! - Diagonal REAL(r8) :: kvq(pcols,pver+1) ! Output vertical diffusion coefficient REAL(R8), PARAMETER :: SHR_CONST_BOLTZ = 1.38065e-23_R8 ! Boltzmann's constant ~ J/K/molecule REAL(r8), PARAMETER :: boltz = shr_const_boltz ! Boltzman's constant (J/K/molecule) REAL(R8), PARAMETER :: SHR_CONST_AVOGAD = 6.02214e26_R8 ! Avogadro's number ~ molecules/kmole REAL(r8), PARAMETER :: avogad = shr_const_avogad ! Avogadro's number (molecules/kmole) REAL(R8), PARAMETER :: SHR_CONST_MWDAIR = 28.966_R8 ! molecular weight dry air ~ kg/kmole REAL(r8), PARAMETER :: mwdry = shr_const_mwdair! molecular weight dry air ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! ! --------------------------------------------------------------------- ! ! Determine superdiagonal (ca(k)) and subdiagonal (cc(k)) coeffs of the ! ! tridiagonal diffusion matrix. The diagonal elements (cb=1+ca+cc) are ! ! a combination of ca and cc; they are not required by the solver. ! !---------------------------------------------------------------------- ! !call t_startf('vd_lu_qdecomp') kvq (:,:) = 0.0_r8 cd_top(:) = 0.0_r8 rghd (:,:) = 0.0_r8! (1/H_i - 1/H) * (rho*g)^(-1) kmq (:) = 0.0_r8! Molecular diffusivity for constituent wrk0 (:) = 0.0_r8! Work variable wrk1 (:) = 0.0_r8! Work variable cb (:,:) = 0.0_r8! - Diagonal ! Compute difference between scale heights of constituent and dry air DO k = ntop_molec, nbot_molec DO i = 1, ncol rghd(i,k) = gravit / ( boltz * avogad * tint(i,k) ) * ( mw - mwdry ) rghd(i,k) = ztodt * gravit * rhoi(i,k) * rghd(i,k) ENDDO ENDDO !-------------------- ! ! Molecular diffusion ! !-------------------- ! DO k = nbot_molec - 1, ntop_molec, -1 kp1 = k + 1 DO i = 1, ncol kmq(i) = kq_scal(i,kp1) * mw_facm wrk0(i) = ( kv(i,kp1) + kmq(i) ) * tmpi(i,kp1) wrk1(i) = kmq(i) * 0.5_r8 * rghd(i,kp1) ! Add species separation term ca(i,k ) = ( wrk0(i) - wrk1(i) ) * rpdel(i,k) cc(i,kp1) = ( wrk0(i) + wrk1(i) ) * rpdel(i,kp1) kvq(i,kp1) = kmq(i) END DO END DO IF( fixed_ubc ) THEN DO i = 1, ncol cc(i,ntop_molec) = kq_scal(i,ntop_molec) * mw_facm & * ( tmpi(i,ntop_molec) + rghd(i,ntop_molec) ) & * rpdel(i,ntop_molec) END DO END IF ! Calculate diagonal elements DO k = nbot_molec - 1, ntop_molec + 1, -1 kp1 = k + 1 DO i = 1, ncol cb(i,k) = 1._r8 + ca(i,k) + cc(i,k) & + rpdel(i,k) * ( kvq(i,kp1) * rghd(i,kp1) & - kvq(i,k) * rghd(i,k) ) kvq(i,kp1) = kv(i,kp1) + kvq(i,kp1) END DO END DO k = ntop_molec kp1 = k + 1 IF( fixed_ubc ) THEN DO i = 1, ncol cb(i,k) = 1.0_r8 + ca(i,k) & + rpdel(i,k) * kvq(i,kp1) * rghd(i,kp1) & + kq_scal(i,ntop_molec) * mw_facm & * ( tmpi(i,ntop_molec) - rghd(i,ntop_molec) ) & * rpdel(i,ntop_molec) END DO ELSE DO i = 1, ncol cb(i,k) = 1._r8 + ca(i,k) & + rpdel(i,k) * kvq(i,kp1) * rghd(i,kp1) END DO END IF k = nbot_molec DO i = 1, ncol cb(i,k) = 1._r8 + cc(i,k) + ca(i,k) & - rpdel(i,k) * kvq(i,k)*rghd(i,k) END DO DO k = 1, nbot_molec + 1, -1 DO i = 1, ncol cb(i,k) = 1._r8 + ca(i,k) + cc(i,k) END DO END DO ! Compute term for updating top level mixing ratio for ubc IF( fixed_ubc ) THEN DO i = 1, ncol cd_top(i) = cc(i,ntop_molec) * ubc_mmr(i) END DO END IF !-------------------------------------------------------- ! ! Calculate e(k). ! ! This term is required in solution of tridiagonal matrix ! ! defined by implicit diffusion equation. ! !-------------------------------------------------------- ! DO k = nbot_molec, ntop_molec + 1, -1 DO i = 1, ncol dnom(i,k) = 1._r8 / ( cb(i,k) - ca(i,k) * ze(i,k+1) ) ze(i,k) = cc(i,k) * dnom(i,k) END DO END DO k = ntop_molec DO i = 1, ncol dnom(i,k) = 1._r8 / ( cb(i,k) - ca(i,k) * ze(i,k+1) ) END DO vd_lu_qdecomp = 1 !call t_stopf('vd_lu_qdecomp') RETURN END FUNCTION vd_lu_qdecomp ! =============================================================================== ! ! ! ! =============================================================================== ! SUBROUTINE vd_lu_decomp( pcols, pver, ncol , & ksrf , kv , tmpi , rpdel, ztodt , cc_top, & ca , cc , dnom , ze , ntop , nbot ) !---------------------------------------------------------------------- ! ! Determine superdiagonal (ca(k)) and subdiagonal (cc(k)) coeffs of the ! ! tridiagonal diffusion matrix. ! ! The diagonal elements (1+ca(k)+cc(k)) are not required by the solver. ! ! Also determine ze factor and denominator for ze and zf (see solver). ! !---------------------------------------------------------------------- ! ! --------------------- ! ! Input-Output Argument ! ! --------------------- ! INTEGER, INTENT(in) :: pcols ! Number of allocated atmospheric columns INTEGER, INTENT(in) :: pver ! Number of allocated atmospheric levels INTEGER, INTENT(in) :: ncol ! Number of computed atmospheric columns INTEGER, INTENT(in) :: ntop ! Top level to operate on INTEGER, INTENT(in) :: nbot ! Bottom level to operate on REAL(r8), INTENT(in) :: ksrf(pcols) ! Surface "drag" coefficient [ kg/s/m2 ] REAL(r8), INTENT(in) :: kv(pcols,pver+1) ! Vertical diffusion coefficients [ m2/s ] REAL(r8), INTENT(in) :: tmpi(pcols,pver+1) ! dt*(g/R)**2/dp*pi(k+1)/(.5*(tm(k+1)+tm(k))**2 REAL(r8), INTENT(in) :: rpdel(pcols,pver) ! 1./pdel (thickness bet interfaces) REAL(r8), INTENT(in) :: ztodt ! 2 delta-t [ s ] REAL(r8), INTENT(in) :: cc_top(pcols) ! Lower diagonal on top interface (for fixed ubc only) REAL(r8), INTENT(out) :: ca(pcols,pver) ! Upper diagonal REAL(r8), INTENT(out) :: cc(pcols,pver) ! Lower diagonal REAL(r8), INTENT(out) :: dnom(pcols,pver) ! 1./(1. + ca(k) + cc(k) - cc(k)*ze(k-1)) REAL(r8), INTENT(out) :: ze(pcols,pver) ! Term in tri-diag. matrix system ! --------------- ! ! Local Variables ! ! --------------- ! INTEGER :: i ! Longitude index INTEGER :: k ! Vertical index ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! DO k = 1, pver DO i = 1, ncol ca(i,k) =0.0_r8 cc(i,k) =0.0_r8 dnom(i,k) =0.0_r8 ze(i,k) =0.0_r8 END DO END DO ! Determine superdiagonal (ca(k)) and subdiagonal (cc(k)) coeffs of the ! tridiagonal diffusion matrix. The diagonal elements (cb=1+ca+cc) are ! a combination of ca and cc; they are not required by the solver. DO k = nbot - 1, ntop, -1 DO i = 1, ncol ca(i,k ) = kv(i,k+1) * tmpi(i,k+1) * rpdel(i,k ) cc(i,k+1) = kv(i,k+1) * tmpi(i,k+1) * rpdel(i,k+1) END DO END DO ! The bottom element of the upper diagonal (ca) is zero (element not used). ! The subdiagonal (cc) is not needed in the solver. DO i = 1, ncol ca(i,nbot) = 0._r8 END DO ! Calculate e(k). This term is ! required in solution of tridiagonal matrix defined by implicit diffusion eqn. DO i = 1, ncol dnom(i,nbot) = 1._r8/(1._r8 + cc(i,nbot) + ksrf(i)*ztodt*gravit*rpdel(i,nbot)) ze(i,nbot) = cc(i,nbot)*dnom(i,nbot) END DO DO k = nbot - 1, ntop + 1, -1 DO i = 1, ncol dnom(i,k) = 1._r8/(1._r8 + ca(i,k) + cc(i,k) - ca(i,k)*ze(i,k+1)) ze(i,k) = cc(i,k)*dnom(i,k) END DO END DO DO i = 1, ncol dnom(i,ntop) = 1._r8/(1._r8 + ca(i,ntop) + cc_top(i) - ca(i,ntop)*ze(i,ntop+1)) END DO RETURN END SUBROUTINE vd_lu_decomp ! =============================================================================== ! ! ! ! =============================================================================== ! SUBROUTINE vd_lu_solve( pcols , pver , ncol , & q , ca , ze , dnom , ntop , nbot , cd_top ) !----------------------------------------------------------------------------------- ! ! Solve the implicit vertical diffusion equation with zero flux boundary conditions. ! ! Procedure for solution of the implicit equation follows Richtmyer and ! ! Morton (1967,pp 198-200). ! ! ! ! The equation solved is ! ! ! ! -ca(k)*q(k+1) + cb(k)*q(k) - cc(k)*q(k-1) = d(k), ! ! ! ! where d(k) is the input profile and q(k) is the output profile ! ! ! ! The solution has the form ! ! ! ! q(k) = ze(k)*q(k-1) + zf(k) ! ! ! ! ze(k) = cc(k) * dnom(k) ! ! ! ! zf(k) = [d(k) + ca(k)*zf(k+1)] * dnom(k) ! ! ! ! dnom(k) = 1/[cb(k) - ca(k)*ze(k+1)] = 1/[1 + ca(k) + cc(k) - ca(k)*ze(k+1)] ! ! ! ! Note that the same routine is used for temperature, momentum and tracers, ! ! and that input variables are replaced. ! ! ---------------------------------------------------------------------------------- ! ! --------------------- ! ! Input-Output Argument ! ! --------------------- ! INTEGER, INTENT(in) :: pcols ! Number of allocated atmospheric columns INTEGER, INTENT(in) :: pver ! Number of allocated atmospheric levels INTEGER, INTENT(in) :: ncol ! Number of computed atmospheric columns INTEGER, INTENT(in) :: ntop ! Top level to operate on INTEGER, INTENT(in) :: nbot ! Bottom level to operate on REAL(r8), INTENT(in) :: ca(pcols,pver) ! -Upper diag coeff.of tri-diag matrix REAL(r8), INTENT(in) :: ze(pcols,pver) ! Term in tri-diag solution REAL(r8), INTENT(in) :: dnom(pcols,pver) ! 1./(1. + ca(k) + cc(k) - ca(k)*ze(k+1)) REAL(r8), INTENT(in) :: cd_top(pcols) ! cc_top * ubc value REAL(r8), INTENT(inout) :: q(pcols,pver) ! Constituent field ! --------------- ! ! Local Variables ! ! --------------- ! REAL(r8) :: zf(pcols,pver) ! Term in tri-diag solution INTEGER i, k ! Longitude, vertical indices ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! zf=0.0_r8 ! Calculate zf(k). Terms zf(k) and ze(k) are required in solution of ! tridiagonal matrix defined by implicit diffusion equation. ! Note that only levels ntop through nbot need be solved for. DO i = 1, ncol zf(i,nbot) = q(i,nbot)*dnom(i,nbot) END DO DO k = nbot - 1, ntop + 1, -1 DO i = 1, ncol zf(i,k) = (q(i,k) + ca(i,k)*zf(i,k+1))*dnom(i,k) END DO END DO ! Include boundary condition on top element k = ntop DO i = 1, ncol zf(i,k) = (q(i,k) + cd_top(i) + ca(i,k)*zf(i,k+1))*dnom(i,k) END DO ! Perform back substitution DO i = 1, ncol q(i,ntop) = zf(i,ntop) END DO DO k = ntop + 1, nbot, +1 DO i = 1, ncol q(i,k) = zf(i,k) + ze(i,k)*q(i,k-1) END DO END DO RETURN END SUBROUTINE vd_lu_solve ! =============================================================================== ! ! ! ! =============================================================================== ! CHARACTER(128) FUNCTION vdiff_select( fieldlist, name, qindex ) ! --------------------------------------------------------------------- ! ! This function sets the field with incoming name as one to be diffused ! ! --------------------------------------------------------------------- ! TYPE(vdiff_selector), INTENT(inout) :: fieldlist CHARACTER(*), INTENT(in) :: name INTEGER, INTENT(in), OPTIONAL :: qindex vdiff_select = '' SELECT CASE (name) CASE ('u','U') fieldlist%fields(1) = .TRUE. CASE ('v','V') fieldlist%fields(2) = .TRUE. CASE ('s','S') fieldlist%fields(3) = .TRUE. CASE ('q','Q') IF( PRESENT(qindex) ) THEN fieldlist%fields(3 + qindex) = .TRUE. ELSE fieldlist%fields(4) = .TRUE. ENDIF CASE default WRITE(vdiff_select,*) 'Bad argument to vdiff_index: ', name END SELECT RETURN END FUNCTION vdiff_select TYPE(vdiff_selector) FUNCTION NOT(a) ! ------------------------------------------------------------- ! ! This function extends .not. to operate on type vdiff_selector ! ! ------------------------------------------------------------- ! TYPE(vdiff_selector), INTENT(in) :: a ALLOCATE(not%fields(SIZE(a%fields))) not%fields(:) = .NOT. a%fields(:) END FUNCTION not LOGICAL FUNCTION my_any(a) ! -------------------------------------------------- ! ! This function extends the intrinsic function 'any' ! ! to operate on type vdiff_selector ! ! -------------------------------------------------- ! TYPE(vdiff_selector), INTENT(in) :: a my_any = ANY(a%fields) END FUNCTION my_any LOGICAL FUNCTION diffuse(fieldlist,name,qindex) ! ---------------------------------------------------------------------------- ! ! This function reports whether the field with incoming name is to be diffused ! ! ---------------------------------------------------------------------------- ! TYPE(vdiff_selector), INTENT(in) :: fieldlist CHARACTER(*), INTENT(in) :: name INTEGER, INTENT(in), OPTIONAL :: qindex SELECT CASE (name) CASE ('u','U') diffuse = fieldlist%fields(1) CASE ('v','V') diffuse = fieldlist%fields(2) CASE ('s','S') diffuse = fieldlist%fields(3) CASE ('q','Q') IF( PRESENT(qindex) ) THEN diffuse = fieldlist%fields(3 + qindex) ELSE diffuse = fieldlist%fields(4) ENDIF CASE default diffuse = .FALSE. END SELECT RETURN END FUNCTION diffuse CHARACTER*3 FUNCTION cnst_get_type_byind (ind,pcnst) !----------------------------------------------------------------------- ! ! Purpose: Get the type of a constituent ! ! Method: ! ! ! ! Author: P. J. Rasch ! !-----------------------------Arguments--------------------------------- ! INTEGER, INTENT(in) :: ind ! global constituent index (in q array) INTEGER, INTENT(in) :: pcnst !---------------------------Local workspace----------------------------- INTEGER :: m ! tracer index !----------------------------------------------------------------------- IF (ind.LE.pcnst) THEN cnst_get_type_byind = cnst_type(ind) ELSE ! Unrecognized name WRITE(iulog,*) 'CNST_GET_TYPE_BYIND, ind:', ind STOP 'call endrun' ENDIF END FUNCTION cnst_get_type_byind !============================================================================================== !============================================================================ ! ! ! !============================================================================ ! SUBROUTINE compute_tms( & pcols , &!integer, intent(in) :: pcols ! Number of columns dimensioned pver , &!integer, intent(in) :: pver ! Number of model layers ncol , &!integer, intent(in) :: ncol ! Number of columns actually used u , &!real(r8), intent(in) :: u(pcols,pver) ! Layer mid-point zonal wind [ m/s ] v , &!real(r8), intent(in) :: v(pcols,pver) ! Layer mid-point meridional wind [ m/s ] t , &!real(r8), intent(in) :: t(pcols,pver) ! Layer mid-point temperature [ K ] pmid , &!real(r8), intent(in) :: pmid(pcols,pver) ! Layer mid-point pressure [ Pa ] exner , &!real(r8), intent(in) :: exner(pcols,pver) ! Layer mid-point exner function [ no unit ] zm , &!real(r8), intent(in) :: zm(pcols,pver) ! Layer mid-point height [ m ] sgh , &!real(r8), intent(in) :: sgh(pcols) ! Standard deviation of orography [ m ] ksrf , &!real(r8), intent(out) :: ksrf(pcols) ! Surface drag coefficient [ kg/s/m2 ] taux , &!real(r8), intent(out) :: taux(pcols) ! Surface zonal wind stress [ N/m2 ] tauy , &!real(r8), intent(out) :: tauy(pcols) ! Surface meridional wind stress [ N/m2 ] landfrac )!real(r8), intent(in) :: landfrac(pcols) ! Land fraction [ fraction ] !------------------------------------------------------------------------------ ! ! Turbulent mountain stress parameterization ! ! ! ! Returns surface drag coefficient and stress associated with subgrid mountains ! ! For points where the orographic variance is small ( including ocean ), ! ! the returned surface drag coefficient and stress is zero. ! ! ! ! Lastly arranged : Sungsu Park. Jan. 2010. ! !------------------------------------------------------------------------------ ! ! ---------------------- ! ! Input-Output Arguments ! ! ---------------------- ! INTEGER, INTENT(in) :: pcols ! Number of columns dimensioned INTEGER, INTENT(in) :: pver ! Number of model layers INTEGER, INTENT(in) :: ncol ! Number of columns actually used REAL(r8), INTENT(in) :: u(pcols,pver) ! Layer mid-point zonal wind [ m/s ] REAL(r8), INTENT(in) :: v(pcols,pver) ! Layer mid-point meridional wind [ m/s ] REAL(r8), INTENT(in) :: t(pcols,pver) ! Layer mid-point temperature [ K ] REAL(r8), INTENT(in) :: pmid(pcols,pver) ! Layer mid-point pressure [ Pa ] REAL(r8), INTENT(in) :: exner(pcols,pver) ! Layer mid-point exner function [ no unit ] REAL(r8), INTENT(in) :: zm(pcols,pver) ! Layer mid-point height [ m ] REAL(r8), INTENT(in) :: sgh(pcols) ! Standard deviation of orography [ m ] REAL(r8), INTENT(in) :: landfrac(pcols) ! Land fraction [ fraction ] REAL(r8), INTENT(out) :: ksrf(pcols) ! Surface drag coefficient [ kg/s/m2 ] REAL(r8), INTENT(out) :: taux(pcols) ! Surface zonal wind stress [ N/m2 ] REAL(r8), INTENT(out) :: tauy(pcols) ! Surface meridional wind stress [ N/m2 ] ! --------------- ! ! Local Variables ! ! --------------- ! INTEGER :: i ! Loop index INTEGER :: kb, kt ! Bottom and top of source region REAL(r8) :: horo ! Orographic height [ m ] REAL(r8) :: z0oro ! Orographic z0 for momentum [ m ] REAL(r8) :: dv2 ! (delta v)**2 [ m2/s2 ] REAL(r8) :: ri ! Richardson number [ no unit ] REAL(r8) :: stabfri ! Instability function of Richardson number [ no unit ] REAL(r8) :: rho ! Density [ kg/m3 ] REAL(r8) :: cd ! Drag coefficient [ no unit ] REAL(r8) :: vmag ! Velocity magnitude [ m /s ] ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! horo = 0._r8 z0oro = 0._r8 dv2 = 0._r8 ri = 0._r8 stabfri = 0._r8 rho = 0._r8 cd = 0._r8 vmag = 0._r8 DO i = 1, ncol ksrf(i) = 0._r8 taux(i) = 0._r8 tauy(i) = 0._r8 END DO DO i = 1, ncol ! determine subgrid orgraphic height ( mean to peak ) horo = oroconst * sgh(i) ! No mountain stress if horo is too small IF( horo < horomin ) THEN ksrf(i) = 0._r8 taux(i) = 0._r8 tauy(i) = 0._r8 ELSE ! Determine z0m for orography z0oro = MIN( z0fac * horo, z0max ) ! Calculate neutral drag coefficient cd = ( karman / LOG( ( zm(i,pver) + z0oro ) / z0oro) )**2 ! Calculate the Richardson number over the lowest 2 layers kt = pver - 1 kb = pver dv2 = MAX( ( u(i,kt) - u(i,kb) )**2 + ( v(i,kt) - v(i,kb) )**2, dv2min ) ! Modification : Below computation of Ri is wrong. Note that 'Exner' function here is ! inverse exner function. Here, exner function is not multiplied in ! the denominator. Also, we should use moist Ri not dry Ri. ! Also, this approach using the two lowest model layers can be potentially ! sensitive to the vertical resolution. ! OK. I only modified the part associated with exner function. ri = 2._r8 * gravit * ( t(i,kt) * exner(i,kt) - t(i,kb) * exner(i,kb) ) * ( zm(i,kt) - zm(i,kb) ) & / ( ( t(i,kt) * exner(i,kt) + t(i,kb) * exner(i,kb) ) * dv2 ) ! ri = 2._r8 * gravit * ( t(i,kt) * exner(i,kt) - t(i,kb) * exner(i,kb) ) * ( zm(i,kt) - zm(i,kb) ) & ! / ( ( t(i,kt) + t(i,kb) ) * dv2 ) ! Calculate the instability function and modify the neutral drag cofficient. ! We should probably follow more elegant approach like Louis et al (1982) or Bretherton and Park (2009) ! but for now we use very crude approach : just 1 for ri < 0, 0 for ri > 1, and linear ramping. stabfri = MAX( 0._r8, MIN( 1._r8, 1._r8 - ri ) ) cd = cd * stabfri ! Compute density, velocity magnitude and stress using bottom level properties rho = pmid(i,pver) / ( rair * t(i,pver) ) vmag = SQRT( u(i,pver)**2 + v(i,pver)**2 ) ksrf(i) = rho * cd * vmag * landfrac(i) taux(i) = -ksrf(i) * u(i,pver) tauy(i) = -ksrf(i) * v(i,pver) END IF END DO RETURN END SUBROUTINE compute_tms !============================================================================================== REAL(r8) FUNCTION estblf( td ) ! ! Saturation vapor pressure table lookup ! REAL(r8), INTENT(in) :: td ! Temperature for saturation lookup ! REAL(r8) :: ee ! intermediate variable for es look-up REAL(r8) :: ai INTEGER :: i REAL(r8), PARAMETER:: tmin = 173.16_r8 ! min temperature (K) for table REAL(r8), PARAMETER:: tmax = 375.16_r8 ! max temperature (K) for table! Maximum temperature entry in table REAL(r8) ttrice ! transition range from es over H2O to es over ice REAL(r8), PARAMETER :: trice = 20.00_r8 ! Transition range from es over range to es over ice ! ee = MAX(MIN(td,tmax),tmin) ! partial pressure i = INT(ee-tmin)+1 ai = AINT(ee-tmin) estblf = (tmin+ai-ee+1.0_r8)* & estbl(i)-(tmin+ai-ee)* & estbl(i+1) END FUNCTION estblf !--xl !============================================================================================== INTEGER FUNCTION fqsatd(t ,p ,es ,qs ,gam , len ) !----------------------------------------------------------------------- ! Purpose: ! This is merely a function interface vqsatd. !------------------------------Arguments-------------------------------- ! Input arguments INTEGER , INTENT(in) :: len ! vector length REAL(r8), INTENT(in) :: t(len) ! temperature REAL(r8), INTENT(in) :: p(len) ! pressure ! Output arguments REAL(r8), INTENT(out) :: es(len) ! saturation vapor pressure REAL(r8), INTENT(out) :: qs(len) ! saturation specific humidity REAL(r8), INTENT(out) :: gam(len) ! (l/cp)*(d(qs)/dt) ! Call vqsatd es(1:len) =0.0_r8 qs(1:len) =0.0_r8 gam(1:len)=0.0_r8 CALL vqsatd(t ,p ,es ,qs ,gam , len ) fqsatd = 1 RETURN END FUNCTION fqsatd SUBROUTINE vqsatd(t ,p ,es ,qs ,gam , & len ) !----------------------------------------------------------------------- ! ! Purpose: ! Utility procedure to look up and return saturation vapor pressure from ! precomputed table, calculate and return saturation specific humidity ! (g/g), and calculate and return gamma (l/cp)*(d(qsat)/dT). The same ! function as qsatd, but operates on vectors of temperature and pressure ! ! Method: ! ! Author: J. Hack ! !------------------------------Arguments-------------------------------- ! ! Input arguments ! INTEGER, INTENT(in) :: len ! vector length REAL(r8), INTENT(in) :: t(len) ! temperature REAL(r8), INTENT(in) :: p(len) ! pressure ! ! Output arguments ! REAL(r8), INTENT(out) :: es(len) ! saturation vapor pressure REAL(r8), INTENT(out) :: qs(len) ! saturation specific humidity REAL(r8), INTENT(out) :: gam(len) ! (l/cp)*(d(qs)/dt) ! !--------------------------Local Variables------------------------------ ! LOGICAL lflg ! true if in temperature transition region ! INTEGER i ! index for vector calculations ! REAL(r8) omeps ! 1. - 0.622 REAL(r8) trinv ! reciprocal of ttrice (transition range) REAL(r8) tc ! temperature (in degrees C) REAL(r8) weight ! weight for es transition from water to ice REAL(r8) hltalt ! appropriately modified hlat for T derivatives ! REAL(r8) hlatsb ! hlat weighted in transition region REAL(r8) hlatvp ! hlat modified for t changes above freezing REAL(r8) tterm ! account for d(es)/dT in transition region REAL(r8) desdt ! d(es)/dT REAL(r8), PARAMETER :: trice = 20.00_r8 ! Transition range from es over range to es over ice REAL(r8), PARAMETER :: ttrice=trice REAL(R8),PARAMETER :: SHR_CONST_TKFRZ = 273.15_R8 ! freezing T of fresh water ~ K REAL(r8), PARAMETER :: tmelt = shr_const_tkfrz ! Freezing point of water (K) REAL(R8),PARAMETER :: SHR_CONST_LATICE = 3.337e5_R8 ! latent heat of fusion ~ J/kg REAL(R8),PARAMETER :: SHR_CONST_LATVAP = 2.501e6_R8 ! latent heat of evaporation ~ J/kg REAL(r8), PARAMETER :: hlatf = shr_const_latice ! Latent heat of fusion (J/kg) REAL(r8), PARAMETER :: hlatv = shr_const_latvap ! Latent heat of vaporization (J/kg) REAL(R8),PARAMETER :: SHR_CONST_CPDAIR = 1.00464e3_R8 ! specific heat of dry air ~ J/kg/K REAL(r8), PARAMETER :: cp = shr_const_cpdair ! specific heat of dry air (J/K/kg) REAL(r8),PARAMETER :: rgasv = shr_const_rgas/shr_const_mwwv ! Water vapor gas constant ~ J/K/kg es(1:len) =0.0_r8 qs(1:len) =0.0_r8 gam(1:len)=0.0_r8 ! !----------------------------------------------------------------------- ! omeps = 1.0_r8 - epsqs DO i=1,len es(i) = estblf(t(i)) ! ! Saturation specific humidity ! qs(i) = epsqs*es(i)/(p(i) - omeps*es(i)) ! ! The following check is to avoid the generation of negative ! values that can occur in the upper stratosphere and mesosphere ! qs(i) = MIN(1.0_r8,qs(i)) ! IF (qs(i) < 0.0_r8) THEN qs(i) = 1.0_r8 es(i) = p(i) END IF END DO ! ! "generalized" analytic expression for t derivative of es ! accurate to within 1 percent for 173.16 < t < 373.16 ! trinv = 0.0_r8 IF ((.NOT. icephs) .OR. (ttrice.EQ.0.0_r8)) go to 10 trinv = 1.0_r8/ttrice DO i=1,len ! ! Weighting of hlat accounts for transition from water to ice ! polynomial expression approximates difference between es over ! water and es over ice from 0 to -ttrice (C) (min of ttrice is ! -40): required for accurate estimate of es derivative in transition ! range from ice to water also accounting for change of hlatv with t ! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw ! tc = t(i) - tmelt lflg = (tc >= -ttrice .AND. tc < 0.0_r8) weight = MIN(-tc*trinv,1.0_r8) hlatsb = hlatv + weight*hlatf hlatvp = hlatv - 2369.0_r8*tc IF (t(i) < tmelt) THEN hltalt = hlatsb ELSE hltalt = hlatvp END IF IF (lflg) THEN tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) + tc*pcf(5)))) ELSE tterm = 0.0_r8 END IF desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) + tterm*trinv gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) IF (qs(i) == 1.0_r8) gam(i) = 0.0_r8 END DO RETURN ! ! No icephs or water to ice transition ! 10 DO i=1,len ! ! Account for change of hlatv with t above freezing where ! constant slope is given by -2369 j/(kg c) = cpv - cw ! hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt) IF (icephs) THEN hlatsb = hlatv + hlatf ELSE hlatsb = hlatv END IF IF (t(i) < tmelt) THEN hltalt = hlatsb ELSE hltalt = hlatvp END IF desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) IF (qs(i) == 1.0_r8) gam(i) = 0.0_r8 END DO ! RETURN ! END SUBROUTINE vqsatd SUBROUTINE aqsat(t ,p ,es ,qs ,ii , & ILEN ,kk ,kstart ,kend ) !----------------------------------------------------------------------- ! ! Purpose: ! Utility procedure to look up and return saturation vapor pressure from ! precomputed table, calculate and return saturation specific humidity ! (g/g),for input arrays of temperature and pressure (dimensioned ii,kk) ! This routine is useful for evaluating only a selected region in the ! vertical. ! ! Method: ! ! ! ! Author: J. Hack ! !------------------------------Arguments-------------------------------- ! ! Input arguments ! INTEGER, INTENT(in) :: ii ! I dimension of arrays t, p, es, qs INTEGER, INTENT(in) :: kk ! K dimension of arrays t, p, es, qs INTEGER, INTENT(in) :: ILEN ! Length of vectors in I direction which INTEGER, INTENT(in) :: kstart ! Starting location in K direction INTEGER, INTENT(in) :: kend ! Ending location in K direction REAL(r8), INTENT(in) :: t(ii,kk) ! Temperature REAL(r8), INTENT(in) :: p(ii,kk) ! Pressure ! ! Output arguments ! REAL(r8), INTENT(out) :: es(ii,kk) ! Saturation vapor pressure REAL(r8), INTENT(out) :: qs(ii,kk) ! Saturation specific humidity ! !---------------------------Local workspace----------------------------- ! REAL(r8) omeps ! 1 - 0.622 INTEGER i, k ! Indices ! !----------------------------------------------------------------------- ! omeps = 1.0_r8 - epsqs DO k=kstart,kend DO i=1,ILEN es(i,k) = estblf(t(i,k)) ! ! Saturation specific humidity ! qs(i,k) = epsqs*es(i,k)/(p(i,k) - omeps*es(i,k)) ! ! The following check is to avoid the generation of negative values ! that can occur in the upper stratosphere and mesosphere ! qs(i,k) = MIN(1.0_r8,qs(i,k)) ! IF (qs(i,k) < 0.0_r8) THEN qs(i,k) = 1.0_r8 es(i,k) = p(i,k) END IF END DO END DO ! RETURN END SUBROUTINE aqsat subroutine gffgch(t ,es ,itype ) !----------------------------------------------------------------------- ! ! Purpose: ! Computes saturation vapor pressure over water and/or over ice using ! Goff & Gratch (1946) relationships. ! ! ! Method: ! T (temperature), and itype are input parameters, while es (saturation ! vapor pressure) is an output parameter. The input parameter itype ! serves two purposes: a value of zero indicates that saturation vapor ! pressures over water are to be returned (regardless of temperature), ! while a value of one indicates that saturation vapor pressures over ! ice should be returned when t is less than freezing degrees. If itype ! is negative, its absolute value is interpreted to define a temperature ! transition region below freezing in which the returned ! saturation vapor pressure is a weighted average of the respective ice ! and water value. That is, in the temperature range 0 => -itype ! degrees c, the saturation vapor pressures are assumed to be a weighted ! average of the vapor pressure over supercooled water and ice (all ! water at 0 c; all ice at -itype c). Maximum transition range => 40 c ! ! Author: J. Hack ! !----------------------------------------------------------------------- ! use shr_kind_mod, only: r8 => shr_kind_r8 ! use physconst, only: tmelt ! use abortutils, only: endrun ! use cam_logfile, only: iulog implicit none !------------------------------Arguments-------------------------------- ! ! Input arguments ! real(r8), intent(in) :: t ! Temperature ! ! Output arguments ! integer, intent(inout) :: itype ! Flag for ice phase and associated transition real(r8), intent(out) :: es ! Saturation vapor pressure ! !---------------------------Local variables----------------------------- ! real(r8) e1 ! Intermediate scratch variable for es over water real(r8) e2 ! Intermediate scratch variable for es over water real(r8) eswtr ! Saturation vapor pressure over water real(r8) f ! Intermediate scratch variable for es over water real(r8) f1 ! Intermediate scratch variable for es over water real(r8) f2 ! Intermediate scratch variable for es over water real(r8) f3 ! Intermediate scratch variable for es over water real(r8) f4 ! Intermediate scratch variable for es over water real(r8) f5 ! Intermediate scratch variable for es over water real(r8) ps ! Reference pressure (mb) real(r8) t0 ! Reference temperature (freezing point of water) real(r8) term1 ! Intermediate scratch variable for es over ice real(r8) term2 ! Intermediate scratch variable for es over ice real(r8) term3 ! Intermediate scratch variable for es over ice real(r8) tr ! Transition range for es over water to es over ice real(r8) ts ! Reference temperature (boiling point of water) real(r8) weight ! Intermediate scratch variable for es transition integer itypo ! Intermediate scratch variable for holding itype INTEGER, PARAMETER :: iulog=0 ! !----------------------------------------------------------------------- ! ! Check on whether there is to be a transition region for es ! if (itype < 0) then tr = abs(real(itype,r8)) itypo = itype itype = 1 else tr = 0.0_r8 itypo = itype end if if (tr > 40.0_r8) then write(iulog,900) tr STOP 'call endrun (GFFGCH) ! Abnormal termination' end if ! if(t < (tmelt - tr) .and. itype == 1) go to 10 ! ! Water ! ps = 1013.246_r8 ts = 373.16_r8 e1 = 11.344_r8*(1.0_r8 - t/ts) e2 = -3.49149_r8*(ts/t - 1.0_r8) f1 = -7.90298_r8*(ts/t - 1.0_r8) f2 = 5.02808_r8*log10(ts/t) f3 = -1.3816_r8*(10.0_r8**e1 - 1.0_r8)/10000000.0_r8 f4 = 8.1328_r8*(10.0_r8**e2 - 1.0_r8)/1000.0_r8 f5 = log10(ps) f = f1 + f2 + f3 + f4 + f5 es = (10.0_r8**f)*100.0_r8 eswtr = es ! if(t >= tmelt .or. itype == 0) go to 20 ! ! Ice ! 10 continue t0 = tmelt term1 = 2.01889049_r8/(t0/t) term2 = 3.56654_r8*log(t0/t) term3 = 20.947031_r8*(t0/t) es = 575.185606e10_r8*exp(-(term1 + term2 + term3)) ! if (t < (tmelt - tr)) go to 20 ! ! Weighted transition between water and ice ! weight = min((tmelt - t)/tr,1.0_r8) es = weight*es + (1.0_r8 - weight)*eswtr ! 20 continue itype = itypo return ! 900 format('GFFGCH: FATAL ERROR ******************************',/, & 'TRANSITION RANGE FOR WATER TO ICE SATURATION VAPOR', & ' PRESSURE, TR, EXCEEDS MAXIMUM ALLOWABLE VALUE OF', & ' 40.0 DEGREES C',/, ' TR = ',f7.2) ! end subroutine gffgch ! ! Finalize_Pbl_UniversityWashington ! SUBROUTINE Finalize_Pbl_UniversityWashington() IMPLICIT NONE END SUBROUTINE Finalize_Pbl_UniversityWashington END MODULE Pbl_UniversityWashington !PROGRAM MAIN ! USE Pbl_UniversityWashington, ONLY :Init_Pbl_UniversityWashington, & ! Finalize_Pbl_UniversityWashington ! IMPLICIT NONE ! CALL Init() ! CALL Run() ! CALL Finalize() !CONTAINS ! ! Init ! !SUBROUTINE Init() ! IMPLICIT NONE ! INTEGER, PARAMETER :: pver =28 ! INTEGER, PARAMETER :: pcnst=1 ! REAL(KIND=8) :: sig(pver) ! CALL Init_Pbl_UniversityWashington(pver,pcnst,pcnst,sig) !END SUBROUTINE Init ! ! Run ! !SUBROUTINE Run() ! IMPLICIT NONE !END SUBROUTINE Run ! ! Finalize ! !SUBROUTINE Finalize() ! IMPLICIT NONE ! CALL Finalize_Pbl_UniversityWashington() !END SUBROUTINE Finalize !END PROGRAM MAIN