Line data Source code
1 : module uwshcu
2 :
3 : use shr_spfn_mod, only: erfc => shr_spfn_erfc
4 : use cam_logfile, only: iulog
5 : use ppgrid, only: pcols, pver, pverp
6 : use cam_abortutils, only: endrun
7 : use spmd_utils, only: masterproc
8 : use wv_saturation, only: qsat
9 :
10 :
11 : implicit none
12 : private
13 : save
14 :
15 : public &
16 : uwshcu_readnl, &
17 : init_uwshcu, &
18 : compute_uwshcu, &
19 : compute_uwshcu_inv
20 :
21 : integer , parameter :: r8 = selected_real_kind(12) ! 8 byte real
22 : real(r8), parameter :: unset_r8 = huge(1.0_r8)
23 : real(r8) :: xlv ! Latent heat of vaporization
24 : real(r8) :: xlf ! Latent heat of fusion
25 : real(r8) :: xls ! Latent heat of sublimation = xlv + xlf
26 : real(r8) :: cp ! Specific heat of dry air
27 : real(r8) :: zvir ! rh2o/rair - 1
28 : real(r8) :: r ! Gas constant for dry air
29 : real(r8) :: g ! Gravitational constant
30 : real(r8) :: ep2 ! mol wgt water vapor / mol wgt dry air
31 : real(r8) :: p00 ! Reference pressure for exner function
32 : real(r8) :: rovcp ! R/cp
33 :
34 : ! Tuning parameters set via namelist
35 : real(r8) :: rpen ! For penetrative entrainment efficiency
36 :
37 : !===============================================================================
38 : contains
39 : !===============================================================================
40 :
41 0 : real(r8) function exnf(pressure)
42 : real(r8), intent(in) :: pressure
43 0 : exnf = (pressure/p00)**rovcp
44 : return
45 : end function exnf
46 :
47 : !===============================================================================
48 :
49 1536 : subroutine uwshcu_readnl(nlfile)
50 :
51 : use namelist_utils, only: find_group_name
52 : use units, only: getunit, freeunit
53 : use mpishorthand
54 :
55 : character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input
56 :
57 : ! Local variables
58 : integer :: unitn, ierr
59 : character(len=*), parameter :: subname = 'uwshcu_readnl'
60 :
61 : ! Namelist variables
62 : real(r8) :: uwshcu_rpen = unset_r8 ! For penetrative entrainment efficiency
63 :
64 : namelist /uwshcu_nl/ uwshcu_rpen
65 : !-----------------------------------------------------------------------------
66 :
67 1536 : if (masterproc) then
68 2 : unitn = getunit()
69 2 : open( unitn, file=trim(nlfile), status='old' )
70 2 : call find_group_name(unitn, 'uwshcu_nl', status=ierr)
71 2 : if (ierr == 0) then
72 0 : read(unitn, uwshcu_nl, iostat=ierr)
73 0 : if (ierr /= 0) then
74 0 : call endrun(subname // ':: ERROR reading namelist')
75 : end if
76 : end if
77 2 : close(unitn)
78 2 : call freeunit(unitn)
79 : end if
80 :
81 : #ifdef SPMD
82 : ! Broadcast namelist variables
83 1536 : call mpibcast(uwshcu_rpen, 1, mpir8, 0, mpicom)
84 : #endif
85 :
86 1536 : rpen=uwshcu_rpen
87 :
88 :
89 1536 : end subroutine uwshcu_readnl
90 :
91 : !===============================================================================
92 :
93 0 : subroutine init_uwshcu( kind, xlv_in, cp_in, xlf_in, zvir_in, r_in, g_in, ep2_in )
94 :
95 : !------------------------------------------------------------- !
96 : ! Purpose: !
97 : ! Initialize key constants for the shallow convection package. !
98 : !------------------------------------------------------------- !
99 :
100 : use cam_history, only: addfld, horiz_only
101 : implicit none
102 : integer , intent(in) :: kind ! kind of reals being passed in
103 : real(r8), intent(in) :: xlv_in ! Latent heat of vaporization
104 : real(r8), intent(in) :: xlf_in ! Latent heat of fusion
105 : real(r8), intent(in) :: cp_in ! Specific heat of dry air
106 : real(r8), intent(in) :: zvir_in ! rh2o/rair - 1
107 : real(r8), intent(in) :: r_in ! Gas constant for dry air
108 : real(r8), intent(in) :: g_in ! Gravitational constant
109 : real(r8), intent(in) :: ep2_in ! mol wgt water vapor / mol wgt dry air
110 :
111 : character(len=*), parameter :: subname = 'init_uwshcu'
112 :
113 : ! ------------------------- !
114 : ! Internal Output Variables !
115 : ! ------------------------- !
116 :
117 0 : call addfld( 'qtflx_Cu' , (/ 'ilev' /), 'A', 'kg/m2/s' , 'Convective qt flux' )
118 0 : call addfld( 'slflx_Cu' , (/ 'ilev' /), 'A', 'J/m2/s' , 'Convective sl flux' )
119 0 : call addfld( 'uflx_Cu' , (/ 'ilev' /), 'A', 'kg/m/s2' , 'Convective u flux' )
120 0 : call addfld( 'vflx_Cu' , (/ 'ilev' /), 'A', 'kg/m/s2' , 'Convective v flux' )
121 :
122 0 : call addfld( 'qtten_Cu' , (/ 'lev' /), 'A', 'kg/kg/s' , 'qt tendency by convection' )
123 0 : call addfld( 'slten_Cu' , (/ 'lev' /), 'A', 'J/kg/s' , 'sl tendency by convection' )
124 0 : call addfld( 'uten_Cu' , (/ 'lev' /), 'A', 'm/s2' , ' u tendency by convection' )
125 0 : call addfld( 'vten_Cu' , (/ 'lev' /), 'A', 'm/s2' , ' v tendency by convection' )
126 0 : call addfld( 'qvten_Cu' , (/ 'lev' /), 'A', 'kg/kg/s' , 'qv tendency by convection' )
127 0 : call addfld( 'qlten_Cu' , (/ 'lev' /), 'A', 'kg/kg/s' , 'ql tendency by convection' )
128 0 : call addfld( 'qiten_Cu' , (/ 'lev' /), 'A', 'kg/kg/s' , 'qi tendency by convection' )
129 :
130 0 : call addfld( 'cbmf_Cu' , horiz_only, 'A', 'kg/m2/s' , 'Cumulus base mass flux' )
131 0 : call addfld( 'ufrcinvbase_Cu' , horiz_only, 'A', 'fraction', 'Cumulus fraction at PBL top' )
132 0 : call addfld( 'ufrclcl_Cu' , horiz_only, 'A', 'fraction', 'Cumulus fraction at LCL' )
133 0 : call addfld( 'winvbase_Cu' , horiz_only, 'A', 'm/s' , 'Cumulus vertical velocity at PBL top' )
134 0 : call addfld( 'wlcl_Cu' , horiz_only, 'A', 'm/s' , 'Cumulus vertical velocity at LCL' )
135 0 : call addfld( 'plcl_Cu' , horiz_only, 'A', 'Pa' , 'LCL of source air' )
136 0 : call addfld( 'pinv_Cu' , horiz_only, 'A', 'Pa' , 'PBL top pressure' )
137 0 : call addfld( 'plfc_Cu' , horiz_only, 'A', 'Pa' , 'LFC of source air' )
138 0 : call addfld( 'pbup_Cu' , horiz_only, 'A', 'Pa' , 'Highest interface level of positive cumulus buoyancy' )
139 0 : call addfld( 'ppen_Cu' , horiz_only, 'A', 'Pa' , 'Highest level where cumulus w is 0' )
140 0 : call addfld( 'qtsrc_Cu' , horiz_only, 'A', 'kg/kg' , 'Cumulus source air qt' )
141 0 : call addfld( 'thlsrc_Cu' , horiz_only, 'A', 'K' , 'Cumulus source air thl' )
142 0 : call addfld( 'thvlsrc_Cu' , horiz_only, 'A', 'K' , 'Cumulus source air thvl' )
143 0 : call addfld( 'emfkbup_Cu' , horiz_only, 'A', 'kg/m2/s' , 'Penetrative mass flux at kbup' )
144 0 : call addfld( 'cin_Cu' , horiz_only, 'A', 'J/kg' , 'CIN upto LFC' )
145 0 : call addfld( 'cinlcl_Cu' , horiz_only, 'A', 'J/kg' , 'CIN upto LCL' )
146 0 : call addfld( 'cbmflimit_Cu' , horiz_only, 'A', 'kg/m2/s' , 'cbmflimiter' )
147 0 : call addfld( 'tkeavg_Cu' , horiz_only, 'A', 'm2/s2' , 'Average tke within PBL for convection scheme' )
148 0 : call addfld( 'zinv_Cu' , horiz_only, 'A', 'm' , 'PBL top height' )
149 0 : call addfld( 'rcwp_Cu' , horiz_only, 'A', 'kg/m2' , 'Cumulus LWP+IWP' )
150 0 : call addfld( 'rlwp_Cu' , horiz_only, 'A', 'kg/m2' , 'Cumulus LWP' )
151 0 : call addfld( 'riwp_Cu' , horiz_only, 'A', 'kg/m2' , 'Cumulus IWP' )
152 0 : call addfld( 'tophgt_Cu' , horiz_only, 'A', 'm' , 'Cumulus top height' )
153 :
154 0 : call addfld( 'wu_Cu' , (/ 'ilev' /), 'A', 'm/s' , 'Convective updraft vertical velocity' )
155 0 : call addfld( 'ufrc_Cu' , (/ 'ilev' /), 'A', 'fraction', 'Convective updraft fractional area' )
156 0 : call addfld( 'qtu_Cu' , (/ 'ilev' /), 'A', 'kg/kg' , 'Cumulus updraft qt' )
157 0 : call addfld( 'thlu_Cu' , (/ 'ilev' /), 'A', 'K' , 'Cumulus updraft thl' )
158 0 : call addfld( 'thvu_Cu' , (/ 'ilev' /), 'A', 'K' , 'Cumulus updraft thv' )
159 0 : call addfld( 'uu_Cu' , (/ 'ilev' /), 'A', 'm/s' , 'Cumulus updraft uwnd' )
160 0 : call addfld( 'vu_Cu' , (/ 'ilev' /), 'A', 'm/s' , 'Cumulus updraft vwnd' )
161 0 : call addfld( 'qtu_emf_Cu' , (/ 'ilev' /), 'A', 'kg/kg' , 'qt of penatratively entrained air' )
162 0 : call addfld( 'thlu_emf_Cu' , (/ 'ilev' /), 'A', 'K' , 'thl of penatratively entrained air' )
163 0 : call addfld( 'uu_emf_Cu' , (/ 'ilev' /), 'A', 'm/s' , 'uwnd of penatratively entrained air' )
164 0 : call addfld( 'vu_emf_Cu' , (/ 'ilev' /), 'A', 'm/s' , 'vwnd of penatratively entrained air' )
165 0 : call addfld( 'umf_Cu' , (/ 'ilev' /), 'A', 'kg/m2/s' , 'Cumulus updraft mass flux' )
166 0 : call addfld( 'uemf_Cu' , (/ 'ilev' /), 'A', 'kg/m2/s' , 'Cumulus net ( updraft + entrainment ) mass flux' )
167 0 : call addfld( 'qcu_Cu' , (/ 'lev' /), 'A', 'kg/kg' , 'Cumulus updraft LWC+IWC' )
168 0 : call addfld( 'qlu_Cu' , (/ 'lev' /), 'A', 'kg/kg' , 'Cumulus updraft LWC' )
169 0 : call addfld( 'qiu_Cu' , (/ 'lev' /), 'A', 'kg/kg' , 'Cumulus updraft IWC' )
170 0 : call addfld( 'cufrc_Cu' , (/ 'lev' /), 'A', 'fraction', 'Cumulus cloud fraction' )
171 0 : call addfld( 'fer_Cu' , (/ 'lev' /), 'A', '1/m' , 'Cumulus lateral fractional entrainment rate' )
172 0 : call addfld( 'fdr_Cu' , (/ 'lev' /), 'A', '1/m' , 'Cumulus lateral fractional detrainment Rate' )
173 :
174 0 : call addfld( 'dwten_Cu' , (/ 'lev' /), 'A', 'kg/kg/s' , 'Expellsion rate of cumulus cloud water to env.' )
175 0 : call addfld( 'diten_Cu' , (/ 'lev' /), 'A', 'kg/kg/s' , 'Expellsion rate of cumulus ice water to env.' )
176 0 : call addfld( 'qrten_Cu' , (/ 'lev' /), 'A', 'kg/kg/s' , 'Production rate of rain by cumulus' )
177 0 : call addfld( 'qsten_Cu' , (/ 'lev' /), 'A', 'kg/kg/s' , 'Production rate of snow by cumulus' )
178 0 : call addfld( 'flxrain_Cu' , (/ 'ilev' /), 'A', 'kg/m2/s' , 'Rain flux induced by Cumulus' )
179 0 : call addfld( 'flxsnow_Cu' , (/ 'ilev' /), 'A', 'kg/m2/s' , 'Snow flux induced by Cumulus' )
180 0 : call addfld( 'ntraprd_Cu' , (/ 'lev' /), 'A', 'kg/kg/s' , 'Net production rate of rain by Cumulus' )
181 0 : call addfld( 'ntsnprd_Cu' , (/ 'lev' /), 'A', 'kg/kg/s' , 'Net production rate of snow by Cumulus' )
182 :
183 0 : call addfld( 'excessu_Cu' , (/ 'lev' /), 'A', 'no' , 'Updraft saturation excess' )
184 0 : call addfld( 'excess0_Cu' , (/ 'lev' /), 'A', 'no' , 'Environmental saturation excess' )
185 0 : call addfld( 'xc_Cu' , (/ 'lev' /), 'A', 'no' , 'Critical mixing ratio' )
186 0 : call addfld( 'aquad_Cu' , (/ 'lev' /), 'A', 'no' , 'aquad' )
187 0 : call addfld( 'bquad_Cu' , (/ 'lev' /), 'A', 'no' , 'bquad' )
188 0 : call addfld( 'cquad_Cu' , (/ 'lev' /), 'A', 'no' , 'cquad' )
189 0 : call addfld( 'bogbot_Cu' , (/ 'lev' /), 'A', 'no' , 'Cloud buoyancy at the bottom interface' )
190 0 : call addfld( 'bogtop_Cu' , (/ 'lev' /), 'A', 'no' , 'Cloud buoyancy at the top interface' )
191 :
192 0 : call addfld('exit_UWCu_Cu' , horiz_only, 'A', 'no' , 'exit_UWCu' )
193 0 : call addfld('exit_conden_Cu' , horiz_only, 'A', 'no' , 'exit_conden' )
194 0 : call addfld('exit_klclmkx_Cu' , horiz_only, 'A', 'no' , 'exit_klclmkx' )
195 0 : call addfld('exit_klfcmkx_Cu' , horiz_only, 'A', 'no' , 'exit_klfcmkx' )
196 0 : call addfld('exit_ufrc_Cu' , horiz_only, 'A', 'no' , 'exit_ufrc' )
197 0 : call addfld('exit_wtw_Cu' , horiz_only, 'A', 'no' , 'exit_wtw' )
198 0 : call addfld('exit_drycore_Cu' , horiz_only, 'A', 'no' , 'exit_drycore' )
199 0 : call addfld('exit_wu_Cu' , horiz_only, 'A', 'no' , 'exit_wu' )
200 0 : call addfld('exit_cufilter_Cu', horiz_only, 'A', 'no' , 'exit_cufilter' )
201 0 : call addfld('exit_kinv1_Cu' , horiz_only, 'A', 'no' , 'exit_kinv1' )
202 0 : call addfld('exit_rei_Cu' , horiz_only, 'A', 'no' , 'exit_rei' )
203 :
204 0 : call addfld('limit_shcu_Cu' , horiz_only, 'A', 'no' , 'limit_shcu' )
205 0 : call addfld('limit_negcon_Cu' , horiz_only, 'A', 'no' , 'limit_negcon' )
206 0 : call addfld('limit_ufrc_Cu' , horiz_only, 'A', 'no' , 'limit_ufrc' )
207 0 : call addfld('limit_ppen_Cu' , horiz_only, 'A', 'no' , 'limit_ppen' )
208 0 : call addfld('limit_emf_Cu' , horiz_only, 'A', 'no' , 'limit_emf' )
209 0 : call addfld('limit_cinlcl_Cu' , horiz_only, 'A', 'no' , 'limit_cinlcl' )
210 0 : call addfld('limit_cin_Cu' , horiz_only, 'A', 'no' , 'limit_cin' )
211 0 : call addfld('limit_cbmf_Cu' , horiz_only, 'A', 'no' , 'limit_cbmf' )
212 0 : call addfld('limit_rei_Cu' , horiz_only, 'A', 'no' , 'limit_rei' )
213 0 : call addfld('ind_delcin_Cu' , horiz_only, 'A', 'no' , 'ind_delcin' )
214 :
215 0 : if( kind .ne. r8 ) then
216 0 : write(iulog,*) subname//': ERROR -- real KIND does not match internal specification.'
217 0 : call endrun(subname//': ERROR -- real KIND does not match internal specification.')
218 : endif
219 :
220 0 : xlv = xlv_in
221 0 : xlf = xlf_in
222 0 : xls = xlv + xlf
223 0 : cp = cp_in
224 0 : zvir = zvir_in
225 0 : r = r_in
226 0 : g = g_in
227 0 : ep2 = ep2_in
228 0 : p00 = 1.e5_r8
229 0 : rovcp = r/cp
230 :
231 0 : if (rpen == unset_r8) then
232 0 : call endrun(subname//': uwshcu_rpen must be set in the namelist')
233 : end if
234 :
235 0 : if ( masterproc ) then
236 0 : write(iulog,*) subname//': tuning parameters: rpen=',rpen
237 : endif
238 :
239 0 : end subroutine init_uwshcu
240 :
241 0 : subroutine compute_uwshcu_inv( mix , mkx , iend , ncnst , dt , &
242 0 : ps0_inv , zs0_inv , p0_inv , z0_inv , dp0_inv , &
243 0 : u0_inv , v0_inv , qv0_inv , ql0_inv , qi0_inv , &
244 0 : t0_inv , s0_inv , tr0_inv , &
245 0 : tke_inv , cldfrct_inv, concldfrct_inv, pblh , cush , &
246 0 : umf_inv , slflx_inv , qtflx_inv , &
247 0 : flxprc1_inv, flxsnow1_inv, &
248 0 : qvten_inv, qlten_inv , qiten_inv , &
249 0 : sten_inv , uten_inv , vten_inv , trten_inv , &
250 0 : qrten_inv, qsten_inv , precip , snow , evapc_inv, &
251 0 : cufrc_inv, qcu_inv , qlu_inv , qiu_inv , &
252 0 : cbmf , qc_inv , rliq , &
253 0 : cnt_inv , cnb_inv , lchnk , dpdry0_inv, &
254 0 : sh_e_ed_ratio )
255 :
256 : implicit none
257 : integer , intent(in) :: lchnk
258 : integer , intent(in) :: mix
259 : integer , intent(in) :: mkx
260 : integer , intent(in) :: iend
261 : integer , intent(in) :: ncnst
262 : real(r8), intent(in) :: dt ! Time step : 2*delta_t [ s ]
263 : real(r8), intent(in) :: ps0_inv(mix,mkx+1) ! Environmental pressure at the interfaces [ Pa ]
264 : real(r8), intent(in) :: zs0_inv(mix,mkx+1) ! Environmental height at the interfaces [ m ]
265 : real(r8), intent(in) :: p0_inv(mix,mkx) ! Environmental pressure at the layer mid-point [ Pa ]
266 : real(r8), intent(in) :: z0_inv(mix,mkx) ! Environmental height at the layer mid-point [ m ]
267 : real(r8), intent(in) :: dp0_inv(mix,mkx) ! Environmental layer pressure thickness [ Pa ] > 0.
268 : real(r8), intent(in) :: dpdry0_inv(mix,mkx) ! Environmental dry layer pressure thickness [ Pa ]
269 : real(r8), intent(in) :: u0_inv(mix,mkx) ! Environmental zonal wind [ m/s ]
270 : real(r8), intent(in) :: v0_inv(mix,mkx) ! Environmental meridional wind [ m/s ]
271 : real(r8), intent(in) :: qv0_inv(mix,mkx) ! Environmental water vapor specific humidity [ kg/kg ]
272 : real(r8), intent(in) :: ql0_inv(mix,mkx) ! Environmental liquid water specific humidity [ kg/kg ]
273 : real(r8), intent(in) :: qi0_inv(mix,mkx) ! Environmental ice specific humidity [ kg/kg ]
274 : real(r8), intent(in) :: t0_inv(mix,mkx) ! Environmental temperature [ K ]
275 : real(r8), intent(in) :: s0_inv(mix,mkx) ! Environmental dry static energy [ J/kg ]
276 : real(r8), intent(in) :: tr0_inv(mix,mkx,ncnst) ! Environmental tracers [ #, kg/kg ]
277 : real(r8), intent(in) :: tke_inv(mix,mkx+1) ! Turbulent kinetic energy at the interfaces [ m2/s2 ]
278 : real(r8), intent(in) :: cldfrct_inv(mix,mkx) ! Total cloud fraction at the previous time step [ fraction ]
279 : real(r8), intent(in) :: concldfrct_inv(mix,mkx) ! Total convective ( shallow + deep ) cloud fraction
280 : ! at the previous time step [ fraction ]
281 : real(r8), intent(in) :: pblh(mix) ! Height of PBL [ m ]
282 : real(r8), intent(inout) :: cush(mix) ! Convective scale height [ m ]
283 : real(r8), intent(out) :: umf_inv(mix,mkx+1) ! Updraft mass flux at the interfaces [ kg/m2/s ]
284 : real(r8), intent(out) :: qvten_inv(mix,mkx) ! Tendency of water vapor specific humidity [ kg/kg/s ]
285 : real(r8), intent(out) :: qlten_inv(mix,mkx) ! Tendency of liquid water specific humidity [ kg/kg/s ]
286 : real(r8), intent(out) :: qiten_inv(mix,mkx) ! Tendency of ice specific humidity [ kg/kg/s ]
287 : real(r8), intent(out) :: sten_inv(mix,mkx) ! Tendency of dry static energy [ J/kg/s ]
288 : real(r8), intent(out) :: uten_inv(mix,mkx) ! Tendency of zonal wind [ m/s2 ]
289 : real(r8), intent(out) :: vten_inv(mix,mkx) ! Tendency of meridional wind [ m/s2 ]
290 : real(r8), intent(out) :: trten_inv(mix,mkx,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ]
291 : real(r8), intent(out) :: qrten_inv(mix,mkx) ! Tendency of rain water specific humidity [ kg/kg/s ]
292 : real(r8), intent(out) :: qsten_inv(mix,mkx) ! Tendency of snow specific humidity [ kg/kg/s ]
293 : real(r8), intent(out) :: precip(mix) ! Precipitation ( rain + snow ) flux at the surface [ m/s ]
294 : real(r8), intent(out) :: snow(mix) ! Snow flux at the surface [ m/s ]
295 : real(r8), intent(out) :: evapc_inv(mix,mkx) ! Evaporation of precipitation [ kg/kg/s ]
296 : real(r8), intent(out) :: rliq(mix) ! Vertical integral of tendency of detrained cloud condensate qc [ m/s ]
297 : real(r8), intent(out) :: slflx_inv(mix,mkx+1) ! Updraft liquid static energy flux [ J/kg * kg/m2/s ]
298 : real(r8), intent(out) :: qtflx_inv(mix,mkx+1) ! Updraft total water flux [ kg/kg * kg/m2/s ]
299 : real(r8), intent(out) :: flxprc1_inv(mix,mkx+1) ! uw grid-box mean rain+snow flux (kg m^-2 s^-1)
300 : ! for physics buffer calls in convect_shallow.F90
301 : real(r8), intent(out) :: flxsnow1_inv(mix,mkx+1) ! uw grid-box mean snow flux (kg m^-2 s^-1)
302 : ! for physics buffer calls in convect_shallow.F90
303 :
304 : real(r8), intent(out) :: cufrc_inv(mix,mkx) ! Shallow cumulus cloud fraction at the layer mid-point [ fraction ]
305 : real(r8), intent(out) :: qcu_inv(mix,mkx) ! Liquid+ice specific humidity within cumulus updraft [ kg/kg ]
306 : real(r8), intent(out) :: qlu_inv(mix,mkx) ! Liquid water specific humidity within cumulus updraft [ kg/kg ]
307 : real(r8), intent(out) :: qiu_inv(mix,mkx) ! Ice specific humidity within cumulus updraft [ kg/kg ]
308 : real(r8), intent(out) :: qc_inv(mix,mkx) ! Tendency of cumulus condensate detrained into the environment [ kg/kg/s ]
309 : real(r8), intent(out) :: cbmf(mix) ! Cumulus base mass flux [ kg/m2/s ]
310 : real(r8), intent(out) :: cnt_inv(mix) ! Cumulus top interface index, cnt = kpen [ no ]
311 : real(r8), intent(out) :: cnb_inv(mix) ! Cumulus base interface index, cnb = krel - 1 [ no ]
312 :
313 : real(r8), intent(out) :: sh_e_ed_ratio(mix,mkx) ! shallow conv [ent/(ent+det)] ratio
314 :
315 :
316 0 : real(r8) :: ps0(mix,0:mkx) ! Environmental pressure at the interfaces [ Pa ]
317 0 : real(r8) :: zs0(mix,0:mkx) ! Environmental height at the interfaces [ m ]
318 0 : real(r8) :: p0(mix,mkx) ! Environmental pressure at the layer mid-point [ Pa ]
319 0 : real(r8) :: z0(mix,mkx) ! Environmental height at the layer mid-point [ m ]
320 0 : real(r8) :: dp0(mix,mkx) ! Environmental layer pressure thickness [ Pa ] > 0.
321 0 : real(r8) :: dpdry0(mix,mkx) ! Environmental dry layer pressure thickness [ Pa ]
322 0 : real(r8) :: u0(mix,mkx) ! Environmental zonal wind [ m/s ]
323 0 : real(r8) :: v0(mix,mkx) ! Environmental meridional wind [ m/s ]
324 0 : real(r8) :: tke(mix,0:mkx) ! Turbulent kinetic energy at the interfaces [ m2/s2 ]
325 0 : real(r8) :: cldfrct(mix,mkx) ! Total cloud fraction at the previous time step [ fraction ]
326 0 : real(r8) :: concldfrct(mix,mkx) ! Total convective ( shallow + deep ) cloud fraction
327 : ! at the previous time step [ fraction ]
328 0 : real(r8) :: qv0(mix,mkx) ! Environmental water vapor specific humidity [ kg/kg ]
329 0 : real(r8) :: ql0(mix,mkx) ! Environmental liquid water specific humidity [ kg/kg ]
330 0 : real(r8) :: qi0(mix,mkx) ! Environmental ice specific humidity [ kg/kg ]
331 0 : real(r8) :: t0(mix,mkx) ! Environmental temperature [ K ]
332 0 : real(r8) :: s0(mix,mkx) ! Environmental dry static energy [ J/kg ]
333 0 : real(r8) :: tr0(mix,mkx,ncnst) ! Environmental tracers [ #, kg/kg ]
334 0 : real(r8) :: umf(mix,0:mkx) ! Updraft mass flux at the interfaces [ kg/m2/s ]
335 0 : real(r8) :: qvten(mix,mkx) ! Tendency of water vapor specific humidity [ kg/kg/s ]
336 0 : real(r8) :: qlten(mix,mkx) ! Tendency of liquid water specific humidity [ kg/kg/s ]
337 0 : real(r8) :: qiten(mix,mkx) ! tendency of ice specific humidity [ kg/kg/s ]
338 0 : real(r8) :: sten(mix,mkx) ! Tendency of static energy [ J/kg/s ]
339 0 : real(r8) :: uten(mix,mkx) ! Tendency of zonal wind [ m/s2 ]
340 0 : real(r8) :: vten(mix,mkx) ! Tendency of meridional wind [ m/s2 ]
341 0 : real(r8) :: trten(mix,mkx,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ]
342 0 : real(r8) :: qrten(mix,mkx) ! Tendency of rain water specific humidity [ kg/kg/s ]
343 0 : real(r8) :: qsten(mix,mkx) ! Tendency of snow speficif humidity [ kg/kg/s ]
344 0 : real(r8) :: evapc(mix,mkx) ! Tendency of evaporation of precipitation [ kg/kg/s ]
345 0 : real(r8) :: slflx(mix,0:mkx) ! Updraft liquid static energy flux [ J/kg * kg/m2/s ]
346 0 : real(r8) :: qtflx(mix,0:mkx) ! Updraft total water flux [ kg/kg * kg/m2/s ]
347 0 : real(r8) :: flxprc1(mix,0:mkx) ! uw grid-box mean rain+snow flux (kg m^-2 s^-1)
348 : ! for physics buffer calls in convect_shallow.F90
349 0 : real(r8) :: flxsnow1(mix,0:mkx) ! uw grid-box mean snow flux (kg m^-2 s^-1)
350 : ! for physics buffer calls in convect_shallow.F90
351 0 : real(r8) :: cufrc(mix,mkx) ! Shallow cumulus cloud fraction at the layer mid-point [ fraction ]
352 0 : real(r8) :: qcu(mix,mkx) ! Condensate water specific humidity within cumulus updraft
353 : ! at the layer mid-point [ kg/kg ]
354 0 : real(r8) :: qlu(mix,mkx) ! Liquid water specific humidity within cumulus updraft
355 : ! at the layer mid-point [ kg/kg ]
356 0 : real(r8) :: qiu(mix,mkx) ! Ice specific humidity within cumulus updraft
357 : ! at the layer mid-point [ kg/kg ]
358 0 : real(r8) :: qc(mix,mkx) ! Tendency of cumulus condensate detrained into the environment [ kg/kg/s ]
359 0 : real(r8) :: cnt(mix) ! Cumulus top interface index, cnt = kpen [ no ]
360 0 : real(r8) :: cnb(mix) ! Cumulus base interface index, cnb = krel - 1 [ no ]
361 :
362 0 : real(r8) :: fer_out(mix,mkx) ! Fractional lateral entrainment rate [ 1/Pa ]
363 0 : real(r8) :: fdr_out(mix,mkx) ! Fractional lateral detrainment rate [ 1/Pa ]
364 :
365 : integer :: i
366 : integer :: k ! Vertical index for local fields [ no ]
367 : integer :: k_inv ! Vertical index for incoming fields [ no ]
368 : integer :: m ! Tracer index [ no ]
369 :
370 0 : do k = 1, mkx
371 0 : k_inv = mkx + 1 - k
372 0 : p0(:iend,k) = p0_inv(:iend,k_inv)
373 0 : u0(:iend,k) = u0_inv(:iend,k_inv)
374 0 : v0(:iend,k) = v0_inv(:iend,k_inv)
375 0 : z0(:iend,k) = z0_inv(:iend,k_inv)
376 0 : dp0(:iend,k) = dp0_inv(:iend,k_inv)
377 0 : dpdry0(:iend,k) = dpdry0_inv(:iend,k_inv)
378 0 : qv0(:iend,k) = qv0_inv(:iend,k_inv)
379 0 : ql0(:iend,k) = ql0_inv(:iend,k_inv)
380 0 : qi0(:iend,k) = qi0_inv(:iend,k_inv)
381 0 : t0(:iend,k) = t0_inv(:iend,k_inv)
382 0 : s0(:iend,k) = s0_inv(:iend,k_inv)
383 0 : cldfrct(:iend,k) = cldfrct_inv(:iend,k_inv)
384 0 : concldfrct(:iend,k) = concldfrct_inv(:iend,k_inv)
385 0 : do m = 1, ncnst
386 0 : tr0(:iend,k,m) = tr0_inv(:iend,k_inv,m)
387 : enddo
388 : enddo
389 :
390 0 : do k = 0, mkx
391 0 : k_inv = mkx + 1 - k
392 0 : ps0(:iend,k) = ps0_inv(:iend,k_inv)
393 0 : zs0(:iend,k) = zs0_inv(:iend,k_inv)
394 0 : tke(:iend,k) = tke_inv(:iend,k_inv)
395 : end do
396 :
397 : call compute_uwshcu( mix , mkx , iend , ncnst , dt , &
398 : ps0 , zs0 , p0 , z0 , dp0 , &
399 : u0 , v0 , qv0 , ql0 , qi0 , &
400 : t0 , s0 , tr0 , &
401 : tke , cldfrct, concldfrct, pblh , cush , &
402 : umf , slflx , qtflx , &
403 : flxprc1 , flxsnow1 , &
404 : qvten, qlten , qiten , &
405 : sten , uten , vten , trten , &
406 : qrten, qsten , precip , snow , evapc, &
407 : cufrc, qcu , qlu , qiu , &
408 : cbmf , qc , rliq , &
409 : cnt , cnb , lchnk , dpdry0, &
410 0 : fer_out, fdr_out )
411 :
412 : ! Reverse cloud top/base interface indices
413 :
414 0 : cnt_inv(:iend) = mkx + 1 - cnt(:iend)
415 0 : cnb_inv(:iend) = mkx + 1 - cnb(:iend)
416 :
417 0 : do k = 0, mkx
418 0 : k_inv = mkx + 1 - k
419 0 : umf_inv(:iend,k_inv) = umf(:iend,k)
420 0 : slflx_inv(:iend,k_inv) = slflx(:iend,k)
421 0 : qtflx_inv(:iend,k_inv) = qtflx(:iend,k)
422 0 : flxprc1_inv(:iend,k_inv) = flxprc1(:iend,k) ! reversed for output to cam
423 0 : flxsnow1_inv(:iend,k_inv) = flxsnow1(:iend,k) ! ""
424 : end do
425 :
426 0 : do k = 1, mkx
427 0 : k_inv = mkx + 1 - k
428 0 : qvten_inv(:iend,k_inv) = qvten(:iend,k)
429 0 : qlten_inv(:iend,k_inv) = qlten(:iend,k)
430 0 : qiten_inv(:iend,k_inv) = qiten(:iend,k)
431 0 : sten_inv(:iend,k_inv) = sten(:iend,k)
432 0 : uten_inv(:iend,k_inv) = uten(:iend,k)
433 0 : vten_inv(:iend,k_inv) = vten(:iend,k)
434 0 : qrten_inv(:iend,k_inv) = qrten(:iend,k)
435 0 : qsten_inv(:iend,k_inv) = qsten(:iend,k)
436 0 : evapc_inv(:iend,k_inv) = evapc(:iend,k)
437 0 : cufrc_inv(:iend,k_inv) = cufrc(:iend,k)
438 0 : qcu_inv(:iend,k_inv) = qcu(:iend,k)
439 0 : qlu_inv(:iend,k_inv) = qlu(:iend,k)
440 0 : qiu_inv(:iend,k_inv) = qiu(:iend,k)
441 0 : qc_inv(:iend,k_inv) = qc(:iend,k)
442 0 : do m = 1, ncnst
443 0 : trten_inv(:iend,k_inv,m) = trten(:iend,k,m)
444 : enddo
445 :
446 : enddo
447 :
448 0 : sh_e_ed_ratio(:iend,:) = -1.0_r8
449 0 : do k = 1, mkx
450 0 : do i = 1, iend
451 0 : if ( max(fer_out(i,k),fdr_out(i,k)) > 1.0e-10_r8) then
452 : sh_e_ed_ratio(i,k) = max(fer_out(i,k),0.0_r8) &
453 0 : / (max(fer_out(i,k),0.0_r8) + max(fdr_out(i,k),0.0_r8))
454 : end if
455 : end do
456 : end do
457 :
458 0 : end subroutine compute_uwshcu_inv
459 :
460 0 : subroutine compute_uwshcu( mix , mkx , iend , ncnst , dt , &
461 0 : ps0_in , zs0_in , p0_in , z0_in , dp0_in , &
462 0 : u0_in , v0_in , qv0_in , ql0_in , qi0_in , &
463 0 : t0_in , s0_in , tr0_in , &
464 0 : tke_in , cldfrct_in, concldfrct_in, pblh_in , cush_inout, &
465 0 : umf_out , slflx_out , qtflx_out , &
466 0 : flxprc1_out , flxsnow1_out , &
467 0 : qvten_out, qlten_out , qiten_out , &
468 0 : sten_out , uten_out , vten_out , trten_out, &
469 0 : qrten_out, qsten_out , precip_out , snow_out , evapc_out , &
470 0 : cufrc_out, qcu_out , qlu_out , qiu_out , &
471 0 : cbmf_out , qc_out , rliq_out , &
472 0 : cnt_out , cnb_out , lchnk , dpdry0_in , &
473 0 : fer_out , fdr_out )
474 :
475 : ! ------------------------------------------------------------ !
476 : ! !
477 : ! University of Washington Shallow Convection Scheme !
478 : ! !
479 : ! Described in Park and Bretherton. 2008. J. Climate : !
480 : ! !
481 : ! 'The University of Washington shallow convection and !
482 : ! moist turbulent schemes and their impact on climate !
483 : ! simulations with the Community Atmosphere Model' !
484 : ! !
485 : ! Coded by Sungsu Park. Oct.2005. !
486 : ! May.2008. !
487 : ! For questions, send an email to sungsup@ucar.edu or !
488 : ! sungsu@atmos.washington.edu !
489 : ! !
490 : ! ------------------------------------------------------------ !
491 :
492 : use cam_history, only : outfld
493 : use constituents, only : qmin, cnst_get_type_byind, cnst_get_ind
494 : use wv_saturation, only : findsp_vc
495 :
496 : implicit none
497 :
498 : ! ---------------------- !
499 : ! Input-Output Variables !
500 : ! ---------------------- !
501 :
502 : integer , intent(in) :: lchnk
503 : integer , intent(in) :: mix
504 : integer , intent(in) :: mkx
505 : integer , intent(in) :: iend
506 : integer , intent(in) :: ncnst
507 : real(r8), intent(in) :: dt ! Time step : 2*delta_t [ s ]
508 : real(r8), intent(in) :: ps0_in(mix,0:mkx) ! Environmental pressure at the interfaces [ Pa ]
509 : real(r8), intent(in) :: zs0_in(mix,0:mkx) ! Environmental height at the interfaces [ m ]
510 : real(r8), intent(in) :: p0_in(mix,mkx) ! Environmental pressure at the layer mid-point [ Pa ]
511 : real(r8), intent(in) :: z0_in(mix,mkx) ! Environmental height at the layer mid-point [ m ]
512 : real(r8), intent(in) :: dp0_in(mix,mkx) ! Environmental layer pressure thickness [ Pa ] > 0.
513 : real(r8), intent(in) :: dpdry0_in(mix,mkx) ! Environmental dry layer pressure thickness [ Pa ]
514 : real(r8), intent(in) :: u0_in(mix,mkx) ! Environmental zonal wind [ m/s ]
515 : real(r8), intent(in) :: v0_in(mix,mkx) ! Environmental meridional wind [ m/s ]
516 : real(r8), intent(in) :: qv0_in(mix,mkx) ! Environmental water vapor specific humidity [ kg/kg ]
517 : real(r8), intent(in) :: ql0_in(mix,mkx) ! Environmental liquid water specific humidity [ kg/kg ]
518 : real(r8), intent(in) :: qi0_in(mix,mkx) ! Environmental ice specific humidity [ kg/kg ]
519 : real(r8), intent(in) :: t0_in(mix,mkx) ! Environmental temperature [ K ]
520 : real(r8), intent(in) :: s0_in(mix,mkx) ! Environmental dry static energy [ J/kg ]
521 : real(r8), intent(in) :: tr0_in(mix,mkx,ncnst) ! Environmental tracers [ #, kg/kg ]
522 : real(r8), intent(in) :: tke_in(mix,0:mkx) ! Turbulent kinetic energy at the interfaces [ m2/s2 ]
523 : real(r8), intent(in) :: cldfrct_in(mix,mkx) ! Total cloud fraction at the previous time step [ fraction ]
524 : real(r8), intent(in) :: concldfrct_in(mix,mkx) ! Total convective cloud fraction
525 : ! at the previous time step [ fraction ]
526 : real(r8), intent(in) :: pblh_in(mix) ! Height of PBL [ m ]
527 : real(r8), intent(inout) :: cush_inout(mix) ! Convective scale height [ m ]
528 :
529 0 : real(r8) tw0_in(mix,mkx) ! Wet bulb temperature [ K ]
530 0 : real(r8) qw0_in(mix,mkx) ! Wet-bulb specific humidity [ kg/kg ]
531 :
532 : real(r8), intent(out) :: umf_out(mix,0:mkx) ! Updraft mass flux at the interfaces [ kg/m2/s ]
533 : real(r8), intent(out) :: qvten_out(mix,mkx) ! Tendency of water vapor specific humidity [ kg/kg/s ]
534 : real(r8), intent(out) :: qlten_out(mix,mkx) ! Tendency of liquid water specific humidity [ kg/kg/s ]
535 : real(r8), intent(out) :: qiten_out(mix,mkx) ! Tendency of ice specific humidity [ kg/kg/s ]
536 : real(r8), intent(out) :: sten_out(mix,mkx) ! Tendency of dry static energy [ J/kg/s ]
537 : real(r8), intent(out) :: uten_out(mix,mkx) ! Tendency of zonal wind [ m/s2 ]
538 : real(r8), intent(out) :: vten_out(mix,mkx) ! Tendency of meridional wind [ m/s2 ]
539 : real(r8), intent(out) :: trten_out(mix,mkx,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ]
540 : real(r8), intent(out) :: qrten_out(mix,mkx) ! Tendency of rain water specific humidity [ kg/kg/s ]
541 : real(r8), intent(out) :: qsten_out(mix,mkx) ! Tendency of snow specific humidity [ kg/kg/s ]
542 : real(r8), intent(out) :: precip_out(mix) ! Precipitation ( rain + snow ) rate at surface [ m/s ]
543 : real(r8), intent(out) :: snow_out(mix) ! Snow rate at surface [ m/s ]
544 : real(r8), intent(out) :: evapc_out(mix,mkx) ! Tendency of evaporation of precipitation [ kg/kg/s ]
545 : real(r8), intent(out) :: slflx_out(mix,0:mkx) ! Updraft/pen.entrainment liquid static energy flux
546 : ! [ J/kg * kg/m2/s ]
547 : real(r8), intent(out) :: qtflx_out(mix,0:mkx) ! updraft/pen.entrainment total water flux [ kg/kg * kg/m2/s ]
548 : real(r8), intent(out) :: flxprc1_out(mix,0:mkx) ! precip (rain+snow) flux
549 : real(r8), intent(out) :: flxsnow1_out(mix,0:mkx) ! snow flux
550 : real(r8), intent(out) :: cufrc_out(mix,mkx) ! Shallow cumulus cloud fraction at the layer mid-point [ fraction ]
551 : real(r8), intent(out) :: qcu_out(mix,mkx) ! Condensate water specific humidity within cumulus updraft [ kg/kg ]
552 : real(r8), intent(out) :: qlu_out(mix,mkx) ! Liquid water specific humidity within cumulus updraft [ kg/kg ]
553 : real(r8), intent(out) :: qiu_out(mix,mkx) ! Ice specific humidity within cumulus updraft [ kg/kg ]
554 : real(r8), intent(out) :: cbmf_out(mix) ! Cloud base mass flux [ kg/m2/s ]
555 : real(r8), intent(out) :: qc_out(mix,mkx) ! Tendency of detrained cumulus condensate
556 : ! into the environment [ kg/kg/s ]
557 : real(r8), intent(out) :: rliq_out(mix) ! Vertical integral of qc_out [ m/s ]
558 : real(r8), intent(out) :: cnt_out(mix) ! Cumulus top interface index, cnt = kpen [ no ]
559 : real(r8), intent(out) :: cnb_out(mix) ! Cumulus base interface index, cnb = krel - 1 [ no ]
560 : real(r8), intent(out) :: fer_out(mix,mkx) ! Fractional lateral entrainment rate [ 1/Pa ]
561 : real(r8), intent(out) :: fdr_out(mix,mkx) ! Fractional lateral detrainment rate [ 1/Pa ]
562 :
563 : !
564 : ! Internal Output Variables
565 : !
566 :
567 0 : real(r8) qtten_out(mix,mkx) ! Tendency of qt [ kg/kg/s ]
568 0 : real(r8) slten_out(mix,mkx) ! Tendency of sl [ J/kg/s ]
569 0 : real(r8) ufrc_out(mix,0:mkx) ! Updraft fractional area at the interfaces [ fraction ]
570 0 : real(r8) uflx_out(mix,0:mkx) ! Updraft/pen.entrainment zonal momentum flux [ m/s/m2/s ]
571 0 : real(r8) vflx_out(mix,0:mkx) ! Updraft/pen.entrainment meridional momentum flux [ m/s/m2/s ]
572 0 : real(r8) cinh_out(mix) ! Convective INhibition upto LFC (CIN) [ J/kg ]
573 0 : real(r8) trflx_out(mix,0:mkx,ncnst) ! Updraft/pen.entrainment tracer flux [ #/m2/s, kg/kg/m2/s ]
574 :
575 : ! -------------------------------------------- !
576 : ! One-dimensional variables at each grid point !
577 : ! -------------------------------------------- !
578 :
579 : ! 1. Input variables
580 :
581 0 : real(r8) ps0(0:mkx) ! Environmental pressure at the interfaces [ Pa ]
582 0 : real(r8) zs0(0:mkx) ! Environmental height at the interfaces [ m ]
583 0 : real(r8) p0(mkx) ! Environmental pressure at the layer mid-point [ Pa ]
584 0 : real(r8) z0(mkx) ! Environmental height at the layer mid-point [ m ]
585 0 : real(r8) dp0(mkx) ! Environmental layer pressure thickness [ Pa ] > 0.
586 0 : real(r8) dpdry0(mkx) ! Environmental dry layer pressure thickness [ Pa ]
587 0 : real(r8) u0(mkx) ! Environmental zonal wind [ m/s ]
588 0 : real(r8) v0(mkx) ! Environmental meridional wind [ m/s ]
589 0 : real(r8) tke(0:mkx) ! Turbulent kinetic energy at the interfaces [ m2/s2 ]
590 0 : real(r8) cldfrct(mkx) ! Total cloud fraction at the previous time step [ fraction ]
591 0 : real(r8) concldfrct(mkx) ! Total convective cloud fraction
592 : ! at the previous time step [ fraction ]
593 0 : real(r8) qv0(mkx) ! Environmental water vapor specific humidity [ kg/kg ]
594 0 : real(r8) ql0(mkx) ! Environmental liquid water specific humidity [ kg/kg ]
595 0 : real(r8) qi0(mkx) ! Environmental ice specific humidity [ kg/kg ]
596 0 : real(r8) t0(mkx) ! Environmental temperature [ K ]
597 0 : real(r8) s0(mkx) ! Environmental dry static energy [ J/kg ]
598 : real(r8) pblh ! Height of PBL [ m ]
599 : real(r8) cush ! Convective scale height [ m ]
600 0 : real(r8) tr0(mkx,ncnst) ! Environmental tracers [ #, kg/kg ]
601 :
602 : ! 2. Environmental variables directly derived from the input variables
603 :
604 0 : real(r8) qt0(mkx) ! Environmental total specific humidity [ kg/kg ]
605 0 : real(r8) thl0(mkx) ! Environmental liquid potential temperature [ K ]
606 0 : real(r8) thvl0(mkx) ! Environmental liquid virtual potential temperature [ K ]
607 0 : real(r8) ssqt0(mkx) ! Linear internal slope
608 : ! of environmental total specific humidity [ kg/kg/Pa ]
609 0 : real(r8) ssthl0(mkx) ! Linear internal slope
610 : ! of environmental liquid potential temperature [ K/Pa ]
611 0 : real(r8) ssu0(mkx) ! Linear internal slope of environmental zonal wind [ m/s/Pa ]
612 0 : real(r8) ssv0(mkx) ! Linear internal slope of environmental meridional wind [ m/s/Pa ]
613 0 : real(r8) thv0bot(mkx) ! Environmental virtual potential temperature
614 : ! at the bottom of each layer [ K ]
615 0 : real(r8) thv0top(mkx) ! Environmental virtual potential temperature
616 : ! at the top of each layer [ K ]
617 0 : real(r8) thvl0bot(mkx) ! Environmental liquid virtual potential temperature
618 : ! at the bottom of each layer [ K ]
619 0 : real(r8) thvl0top(mkx) ! Environmental liquid virtual potential temperature
620 : ! at the top of each layer [ K ]
621 0 : real(r8) exn0(mkx) ! Exner function at the layer mid points [ no ]
622 0 : real(r8) exns0(0:mkx) ! Exner function at the interfaces [ no ]
623 0 : real(r8) sstr0(mkx,ncnst) ! Linear slope of environmental tracers [ #/Pa, kg/kg/Pa ]
624 :
625 : ! 2-1. For preventing negative condensate at the provisional time step
626 :
627 0 : real(r8) qv0_star(mkx) ! Environmental water vapor specific humidity [ kg/kg ]
628 0 : real(r8) ql0_star(mkx) ! Environmental liquid water specific humidity [ kg/kg ]
629 0 : real(r8) qi0_star(mkx) ! Environmental ice specific humidity [ kg/kg ]
630 : real(r8) t0_star(mkx) ! Environmental temperature [ K ]
631 0 : real(r8) s0_star(mkx) ! Environmental dry static energy [ J/kg ]
632 :
633 : ! 3. Variables associated with cumulus convection
634 :
635 0 : real(r8) umf(0:mkx) ! Updraft mass flux at the interfaces [ kg/m2/s ]
636 0 : real(r8) emf(0:mkx) ! Penetrative entrainment mass flux at the interfaces [ kg/m2/s ]
637 0 : real(r8) qvten(mkx) ! Tendency of water vapor specific humidity [ kg/kg/s ]
638 0 : real(r8) qlten(mkx) ! Tendency of liquid water specific humidity [ kg/kg/s ]
639 0 : real(r8) qiten(mkx) ! Tendency of ice specific humidity [ kg/kg/s ]
640 0 : real(r8) sten(mkx) ! Tendency of dry static energy [ J/kg ]
641 0 : real(r8) uten(mkx) ! Tendency of zonal wind [ m/s2 ]
642 0 : real(r8) vten(mkx) ! Tendency of meridional wind [ m/s2 ]
643 0 : real(r8) qrten(mkx) ! Tendency of rain water specific humidity [ kg/kg/s ]
644 0 : real(r8) qsten(mkx) ! Tendency of snow specific humidity [ kg/kg/s ]
645 : real(r8) precip ! Precipitation rate ( rain + snow) at the surface [ m/s ]
646 : real(r8) snow ! Snow rate at the surface [ m/s ]
647 0 : real(r8) evapc(mkx) ! Tendency of evaporation of precipitation [ kg/kg/s ]
648 0 : real(r8) slflx(0:mkx) ! Updraft/pen.entrainment liquid static energy flux
649 : ! [ J/kg * kg/m2/s ]
650 0 : real(r8) qtflx(0:mkx) ! Updraft/pen.entrainment total water flux [ kg/kg * kg/m2/s ]
651 0 : real(r8) uflx(0:mkx) ! Updraft/pen.entrainment flux of zonal momentum [ m/s/m2/s ]
652 0 : real(r8) vflx(0:mkx) ! Updraft/pen.entrainment flux of meridional momentum [ m/s/m2/s ]
653 0 : real(r8) cufrc(mkx) ! Shallow cumulus cloud fraction at the layer mid-point [ fraction ]
654 0 : real(r8) qcu(mkx) ! Condensate water specific humidity
655 : ! within convective updraft [ kg/kg ]
656 0 : real(r8) qlu(mkx) ! Liquid water specific humidity within convective updraft [ kg/kg ]
657 0 : real(r8) qiu(mkx) ! Ice specific humidity within convective updraft [ kg/kg ]
658 0 : real(r8) dwten(mkx) ! Detrained water tendency from cumulus updraft [ kg/kg/s ]
659 0 : real(r8) diten(mkx) ! Detrained ice tendency from cumulus updraft [ kg/kg/s ]
660 0 : real(r8) fer(mkx) ! Fractional lateral entrainment rate [ 1/Pa ]
661 0 : real(r8) fdr(mkx) ! Fractional lateral detrainment rate [ 1/Pa ]
662 0 : real(r8) uf(mkx) ! Zonal wind at the provisional time step [ m/s ]
663 0 : real(r8) vf(mkx) ! Meridional wind at the provisional time step [ m/s ]
664 0 : real(r8) qc(mkx) ! Tendency due to detrained 'cloud water + cloud ice'
665 : ! (without rain-snow contribution) [ kg/kg/s ]
666 0 : real(r8) qc_l(mkx) ! Tendency due to detrained 'cloud water'
667 : ! (without rain-snow contribution) [ kg/kg/s ]
668 0 : real(r8) qc_i(mkx) ! Tendency due to detrained 'cloud ice'
669 : ! (without rain-snow contribution) [ kg/kg/s ]
670 : real(r8) qc_lm
671 : real(r8) qc_im
672 : real(r8) nc_lm
673 : real(r8) nc_im
674 : real(r8) ql_emf_kbup
675 : real(r8) qi_emf_kbup
676 : real(r8) nl_emf_kbup
677 : real(r8) ni_emf_kbup
678 : real(r8) qlten_det
679 : real(r8) qiten_det
680 : real(r8) rliq ! Vertical integral of qc [ m/s ]
681 : real(r8) cnt ! Cumulus top interface index, cnt = kpen [ no ]
682 : real(r8) cnb ! Cumulus base interface index, cnb = krel - 1 [ no ]
683 0 : real(r8) qtten(mkx) ! Tendency of qt [ kg/kg/s ]
684 0 : real(r8) slten(mkx) ! Tendency of sl [ J/kg/s ]
685 0 : real(r8) ufrc(0:mkx) ! Updraft fractional area [ fraction ]
686 0 : real(r8) trten(mkx,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ]
687 0 : real(r8) trflx(0:mkx,ncnst) ! Flux of tracers due to convection [ # * kg/m2/s, kg/kg * kg/m2/s ]
688 0 : real(r8) trflx_d(0:mkx) ! Adjustive downward flux of tracers to prevent negative tracers
689 0 : real(r8) trflx_u(0:mkx) ! Adjustive upward flux of tracers to prevent negative tracers
690 : real(r8) trmin ! Minimum concentration of tracers allowed
691 : real(r8) pdelx, dum
692 :
693 : !----- Variables used for the calculation of condensation sink associated with compensating subsidence
694 : ! In the current code, this 'sink' tendency is simply set to be zero.
695 :
696 0 : real(r8) uemf(0:mkx) ! Net updraft mass flux at the interface ( emf + umf ) [ kg/m2/s ]
697 0 : real(r8) comsub(mkx) ! Compensating subsidence
698 : ! at the layer mid-point ( unit of mass flux, umf ) [ kg/m2/s ]
699 0 : real(r8) qlten_sink(mkx) ! Liquid condensate tendency
700 : ! by compensating subsidence/upwelling [ kg/kg/s ]
701 0 : real(r8) qiten_sink(mkx) ! Ice condensate tendency
702 : ! by compensating subsidence/upwelling [ kg/kg/s ]
703 0 : real(r8) nlten_sink(mkx) ! Liquid droplets # tendency
704 : ! by compensating subsidence/upwelling [ kg/kg/s ]
705 0 : real(r8) niten_sink(mkx) ! Ice droplets # tendency
706 : ! by compensating subsidence/upwelling [ kg/kg/s ]
707 : real(r8) thlten_sub, qtten_sub ! Tendency of conservative scalars
708 : ! by compensating subsidence/upwelling
709 : real(r8) qlten_sub, qiten_sub ! Tendency of ql0, qi0
710 : ! by compensating subsidence/upwelling
711 : real(r8) nlten_sub, niten_sub ! Tendency of nl0, ni0
712 : ! by compensating subsidence/upwelling
713 : real(r8) thl_prog, qt_prog ! Prognosed 'thl, qt'
714 : ! by compensating subsidence/upwelling
715 :
716 : !----- Variables describing cumulus updraft
717 :
718 0 : real(r8) wu(0:mkx) ! Updraft vertical velocity at the interface [ m/s ]
719 0 : real(r8) thlu(0:mkx) ! Updraft liquid potential temperature at the interface [ K ]
720 0 : real(r8) qtu(0:mkx) ! Updraft total specific humidity at the interface [ kg/kg ]
721 0 : real(r8) uu(0:mkx) ! Updraft zonal wind at the interface [ m/s ]
722 0 : real(r8) vu(0:mkx) ! Updraft meridional wind at the interface [ m/s ]
723 0 : real(r8) thvu(0:mkx) ! Updraft virtual potential temperature at the interface [ m/s ]
724 0 : real(r8) rei(mkx) ! Updraft fractional mixing rate with the environment [ 1/Pa ]
725 0 : real(r8) tru(0:mkx,ncnst) ! Updraft tracers [ #, kg/kg ]
726 :
727 : !----- Variables describing conservative scalars of entraining downdrafts at the
728 : ! entraining interfaces, i.e., 'kbup <= k < kpen-1'. At the other interfaces,
729 : ! belows are simply set to equal to those of updraft for simplicity - but it
730 : ! does not influence numerical calculation.
731 :
732 0 : real(r8) thlu_emf(0:mkx) ! Penetrative downdraft liquid potential temperature
733 : ! at entraining interfaces [ K ]
734 0 : real(r8) qtu_emf(0:mkx) ! Penetrative downdraft total water
735 : ! at entraining interfaces [ kg/kg ]
736 0 : real(r8) uu_emf(0:mkx) ! Penetrative downdraft zonal wind
737 : ! at entraining interfaces [ m/s ]
738 0 : real(r8) vu_emf(0:mkx) ! Penetrative downdraft meridional wind
739 : ! at entraining interfaces [ m/s ]
740 0 : real(r8) tru_emf(0:mkx,ncnst) ! Penetrative Downdraft tracers
741 : ! at entraining interfaces [ #, kg/kg ]
742 :
743 : !----- Variables associated with evaporations of convective 'rain' and 'snow'
744 :
745 0 : real(r8) flxrain(0:mkx) ! Downward rain flux at each interface [ kg/m2/s ]
746 0 : real(r8) flxsnow(0:mkx) ! Downward snow flux at each interface [ kg/m2/s ]
747 0 : real(r8) ntraprd(mkx) ! Net production ( production - evaporation + melting )
748 : ! rate of rain in each layer [ kg/kg/s ]
749 0 : real(r8) ntsnprd(mkx) ! Net production ( production - evaporation + freezing )
750 : ! rate of snow in each layer [ kg/kg/s ]
751 : real(r8) flxsntm ! Downward snow flux
752 : ! at the top of each layer after melting [ kg/m2/s ]
753 : real(r8) snowmlt ! Snow melting tendency [ kg/kg/s ]
754 : real(r8) subsat ! Sub-saturation ratio (1-qv/qs) [ no unit ]
755 : real(r8) evprain ! Evaporation rate of rain [ kg/kg/s ]
756 : real(r8) evpsnow ! Evaporation rate of snow [ kg/kg/s ]
757 : real(r8) evplimit ! Limiter of 'evprain + evpsnow' [ kg/kg/s ]
758 : real(r8) evplimit_rain ! Limiter of 'evprain' [ kg/kg/s ]
759 : real(r8) evplimit_snow ! Limiter of 'evpsnow' [ kg/kg/s ]
760 : real(r8) evpint_rain ! Vertically-integrated evaporative flux of rain [ kg/m2/s ]
761 : real(r8) evpint_snow ! Vertically-integrated evaporative flux of snow [ kg/m2/s ]
762 : real(r8) kevp ! Evaporative efficiency [ complex unit ]
763 :
764 : !----- Other internal variables
765 :
766 : integer kk, mm, k, i, m, kp1, km1
767 : integer iter_scaleh, iter_xc
768 : integer id_check, status
769 : integer klcl ! Layer containing LCL of source air
770 : integer kinv ! Inversion layer with PBL top interface as a lower interface
771 : integer krel ! Release layer where buoyancy sorting mixing
772 : ! occurs for the first time
773 : integer klfc ! LFC layer of cumulus source air
774 : integer kbup ! Top layer in which cloud buoyancy is positive at the top interface
775 : integer kpen ! Highest layer with positive updraft vertical velocity
776 : ! - top layer cumulus can reach
777 : logical id_exit
778 : logical forcedCu ! If 'true', cumulus updraft cannot overcome the buoyancy barrier
779 : ! just above the PBL top.
780 : real(r8) thlsrc, qtsrc, usrc, vsrc, thvlsrc ! Updraft source air properties
781 : real(r8) PGFc, uplus, vplus
782 0 : real(r8) trsrc(ncnst), tre(ncnst)
783 : real(r8) plcl, plfc, prel, wrel
784 : real(r8) frc_rasn
785 : real(r8) ee2, ud2, wtw, wtwb, wtwh
786 : real(r8) xc, xc_2
787 : real(r8) cldhgt, scaleh, tscaleh, cridis, rle, rkm
788 : real(r8) rkfre, sigmaw, epsvarw, tkeavg, dpsum, dpi, thvlmin
789 : real(r8) thlxsat, qtxsat, thvxsat, x_cu, x_en, thv_x0, thv_x1
790 : real(r8) thj, qvj, qlj, qij, thvj, tj, thv0j, rho0j, rhos0j, qse
791 : real(r8) cin, cinlcl
792 : real(r8) pe, dpe, exne, thvebot, thle, qte, ue, ve, thlue, qtue, wue
793 : real(r8) mu, mumin0, mumin1, mumin2, mulcl, mulclstar
794 : real(r8) cbmf, wcrit, winv, wlcl, ufrcinv, ufrclcl, rmaxfrac
795 : real(r8) criqc, exql, exqi, ppen
796 : real(r8) thl0top, thl0bot, qt0bot, qt0top, thvubot, thvutop
797 : real(r8) thlu_top, qtu_top, qlu_top, qiu_top, qlu_mid, qiu_mid, exntop
798 : real(r8) thl0lcl, qt0lcl, thv0lcl, thv0rel, rho0inv, autodet
799 : real(r8) aquad, bquad, cquad, xc1, xc2, excessu, excess0, xsat, xs1, xs2
800 : real(r8) bogbot, bogtop, delbog, drage, expfac, rbuoy, rdrag
801 : real(r8) rcwp, rlwp, riwp, qcubelow, qlubelow, qiubelow
802 : real(r8) rainflx, snowflx
803 : real(r8) es
804 : real(r8) qs
805 : real(r8) qsat_arg
806 0 : real(r8) xsrc, xmean, xtop, xbot, xflx(0:mkx)
807 : real(r8) tmp1, tmp2
808 :
809 : !----- Some diagnostic internal output variables
810 :
811 0 : real(r8) ufrcinvbase_out(mix) ! Cumulus updraft fraction at the PBL top [ fraction ]
812 0 : real(r8) ufrclcl_out(mix) ! Cumulus updraft fraction at the LCL
813 : ! ( or PBL top when LCL is below PBL top ) [ fraction ]
814 0 : real(r8) winvbase_out(mix) ! Cumulus updraft velocity at the PBL top [ m/s ]
815 0 : real(r8) wlcl_out(mix) ! Cumulus updraft velocity at the LCL
816 : ! ( or PBL top when LCL is below PBL top ) [ m/s ]
817 0 : real(r8) plcl_out(mix) ! LCL of source air [ Pa ]
818 0 : real(r8) pinv_out(mix) ! PBL top pressure [ Pa ]
819 0 : real(r8) plfc_out(mix) ! LFC of source air [ Pa ]
820 0 : real(r8) pbup_out(mix) ! Highest interface level of positive buoyancy [ Pa ]
821 0 : real(r8) ppen_out(mix) ! Highest interface evel where Cu w = 0 [ Pa ]
822 0 : real(r8) qtsrc_out(mix) ! Sourse air qt [ kg/kg ]
823 0 : real(r8) thlsrc_out(mix) ! Sourse air thl [ K ]
824 0 : real(r8) thvlsrc_out(mix) ! Sourse air thvl [ K ]
825 0 : real(r8) emfkbup_out(mix) ! Penetrative downward mass flux at 'kbup' interface [ kg/m2/s ]
826 0 : real(r8) cinlclh_out(mix) ! Convective INhibition upto LCL (CIN) [ J/kg = m2/s2 ]
827 0 : real(r8) tkeavg_out(mix) ! Average tke over the PBL [ m2/s2 ]
828 0 : real(r8) cbmflimit_out(mix) ! Cloud base mass flux limiter [ kg/m2/s ]
829 0 : real(r8) zinv_out(mix) ! PBL top height [ m ]
830 0 : real(r8) rcwp_out(mix) ! Layer mean Cumulus LWP+IWP [ kg/m2 ]
831 0 : real(r8) rlwp_out(mix) ! Layer mean Cumulus LWP [ kg/m2 ]
832 0 : real(r8) riwp_out(mix) ! Layer mean Cumulus IWP [ kg/m2 ]
833 0 : real(r8) wu_out(mix,0:mkx) ! Updraft vertical velocity
834 : ! ( defined from the release level to 'kpen-1' interface )
835 0 : real(r8) qtu_out(mix,0:mkx) ! Updraft qt [ kg/kg ]
836 0 : real(r8) thlu_out(mix,0:mkx) ! Updraft thl [ K ]
837 0 : real(r8) thvu_out(mix,0:mkx) ! Updraft thv [ K ]
838 0 : real(r8) uu_out(mix,0:mkx) ! Updraft zonal wind [ m/s ]
839 0 : real(r8) vu_out(mix,0:mkx) ! Updraft meridional wind [ m/s ]
840 0 : real(r8) qtu_emf_out(mix,0:mkx) ! Penetratively entrained qt [ kg/kg ]
841 0 : real(r8) thlu_emf_out(mix,0:mkx) ! Penetratively entrained thl [ K ]
842 0 : real(r8) uu_emf_out(mix,0:mkx) ! Penetratively entrained u [ m/s ]
843 0 : real(r8) vu_emf_out(mix,0:mkx) ! Penetratively entrained v [ m/s ]
844 0 : real(r8) uemf_out(mix,0:mkx) ! Net upward mass flux
845 : ! including penetrative entrainment (umf+emf) [ kg/m2/s ]
846 0 : real(r8) tru_out(mix,0:mkx,ncnst) ! Updraft tracers [ #, kg/kg ]
847 0 : real(r8) tru_emf_out(mix,0:mkx,ncnst) ! Penetratively entrained tracers [ #, kg/kg ]
848 :
849 0 : real(r8) wu_s(0:mkx) ! Same as above but for implicit CIN
850 0 : real(r8) qtu_s(0:mkx)
851 0 : real(r8) thlu_s(0:mkx)
852 0 : real(r8) thvu_s(0:mkx)
853 0 : real(r8) uu_s(0:mkx)
854 0 : real(r8) vu_s(0:mkx)
855 0 : real(r8) qtu_emf_s(0:mkx)
856 0 : real(r8) thlu_emf_s(0:mkx)
857 0 : real(r8) uu_emf_s(0:mkx)
858 0 : real(r8) vu_emf_s(0:mkx)
859 0 : real(r8) uemf_s(0:mkx)
860 0 : real(r8) tru_s(0:mkx,ncnst)
861 0 : real(r8) tru_emf_s(0:mkx,ncnst)
862 :
863 0 : real(r8) dwten_out(mix,mkx)
864 0 : real(r8) diten_out(mix,mkx)
865 0 : real(r8) flxrain_out(mix,0:mkx)
866 0 : real(r8) flxsnow_out(mix,0:mkx)
867 0 : real(r8) ntraprd_out(mix,mkx)
868 0 : real(r8) ntsnprd_out(mix,mkx)
869 :
870 0 : real(r8) dwten_s(mkx)
871 0 : real(r8) diten_s(mkx)
872 0 : real(r8) flxrain_s(0:mkx)
873 0 : real(r8) flxsnow_s(0:mkx)
874 0 : real(r8) ntraprd_s(mkx)
875 0 : real(r8) ntsnprd_s(mkx)
876 :
877 0 : real(r8) excessu_arr_out(mix,mkx)
878 0 : real(r8) excessu_arr(mkx)
879 0 : real(r8) excessu_arr_s(mkx)
880 0 : real(r8) excess0_arr_out(mix,mkx)
881 0 : real(r8) excess0_arr(mkx)
882 0 : real(r8) excess0_arr_s(mkx)
883 0 : real(r8) xc_arr_out(mix,mkx)
884 0 : real(r8) xc_arr(mkx)
885 0 : real(r8) xc_arr_s(mkx)
886 0 : real(r8) aquad_arr_out(mix,mkx)
887 0 : real(r8) aquad_arr(mkx)
888 0 : real(r8) aquad_arr_s(mkx)
889 0 : real(r8) bquad_arr_out(mix,mkx)
890 0 : real(r8) bquad_arr(mkx)
891 0 : real(r8) bquad_arr_s(mkx)
892 0 : real(r8) cquad_arr_out(mix,mkx)
893 0 : real(r8) cquad_arr(mkx)
894 0 : real(r8) cquad_arr_s(mkx)
895 0 : real(r8) bogbot_arr_out(mix,mkx)
896 0 : real(r8) bogbot_arr(mkx)
897 0 : real(r8) bogbot_arr_s(mkx)
898 0 : real(r8) bogtop_arr_out(mix,mkx)
899 0 : real(r8) bogtop_arr(mkx)
900 0 : real(r8) bogtop_arr_s(mkx)
901 :
902 0 : real(r8) exit_UWCu(mix)
903 0 : real(r8) exit_conden(mix)
904 0 : real(r8) exit_klclmkx(mix)
905 0 : real(r8) exit_klfcmkx(mix)
906 0 : real(r8) exit_ufrc(mix)
907 0 : real(r8) exit_wtw(mix)
908 0 : real(r8) exit_drycore(mix)
909 0 : real(r8) exit_wu(mix)
910 0 : real(r8) exit_cufilter(mix)
911 0 : real(r8) exit_kinv1(mix)
912 0 : real(r8) exit_rei(mix)
913 :
914 0 : real(r8) limit_shcu(mix)
915 0 : real(r8) limit_negcon(mix)
916 0 : real(r8) limit_ufrc(mix)
917 0 : real(r8) limit_ppen(mix)
918 0 : real(r8) limit_emf(mix)
919 0 : real(r8) limit_cinlcl(mix)
920 0 : real(r8) limit_cin(mix)
921 0 : real(r8) limit_cbmf(mix)
922 0 : real(r8) limit_rei(mix)
923 0 : real(r8) ind_delcin(mix)
924 :
925 : real(r8) :: ufrcinvbase_s, ufrclcl_s, winvbase_s, wlcl_s, plcl_s, pinv_s, plfc_s, &
926 : qtsrc_s, thlsrc_s, thvlsrc_s, emfkbup_s, cinlcl_s, pbup_s, ppen_s, cbmflimit_s, &
927 : tkeavg_s, zinv_s, rcwp_s, rlwp_s, riwp_s
928 : real(r8) :: ufrcinvbase, winvbase, pinv, zinv, emfkbup, cbmflimit, rho0rel
929 :
930 : !----- Variables for implicit CIN computation
931 :
932 0 : real(r8), dimension(mkx) :: qv0_s , ql0_s , qi0_s , s0_s , u0_s , &
933 0 : v0_s , t0_s , qt0_s , thl0_s , thvl0_s , qvten_s , &
934 0 : qlten_s, qiten_s , qrten_s , qsten_s , sten_s , evapc_s , &
935 0 : uten_s , vten_s , cufrc_s , qcu_s , qlu_s , qiu_s , &
936 0 : fer_s , fdr_s , qc_s , qtten_s , slten_s
937 0 : real(r8), dimension(0:mkx) :: umf_s , slflx_s , qtflx_s , ufrc_s , uflx_s , vflx_s
938 : real(r8) :: cush_s , precip_s, snow_s , cin_s , rliq_s, cbmf_s, cnt_s, cnb_s
939 : real(r8) :: cin_i,cin_f,del_CIN,ke,alpha,thlj
940 : real(r8) :: cinlcl_i,cinlcl_f,del_cinlcl
941 : integer :: iter
942 :
943 0 : real(r8), dimension(mkx,ncnst) :: tr0_s, trten_s
944 0 : real(r8), dimension(0:mkx,ncnst) :: trflx_s
945 :
946 : !----- Variables for temporary storages
947 :
948 0 : real(r8), dimension(mkx) :: qv0_o, ql0_o, qi0_o, t0_o, s0_o, u0_o, v0_o
949 0 : real(r8), dimension(mkx) :: qt0_o , thl0_o , thvl0_o , &
950 : qvten_o , qlten_o , qiten_o , qrten_o , qsten_o , &
951 : sten_o , uten_o , vten_o , qcu_o , qlu_o , &
952 : qiu_o , cufrc_o , evapc_o , &
953 0 : thv0bot_o, thv0top_o, thvl0bot_o, thvl0top_o, &
954 0 : ssthl0_o , ssqt0_o , ssu0_o , ssv0_o , qc_o , &
955 : qtten_o , slten_o
956 : real(r8), dimension(0:mkx) :: umf_o , slflx_o , qtflx_o , ufrc_o
957 : real(r8), dimension(mix) :: cush_o , precip_o , snow_o , rliq_o, cbmf_o, cnt_o, cnb_o
958 : real(r8), dimension(0:mkx) :: uflx_o , vflx_o
959 : real(r8) :: tkeavg_o , thvlmin_o, qtsrc_o , thvlsrc_o, thlsrc_o , &
960 : usrc_o , vsrc_o , plcl_o , plfc_o , &
961 : thv0lcl_o, cinlcl_o
962 : integer :: kinv_o , klcl_o , klfc_o
963 :
964 0 : real(r8), dimension(mkx,ncnst) :: tr0_o
965 0 : real(r8), dimension(mkx,ncnst) :: trten_o, sstr0_o
966 : real(r8), dimension(0:mkx,ncnst) :: trflx_o
967 0 : real(r8), dimension(ncnst) :: trsrc_o
968 : integer :: ixnumliq, ixnumice, ixcldliq, ixcldice
969 :
970 : ! ------------------ !
971 : ! !
972 : ! Define Parameters !
973 : ! !
974 : ! ------------------ !
975 :
976 : ! ------------------------ !
977 : ! Iterative xc calculation !
978 : ! ------------------------ !
979 :
980 : integer , parameter :: niter_xc = 2
981 :
982 : ! ----------------------------------------------------------- !
983 : ! Choice of 'CIN = cin' (.true.) or 'CIN = cinlcl' (.false.). !
984 : ! !
985 : ! Feb 2007, Bundy: Note that use_CINcin = .false. will try to !
986 : ! use a variable (del_cinlcl) that is not currently set !
987 : ! !
988 : ! Sept 2012, Santos: The fact that this is still true over 5 !
989 : ! years later suggests that this option needs to be !
990 : ! fixed or abandoned. !
991 : ! ----------------------------------------------------------- !
992 :
993 : logical , parameter :: use_CINcin = .true.
994 :
995 : ! --------------------------------------------------------------- !
996 : ! Choice of 'explicit' ( 1 ) or 'implicit' ( 2 ) CIN. !
997 : ! !
998 : ! When choose 'CIN = cinlcl' above, it is recommended not to use !
999 : ! implicit CIN, i.e., do 'NOT' choose simultaneously : !
1000 : ! [ 'use_CINcin=.false. & 'iter_cin=2' ] !
1001 : ! since 'cinlcl' will be always set to zero whenever LCL is below !
1002 : ! the PBL top interface in the current code. So, averaging cinlcl !
1003 : ! of two iter_cin steps is likely not so good. Except that, all !
1004 : ! the other combinations of 'use_CINcin' & 'iter_cin' are OK. !
1005 : ! --------------------------------------------------------------- !
1006 :
1007 : integer , parameter :: iter_cin = 2
1008 :
1009 : ! ---------------------------------------------------------------- !
1010 : ! Choice of 'self-detrainment' by negative buoyancy in calculating !
1011 : ! cumulus updraft mass flux at the top interface in each layer. !
1012 : ! ---------------------------------------------------------------- !
1013 :
1014 : logical , parameter :: use_self_detrain = .false.
1015 :
1016 : ! --------------------------------------------------------- !
1017 : ! Cumulus momentum flux : turn-on (.true.) or off (.false.) !
1018 : ! --------------------------------------------------------- !
1019 :
1020 : logical , parameter :: use_momenflx = .true.
1021 :
1022 : ! ----------------------------------------------------------------------------------------- !
1023 : ! Penetrative Entrainment : Cumulative ( .true. , original ) or Non-Cumulative ( .false. ) !
1024 : ! This option ( .false. ) is designed to reduce the sensitivity to the vertical resolution. !
1025 : ! ----------------------------------------------------------------------------------------- !
1026 :
1027 : logical , parameter :: use_cumpenent = .true.
1028 :
1029 : ! --------------------------------------------------------------------------------------------------------------- !
1030 : ! Computation of the grid-mean condensate tendency. !
1031 : ! use_expconten = .true. : explcitly compute tendency by condensate detrainment and compensating subsidence !
1032 : ! use_expconten = .false. : use the original proportional condensate tendency equation. ( original ) !
1033 : ! --------------------------------------------------------------------------------------------------------------- !
1034 :
1035 : logical , parameter :: use_expconten = .true.
1036 :
1037 : ! --------------------------------------------------------------------------------------------------------------- !
1038 : ! Treatment of reserved condensate !
1039 : ! use_unicondet = .true. : detrain condensate uniformly over the environment ( original ) !
1040 : ! use_unicondet = .false. : detrain condensate into the pre-existing stratus !
1041 : ! --------------------------------------------------------------------------------------------------------------- !
1042 :
1043 : logical , parameter :: use_unicondet = .false.
1044 :
1045 : ! ----------------------- !
1046 : ! For lateral entrainment !
1047 : ! ----------------------- !
1048 :
1049 : parameter (rle = 0.1_r8) ! For critical stopping distance for lateral entrainment [no unit]
1050 : ! parameter (rkm = 16.0_r8) ! Determine the amount of air that is involved in buoyancy-sorting [no unit]
1051 : parameter (rkm = 14.0_r8) ! Determine the amount of air that is involved in buoyancy-sorting [no unit]
1052 :
1053 : parameter (rkfre = 1.0_r8) ! Vertical velocity variance as fraction of tke.
1054 : parameter (rmaxfrac = 0.10_r8) ! Maximum allowable 'core' updraft fraction
1055 : parameter (mumin1 = 0.906_r8) ! Normalized CIN ('mu') corresponding to 'rmaxfrac' at the PBL top
1056 : ! obtaind by inverting 'rmaxfrac = 0.5*erfc(mumin1)'.
1057 : ! [rmaxfrac:mumin1]=[ 0.05:1.163, 0.075:1.018, 0.1:0.906, 0.15:0.733, 0.2:0.595, 0.25:0.477]
1058 : parameter (rbuoy = 1.0_r8) ! For nonhydrostatic pressure effects on updraft [no unit]
1059 : parameter (rdrag = 1.0_r8) ! Drag coefficient [no unit]
1060 :
1061 : parameter (epsvarw = 5.e-4_r8) ! Variance of w at PBL top by meso-scale component [m2/s2]
1062 : parameter (PGFc = 0.7_r8) ! This is used for calculating vertical variations cumulus
1063 : ! 'u' & 'v' by horizontal PGF during upward motion [no unit]
1064 :
1065 : ! ---------------------------------------- !
1066 : ! Bulk microphysics controlling parameters !
1067 : ! --------------------------------------------------------------------------- !
1068 : ! criqc : Maximum condensate that can be hold by cumulus updraft [kg/kg] !
1069 : ! frc_rasn : Fraction of precipitable condensate in the expelled cloud water !
1070 : ! from cumulus updraft. The remaining fraction ('1-frc_rasn') is !
1071 : ! 'suspended condensate'. !
1072 : ! 0 : all expelled condensate is 'suspended condensate' !
1073 : ! 1 : all expelled condensate is 'precipitable condensate' !
1074 : ! kevp : Evaporative efficiency !
1075 : ! noevap_krelkpen : No evaporation from 'krel' to 'kpen' layers !
1076 : ! --------------------------------------------------------------------------- !
1077 :
1078 : parameter ( criqc = 0.7e-3_r8 )
1079 : parameter ( frc_rasn = 1.0_r8 )
1080 : parameter ( kevp = 2.e-6_r8 )
1081 : logical, parameter :: noevap_krelkpen = .false.
1082 :
1083 : !------------------------!
1084 : ! !
1085 : ! Start Main Calculation !
1086 : ! !
1087 : !------------------------!
1088 :
1089 0 : call cnst_get_ind( 'NUMLIQ', ixnumliq )
1090 0 : call cnst_get_ind( 'NUMICE', ixnumice )
1091 :
1092 0 : call cnst_get_ind( 'CLDLIQ', ixcldliq )
1093 0 : call cnst_get_ind( 'CLDICE', ixcldice )
1094 :
1095 :
1096 :
1097 :
1098 : ! ------------------------------------------------------- !
1099 : ! Initialize output variables defined for all grid points !
1100 : ! ------------------------------------------------------- !
1101 :
1102 0 : umf_out(:iend,0:mkx) = 0.0_r8
1103 0 : slflx_out(:iend,0:mkx) = 0.0_r8
1104 0 : qtflx_out(:iend,0:mkx) = 0.0_r8
1105 0 : flxprc1_out(:iend,0:mkx) = 0.0_r8
1106 0 : flxsnow1_out(:iend,0:mkx) = 0.0_r8
1107 0 : qvten_out(:iend,:mkx) = 0.0_r8
1108 0 : qlten_out(:iend,:mkx) = 0.0_r8
1109 0 : qiten_out(:iend,:mkx) = 0.0_r8
1110 0 : sten_out(:iend,:mkx) = 0.0_r8
1111 0 : uten_out(:iend,:mkx) = 0.0_r8
1112 0 : vten_out(:iend,:mkx) = 0.0_r8
1113 0 : qrten_out(:iend,:mkx) = 0.0_r8
1114 0 : qsten_out(:iend,:mkx) = 0.0_r8
1115 0 : precip_out(:iend) = 0.0_r8
1116 0 : snow_out(:iend) = 0.0_r8
1117 0 : evapc_out(:iend,:mkx) = 0.0_r8
1118 0 : cufrc_out(:iend,:mkx) = 0.0_r8
1119 0 : qcu_out(:iend,:mkx) = 0.0_r8
1120 0 : qlu_out(:iend,:mkx) = 0.0_r8
1121 0 : qiu_out(:iend,:mkx) = 0.0_r8
1122 0 : fer_out(:iend,:mkx) = 0.0_r8
1123 0 : fdr_out(:iend,:mkx) = 0.0_r8
1124 0 : cinh_out(:iend) = -1.0_r8
1125 0 : cinlclh_out(:iend) = -1.0_r8
1126 0 : cbmf_out(:iend) = 0.0_r8
1127 0 : qc_out(:iend,:mkx) = 0.0_r8
1128 0 : rliq_out(:iend) = 0.0_r8
1129 0 : cnt_out(:iend) = real(mkx, r8)
1130 0 : cnb_out(:iend) = 0.0_r8
1131 0 : qtten_out(:iend,:mkx) = 0.0_r8
1132 0 : slten_out(:iend,:mkx) = 0.0_r8
1133 0 : ufrc_out(:iend,0:mkx) = 0.0_r8
1134 :
1135 0 : uflx_out(:iend,0:mkx) = 0.0_r8
1136 0 : vflx_out(:iend,0:mkx) = 0.0_r8
1137 :
1138 0 : trten_out(:iend,:mkx,:ncnst) = 0.0_r8
1139 0 : trflx_out(:iend,0:mkx,:ncnst)= 0.0_r8
1140 :
1141 0 : ufrcinvbase_out(:iend) = 0.0_r8
1142 0 : ufrclcl_out(:iend) = 0.0_r8
1143 0 : winvbase_out(:iend) = 0.0_r8
1144 0 : wlcl_out(:iend) = 0.0_r8
1145 0 : plcl_out(:iend) = 0.0_r8
1146 0 : pinv_out(:iend) = 0.0_r8
1147 0 : plfc_out(:iend) = 0.0_r8
1148 0 : pbup_out(:iend) = 0.0_r8
1149 0 : ppen_out(:iend) = 0.0_r8
1150 0 : qtsrc_out(:iend) = 0.0_r8
1151 0 : thlsrc_out(:iend) = 0.0_r8
1152 0 : thvlsrc_out(:iend) = 0.0_r8
1153 0 : emfkbup_out(:iend) = 0.0_r8
1154 0 : cbmflimit_out(:iend) = 0.0_r8
1155 0 : tkeavg_out(:iend) = 0.0_r8
1156 0 : zinv_out(:iend) = 0.0_r8
1157 0 : rcwp_out(:iend) = 0.0_r8
1158 0 : rlwp_out(:iend) = 0.0_r8
1159 0 : riwp_out(:iend) = 0.0_r8
1160 :
1161 0 : wu_out(:iend,0:mkx) = 0.0_r8
1162 0 : qtu_out(:iend,0:mkx) = 0.0_r8
1163 0 : thlu_out(:iend,0:mkx) = 0.0_r8
1164 0 : thvu_out(:iend,0:mkx) = 0.0_r8
1165 0 : uu_out(:iend,0:mkx) = 0.0_r8
1166 0 : vu_out(:iend,0:mkx) = 0.0_r8
1167 0 : qtu_emf_out(:iend,0:mkx) = 0.0_r8
1168 0 : thlu_emf_out(:iend,0:mkx) = 0.0_r8
1169 0 : uu_emf_out(:iend,0:mkx) = 0.0_r8
1170 0 : vu_emf_out(:iend,0:mkx) = 0.0_r8
1171 0 : uemf_out(:iend,0:mkx) = 0.0_r8
1172 :
1173 0 : tru_out(:iend,0:mkx,:ncnst) = 0.0_r8
1174 0 : tru_emf_out(:iend,0:mkx,:ncnst) = 0.0_r8
1175 :
1176 0 : dwten_out(:iend,:mkx) = 0.0_r8
1177 0 : diten_out(:iend,:mkx) = 0.0_r8
1178 0 : flxrain_out(:iend,0:mkx) = 0.0_r8
1179 0 : flxsnow_out(:iend,0:mkx) = 0.0_r8
1180 0 : ntraprd_out(:iend,mkx) = 0.0_r8
1181 0 : ntsnprd_out(:iend,mkx) = 0.0_r8
1182 :
1183 0 : excessu_arr_out(:iend,:mkx) = 0.0_r8
1184 0 : excess0_arr_out(:iend,:mkx) = 0.0_r8
1185 0 : xc_arr_out(:iend,:mkx) = 0.0_r8
1186 0 : aquad_arr_out(:iend,:mkx) = 0.0_r8
1187 0 : bquad_arr_out(:iend,:mkx) = 0.0_r8
1188 0 : cquad_arr_out(:iend,:mkx) = 0.0_r8
1189 0 : bogbot_arr_out(:iend,:mkx) = 0.0_r8
1190 0 : bogtop_arr_out(:iend,:mkx) = 0.0_r8
1191 :
1192 0 : exit_UWCu(:iend) = 0.0_r8
1193 0 : exit_conden(:iend) = 0.0_r8
1194 0 : exit_klclmkx(:iend) = 0.0_r8
1195 0 : exit_klfcmkx(:iend) = 0.0_r8
1196 0 : exit_ufrc(:iend) = 0.0_r8
1197 0 : exit_wtw(:iend) = 0.0_r8
1198 0 : exit_drycore(:iend) = 0.0_r8
1199 0 : exit_wu(:iend) = 0.0_r8
1200 0 : exit_cufilter(:iend) = 0.0_r8
1201 0 : exit_kinv1(:iend) = 0.0_r8
1202 0 : exit_rei(:iend) = 0.0_r8
1203 :
1204 0 : limit_shcu(:iend) = 0.0_r8
1205 0 : limit_negcon(:iend) = 0.0_r8
1206 0 : limit_ufrc(:iend) = 0.0_r8
1207 0 : limit_ppen(:iend) = 0.0_r8
1208 0 : limit_emf(:iend) = 0.0_r8
1209 0 : limit_cinlcl(:iend) = 0.0_r8
1210 0 : limit_cin(:iend) = 0.0_r8
1211 0 : limit_cbmf(:iend) = 0.0_r8
1212 0 : limit_rei(:iend) = 0.0_r8
1213 :
1214 0 : ind_delcin(:iend) = 0.0_r8
1215 :
1216 : !--------------------------------------------------------------!
1217 : ! !
1218 : ! Start the column i loop where i is a horizontal column index !
1219 : ! !
1220 : !--------------------------------------------------------------!
1221 :
1222 : ! Compute wet-bulb temperature and specific humidity
1223 : ! for treating evaporation of precipitation.
1224 :
1225 : ! "True" means ice will be taken into account
1226 0 : do k = 1, mkx
1227 : call findsp_vc(qv0_in(:iend,k), t0_in(:iend,k), p0_in(:iend,k), .true., &
1228 0 : tw0_in(:iend,k), qw0_in(:iend,k))
1229 : end do
1230 :
1231 0 : do i = 1, iend
1232 :
1233 0 : id_exit = .false.
1234 :
1235 : ! -------------------------------------------- !
1236 : ! Define 1D input variables at each grid point !
1237 : ! -------------------------------------------- !
1238 :
1239 0 : ps0(0:mkx) = ps0_in(i,0:mkx)
1240 0 : zs0(0:mkx) = zs0_in(i,0:mkx)
1241 0 : p0(:mkx) = p0_in(i,:mkx)
1242 0 : z0(:mkx) = z0_in(i,:mkx)
1243 0 : dp0(:mkx) = dp0_in(i,:mkx)
1244 0 : dpdry0(:mkx) = dpdry0_in(i,:mkx)
1245 0 : u0(:mkx) = u0_in(i,:mkx)
1246 0 : v0(:mkx) = v0_in(i,:mkx)
1247 0 : qv0(:mkx) = qv0_in(i,:mkx)
1248 0 : ql0(:mkx) = ql0_in(i,:mkx)
1249 0 : qi0(:mkx) = qi0_in(i,:mkx)
1250 0 : t0(:mkx) = t0_in(i,:mkx)
1251 0 : s0(:mkx) = s0_in(i,:mkx)
1252 0 : tke(0:mkx) = tke_in(i,0:mkx)
1253 0 : cldfrct(:mkx) = cldfrct_in(i,:mkx)
1254 0 : concldfrct(:mkx) = concldfrct_in(i,:mkx)
1255 0 : pblh = pblh_in(i)
1256 0 : cush = cush_inout(i)
1257 0 : do m = 1, ncnst
1258 0 : tr0(:mkx,m) = tr0_in(i,:mkx,m)
1259 : enddo
1260 :
1261 : ! --------------------------------------------------------- !
1262 : ! Compute other basic thermodynamic variables directly from !
1263 : ! the input variables at each grid point !
1264 : ! --------------------------------------------------------- !
1265 :
1266 : !----- 1. Compute internal environmental variables
1267 :
1268 0 : exn0(:mkx) = (p0(:mkx)/p00)**rovcp
1269 0 : exns0(0:mkx) = (ps0(0:mkx)/p00)**rovcp
1270 0 : qt0(:mkx) = (qv0(:mkx) + ql0(:mkx) + qi0(:mkx))
1271 0 : thl0(:mkx) = (t0(:mkx) - xlv*ql0(:mkx)/cp - xls*qi0(:mkx)/cp)/exn0(:mkx)
1272 0 : thvl0(:mkx) = (1._r8 + zvir*qt0(:mkx))*thl0(:mkx)
1273 :
1274 : !----- 2. Compute slopes of environmental variables in each layer
1275 : ! Dimension of ssthl0(:mkx) is implicit.
1276 :
1277 0 : ssthl0 = slope(mkx,thl0,p0)
1278 0 : ssqt0 = slope(mkx,qt0 ,p0)
1279 0 : ssu0 = slope(mkx,u0 ,p0)
1280 0 : ssv0 = slope(mkx,v0 ,p0)
1281 0 : do m = 1, ncnst
1282 0 : sstr0(:mkx,m) = slope(mkx,tr0(:mkx,m),p0)
1283 : enddo
1284 :
1285 : !----- 3. Compute "thv0" and "thvl0" at the top/bottom interfaces in each layer
1286 : ! There are computed from the reconstructed thl, qt at the top/bottom.
1287 :
1288 0 : do k = 1, mkx
1289 :
1290 0 : thl0bot = thl0(k) + ssthl0(k)*(ps0(k-1) - p0(k))
1291 0 : qt0bot = qt0(k) + ssqt0(k) *(ps0(k-1) - p0(k))
1292 0 : call conden(ps0(k-1),thl0bot,qt0bot,thj,qvj,qlj,qij,qse,id_check)
1293 0 : if( id_check .eq. 1 ) then
1294 0 : exit_conden(i) = 1._r8
1295 0 : id_exit = .true.
1296 0 : go to 333
1297 : end if
1298 0 : thv0bot(k) = thj*(1._r8 + zvir*qvj - qlj - qij)
1299 0 : thvl0bot(k) = thl0bot*(1._r8 + zvir*qt0bot)
1300 :
1301 0 : thl0top = thl0(k) + ssthl0(k)*(ps0(k) - p0(k))
1302 0 : qt0top = qt0(k) + ssqt0(k) *(ps0(k) - p0(k))
1303 0 : call conden(ps0(k),thl0top,qt0top,thj,qvj,qlj,qij,qse,id_check)
1304 0 : if( id_check .eq. 1 ) then
1305 0 : exit_conden(i) = 1._r8
1306 0 : id_exit = .true.
1307 0 : go to 333
1308 : end if
1309 0 : thv0top(k) = thj*(1._r8 + zvir*qvj - qlj - qij)
1310 0 : thvl0top(k) = thl0top*(1._r8 + zvir*qt0top)
1311 :
1312 : end do
1313 :
1314 : ! ------------------------------------------------------------ !
1315 : ! Save input and related environmental thermodynamic variables !
1316 : ! for use at "iter_cin=2" when "del_CIN >= 0" !
1317 : ! ------------------------------------------------------------ !
1318 :
1319 0 : qv0_o(:mkx) = qv0(:mkx)
1320 0 : ql0_o(:mkx) = ql0(:mkx)
1321 0 : qi0_o(:mkx) = qi0(:mkx)
1322 0 : t0_o(:mkx) = t0(:mkx)
1323 0 : s0_o(:mkx) = s0(:mkx)
1324 0 : u0_o(:mkx) = u0(:mkx)
1325 0 : v0_o(:mkx) = v0(:mkx)
1326 0 : qt0_o(:mkx) = qt0(:mkx)
1327 0 : thl0_o(:mkx) = thl0(:mkx)
1328 0 : thvl0_o(:mkx) = thvl0(:mkx)
1329 0 : ssthl0_o(:mkx) = ssthl0(:mkx)
1330 0 : ssqt0_o(:mkx) = ssqt0(:mkx)
1331 0 : thv0bot_o(:mkx) = thv0bot(:mkx)
1332 0 : thv0top_o(:mkx) = thv0top(:mkx)
1333 0 : thvl0bot_o(:mkx) = thvl0bot(:mkx)
1334 0 : thvl0top_o(:mkx) = thvl0top(:mkx)
1335 0 : ssu0_o(:mkx) = ssu0(:mkx)
1336 0 : ssv0_o(:mkx) = ssv0(:mkx)
1337 0 : do m = 1, ncnst
1338 0 : tr0_o(:mkx,m) = tr0(:mkx,m)
1339 0 : sstr0_o(:mkx,m) = sstr0(:mkx,m)
1340 : enddo
1341 :
1342 : ! ---------------------------------------------- !
1343 : ! Initialize output variables at each grid point !
1344 : ! ---------------------------------------------- !
1345 :
1346 0 : umf(0:mkx) = 0.0_r8
1347 0 : emf(0:mkx) = 0.0_r8
1348 0 : slflx(0:mkx) = 0.0_r8
1349 0 : qtflx(0:mkx) = 0.0_r8
1350 0 : uflx(0:mkx) = 0.0_r8
1351 0 : vflx(0:mkx) = 0.0_r8
1352 0 : qvten(:mkx) = 0.0_r8
1353 0 : qlten(:mkx) = 0.0_r8
1354 0 : qiten(:mkx) = 0.0_r8
1355 0 : sten(:mkx) = 0.0_r8
1356 0 : uten(:mkx) = 0.0_r8
1357 0 : vten(:mkx) = 0.0_r8
1358 0 : qrten(:mkx) = 0.0_r8
1359 0 : qsten(:mkx) = 0.0_r8
1360 0 : dwten(:mkx) = 0.0_r8
1361 0 : diten(:mkx) = 0.0_r8
1362 0 : precip = 0.0_r8
1363 0 : snow = 0.0_r8
1364 0 : evapc(:mkx) = 0.0_r8
1365 0 : cufrc(:mkx) = 0.0_r8
1366 0 : qcu(:mkx) = 0.0_r8
1367 0 : qlu(:mkx) = 0.0_r8
1368 0 : qiu(:mkx) = 0.0_r8
1369 0 : fer(:mkx) = 0.0_r8
1370 0 : fdr(:mkx) = 0.0_r8
1371 0 : cin = 0.0_r8
1372 0 : cbmf = 0.0_r8
1373 0 : qc(:mkx) = 0.0_r8
1374 0 : qc_l(:mkx) = 0.0_r8
1375 0 : qc_i(:mkx) = 0.0_r8
1376 0 : rliq = 0.0_r8
1377 0 : cnt = real(mkx, r8)
1378 0 : cnb = 0.0_r8
1379 0 : qtten(:mkx) = 0.0_r8
1380 0 : slten(:mkx) = 0.0_r8
1381 0 : ufrc(0:mkx) = 0.0_r8
1382 :
1383 0 : thlu(0:mkx) = 0.0_r8
1384 0 : qtu(0:mkx) = 0.0_r8
1385 0 : uu(0:mkx) = 0.0_r8
1386 0 : vu(0:mkx) = 0.0_r8
1387 0 : wu(0:mkx) = 0.0_r8
1388 0 : thvu(0:mkx) = 0.0_r8
1389 0 : thlu_emf(0:mkx) = 0.0_r8
1390 0 : qtu_emf(0:mkx) = 0.0_r8
1391 0 : uu_emf(0:mkx) = 0.0_r8
1392 0 : vu_emf(0:mkx) = 0.0_r8
1393 :
1394 0 : ufrcinvbase = 0.0_r8
1395 0 : ufrclcl = 0.0_r8
1396 0 : winvbase = 0.0_r8
1397 0 : wlcl = 0.0_r8
1398 : emfkbup = 0.0_r8
1399 0 : cbmflimit = 0.0_r8
1400 0 : excessu_arr(:mkx) = 0.0_r8
1401 0 : excess0_arr(:mkx) = 0.0_r8
1402 0 : xc_arr(:mkx) = 0.0_r8
1403 0 : aquad_arr(:mkx) = 0.0_r8
1404 0 : bquad_arr(:mkx) = 0.0_r8
1405 0 : cquad_arr(:mkx) = 0.0_r8
1406 0 : bogbot_arr(:mkx) = 0.0_r8
1407 0 : bogtop_arr(:mkx) = 0.0_r8
1408 :
1409 0 : uemf(0:mkx) = 0.0_r8
1410 0 : comsub(:mkx) = 0.0_r8
1411 0 : qlten_sink(:mkx) = 0.0_r8
1412 0 : qiten_sink(:mkx) = 0.0_r8
1413 0 : nlten_sink(:mkx) = 0.0_r8
1414 0 : niten_sink(:mkx) = 0.0_r8
1415 :
1416 0 : do m = 1, ncnst
1417 0 : trflx(0:mkx,m) = 0.0_r8
1418 0 : trten(:mkx,m) = 0.0_r8
1419 0 : tru(0:mkx,m) = 0.0_r8
1420 0 : tru_emf(0:mkx,m) = 0.0_r8
1421 : enddo
1422 :
1423 : !-----------------------------------------------!
1424 : ! Below 'iter' loop is for implicit CIN closure !
1425 : !-----------------------------------------------!
1426 :
1427 : ! ----------------------------------------------------------------------------- !
1428 : ! It is important to note that this iterative cin loop is located at the outest !
1429 : ! shell of the code. Thus, source air properties can also be changed during the !
1430 : ! iterative cin calculation, because cumulus convection induces non-zero fluxes !
1431 : ! even at interfaces below PBL top height through 'fluxbelowinv' subroutine. !
1432 : ! ----------------------------------------------------------------------------- !
1433 :
1434 0 : do iter = 1, iter_cin
1435 :
1436 : ! ---------------------------------------------------------------------- !
1437 : ! Cumulus scale height !
1438 : ! In contrast to the premitive code, cumulus scale height is iteratively !
1439 : ! calculated at each time step, and at each iterative cin step. !
1440 : ! It is not clear whether I should locate below two lines within or out !
1441 : ! of the iterative cin loop. !
1442 : ! ---------------------------------------------------------------------- !
1443 :
1444 0 : tscaleh = cush
1445 0 : cush = -1._r8
1446 :
1447 : ! ----------------------------------------------------------------------- !
1448 : ! Find PBL top height interface index, 'kinv-1' where 'kinv' is the layer !
1449 : ! index with PBLH in it. When PBLH is exactly at interface, 'kinv' is the !
1450 : ! layer index having PBLH as a lower interface. !
1451 : ! In the previous code, I set the lower limit of 'kinv' by 2 in order to !
1452 : ! be consistent with the other parts of the code. However in the modified !
1453 : ! code, I allowed 'kinv' to be 1 & if 'kinv = 1', I just exit the program !
1454 : ! without performing cumulus convection. This new approach seems to be !
1455 : ! more reasonable: if PBL height is within 'kinv=1' layer, surface is STL !
1456 : ! interface (bflxs <= 0) and interface just above the surface should be !
1457 : ! either non-turbulent (Ri>0.19) or stably turbulent (0<=Ri<0.19 but this !
1458 : ! interface is identified as a base external interface of upperlying CL. !
1459 : ! Thus, when 'kinv=1', PBL scheme guarantees 'bflxs <= 0'. For this case !
1460 : ! it is reasonable to assume that cumulus convection does not happen. !
1461 : ! When these is SBCL, PBL height from the PBL scheme is likely to be very !
1462 : ! close at 'kinv-1' interface, but not exactly, since 'zi' information is !
1463 : ! changed between two model time steps. In order to ensure correct identi !
1464 : ! fication of 'kinv' for general case including SBCL, I imposed an offset !
1465 : ! of 5 [m] in the below 'kinv' finding block. !
1466 : ! ----------------------------------------------------------------------- !
1467 :
1468 0 : do k = mkx - 1, 1, -1
1469 0 : if( (pblh + 5._r8 - zs0(k))*(pblh + 5._r8 - zs0(k+1)) .lt. 0._r8 ) then
1470 0 : kinv = k + 1
1471 0 : go to 15
1472 : endif
1473 : end do
1474 0 : kinv = 1
1475 : 15 continue
1476 :
1477 0 : if( kinv .le. 1 ) then
1478 0 : exit_kinv1(i) = 1._r8
1479 0 : id_exit = .true.
1480 0 : go to 333
1481 : endif
1482 : ! From here, it must be 'kinv >= 2'.
1483 :
1484 : ! -------------------------------------------------------------------------- !
1485 : ! Find PBL averaged tke ('tkeavg') and minimum 'thvl' ('thvlmin') in the PBL !
1486 : ! In the current code, 'tkeavg' is obtained by averaging all interfacial TKE !
1487 : ! within the PBL. However, in order to be conceptually consistent with PBL !
1488 : ! scheme, 'tkeavg' should be calculated by considering surface buoyancy flux.!
1489 : ! If surface buoyancy flux is positive ( bflxs >0 ), surface interfacial TKE !
1490 : ! should be included in calculating 'tkeavg', while if bflxs <= 0, surface !
1491 : ! interfacial TKE should not be included in calculating 'tkeavg'. I should !
1492 : ! modify the code when 'bflxs' is available as an input of cumulus scheme. !
1493 : ! 'thvlmin' is a minimum 'thvl' within PBL obtained by comparing top & base !
1494 : ! interface values of 'thvl' in each layers within the PBL. !
1495 : ! -------------------------------------------------------------------------- !
1496 :
1497 : dpsum = 0._r8
1498 : tkeavg = 0._r8
1499 : thvlmin = 1000._r8
1500 0 : do k = 0, kinv - 1 ! Here, 'k' is an interfacial layer index.
1501 0 : if( k .eq. 0 ) then
1502 0 : dpi = ps0(0) - p0(1)
1503 0 : elseif( k .eq. (kinv-1) ) then
1504 0 : dpi = p0(kinv-1) - ps0(kinv-1)
1505 : else
1506 0 : dpi = p0(k) - p0(k+1)
1507 : endif
1508 0 : dpsum = dpsum + dpi
1509 0 : tkeavg = tkeavg + dpi*tke(k)
1510 0 : if( k .ne. 0 ) thvlmin = min(thvlmin,min(thvl0bot(k),thvl0top(k)))
1511 : end do
1512 0 : tkeavg = tkeavg/dpsum
1513 :
1514 : ! ------------------------------------------------------------------ !
1515 : ! Find characteristics of cumulus source air: qtsrc,thlsrc,usrc,vsrc !
1516 : ! Note that 'thlsrc' was con-cocked using 'thvlsrc' and 'qtsrc'. !
1517 : ! 'qtsrc' is defined as the lowest layer mid-point value; 'thlsrc' !
1518 : ! is from 'qtsrc' and 'thvlmin=thvlsrc'; 'usrc' & 'vsrc' are defined !
1519 : ! as the values just below the PBL top interface. !
1520 : ! ------------------------------------------------------------------ !
1521 :
1522 0 : qtsrc = qt0(1)
1523 0 : thvlsrc = thvlmin
1524 0 : thlsrc = thvlsrc / ( 1._r8 + zvir * qtsrc )
1525 0 : usrc = u0(kinv-1) + ssu0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )
1526 0 : vsrc = v0(kinv-1) + ssv0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )
1527 0 : do m = 1, ncnst
1528 0 : trsrc(m) = tr0(1,m)
1529 : enddo
1530 :
1531 : ! ------------------------------------------------------------------ !
1532 : ! Find LCL of the source air and a layer index containing LCL (klcl) !
1533 : ! When the LCL is exactly at the interface, 'klcl' is a layer index !
1534 : ! having 'plcl' as the lower interface similar to the 'kinv' case. !
1535 : ! In the previous code, I assumed that if LCL is located within the !
1536 : ! lowest model layer ( 1 ) or the top model layer ( mkx ), then no !
1537 : ! convective adjustment is performed and just exited. However, in !
1538 : ! the revised code, I relaxed the first constraint and even though !
1539 : ! LCL is at the lowest model layer, I allowed cumulus convection to !
1540 : ! be initiated. For this case, cumulus convection should be started !
1541 : ! from the PBL top height, as shown in the following code. !
1542 : ! When source air is already saturated even at the surface, klcl is !
1543 : ! set to 1. !
1544 : ! ------------------------------------------------------------------ !
1545 :
1546 0 : plcl = qsinvert(qtsrc,thlsrc,ps0(0))
1547 0 : do k = 0, mkx
1548 0 : if( ps0(k) .lt. plcl ) then
1549 : klcl = k
1550 : go to 25
1551 : endif
1552 : end do
1553 : klcl = mkx
1554 : 25 continue
1555 0 : klcl = max(1,klcl)
1556 :
1557 0 : if( plcl .lt. 30000._r8 ) then
1558 : ! if( klcl .eq. mkx ) then
1559 0 : exit_klclmkx(i) = 1._r8
1560 0 : id_exit = .true.
1561 0 : go to 333
1562 : endif
1563 :
1564 : ! ------------------------------------------------------------- !
1565 : ! Calculate environmental virtual potential temperature at LCL, !
1566 : !'thv0lcl' which is solely used in the 'cin' calculation. Note !
1567 : ! that 'thv0lcl' is calculated first by calculating 'thl0lcl' !
1568 : ! and 'qt0lcl' at the LCL, and performing 'conden' afterward, !
1569 : ! in fully consistent with the other parts of the code. !
1570 : ! ------------------------------------------------------------- !
1571 :
1572 0 : thl0lcl = thl0(klcl) + ssthl0(klcl) * ( plcl - p0(klcl) )
1573 0 : qt0lcl = qt0(klcl) + ssqt0(klcl) * ( plcl - p0(klcl) )
1574 0 : call conden(plcl,thl0lcl,qt0lcl,thj,qvj,qlj,qij,qse,id_check)
1575 0 : if( id_check .eq. 1 ) then
1576 0 : exit_conden(i) = 1._r8
1577 0 : id_exit = .true.
1578 0 : go to 333
1579 : end if
1580 0 : thv0lcl = thj * ( 1._r8 + zvir * qvj - qlj - qij )
1581 :
1582 : ! ------------------------------------------------------------------------ !
1583 : ! Compute Convective Inhibition, 'cin' & 'cinlcl' [J/kg]=[m2/s2] TKE unit. !
1584 : ! !
1585 : ! 'cin' (cinlcl) is computed from the PBL top interface to LFC (LCL) using !
1586 : ! piecewisely reconstructed environmental profiles, assuming environmental !
1587 : ! buoyancy profile within each layer ( or from LCL to upper interface in !
1588 : ! each layer ) is simply a linear profile. For the purpose of cin (cinlcl) !
1589 : ! calculation, we simply assume that lateral entrainment does not occur in !
1590 : ! updrafting cumulus plume, i.e., cumulus source air property is conserved.!
1591 : ! Below explains some rules used in the calculations of cin (cinlcl). In !
1592 : ! general, both 'cin' and 'cinlcl' are calculated from a PBL top interface !
1593 : ! to LCL and LFC, respectively : !
1594 : ! 1. If LCL is lower than the PBL height, cinlcl = 0 and cin is calculated !
1595 : ! from PBL height to LFC. !
1596 : ! 2. If LCL is higher than PBL height, 'cinlcl' is calculated by summing !
1597 : ! both positive and negative cloud buoyancy up to LCL using 'single_cin'!
1598 : ! From the LCL to LFC, however, only negative cloud buoyancy is counted !
1599 : ! to calculate final 'cin' upto LFC. !
1600 : ! 3. If either 'cin' or 'cinlcl' is negative, they are set to be zero. !
1601 : ! In the below code, 'klfc' is the layer index containing 'LFC' similar to !
1602 : ! 'kinv' and 'klcl'. !
1603 : ! ------------------------------------------------------------------------ !
1604 :
1605 0 : cin = 0._r8
1606 0 : cinlcl = 0._r8
1607 0 : plfc = 0._r8
1608 0 : klfc = mkx
1609 :
1610 : ! ------------------------------------------------------------------------- !
1611 : ! Case 1. LCL height is higher than PBL interface ( 'pLCL <= ps0(kinv-1)' ) !
1612 : ! ------------------------------------------------------------------------- !
1613 :
1614 0 : if( klcl .ge. kinv ) then
1615 :
1616 0 : do k = kinv, mkx - 1
1617 0 : if( k .lt. klcl ) then
1618 0 : thvubot = thvlsrc
1619 0 : thvutop = thvlsrc
1620 0 : cin = cin + single_cin(ps0(k-1),thv0bot(k),ps0(k),thv0top(k),thvubot,thvutop)
1621 0 : elseif( k .eq. klcl ) then
1622 : !----- Bottom to LCL
1623 0 : thvubot = thvlsrc
1624 0 : thvutop = thvlsrc
1625 0 : cin = cin + single_cin(ps0(k-1),thv0bot(k),plcl,thv0lcl,thvubot,thvutop)
1626 0 : if( cin .lt. 0._r8 ) limit_cinlcl(i) = 1._r8
1627 0 : cinlcl = max(cin,0._r8)
1628 0 : cin = cinlcl
1629 : !----- LCL to Top
1630 0 : thvubot = thvlsrc
1631 0 : call conden(ps0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check)
1632 0 : if( id_check .eq. 1 ) then
1633 0 : exit_conden(i) = 1._r8
1634 0 : id_exit = .true.
1635 0 : go to 333
1636 : end if
1637 0 : thvutop = thj * ( 1._r8 + zvir*qvj - qlj - qij )
1638 : call getbuoy(plcl,thv0lcl,ps0(k),thv0top(k),thvubot,thvutop,plfc,cin)
1639 0 : if( plfc .gt. 0._r8 ) then
1640 : klfc = k
1641 : go to 35
1642 : end if
1643 : else
1644 0 : thvubot = thvutop
1645 0 : call conden(ps0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check)
1646 0 : if( id_check .eq. 1 ) then
1647 0 : exit_conden(i) = 1._r8
1648 0 : id_exit = .true.
1649 0 : go to 333
1650 : end if
1651 0 : thvutop = thj * ( 1._r8 + zvir*qvj - qlj - qij )
1652 0 : call getbuoy(ps0(k-1),thv0bot(k),ps0(k),thv0top(k),thvubot,thvutop,plfc,cin)
1653 0 : if( plfc .gt. 0._r8 ) then
1654 : klfc = k
1655 : go to 35
1656 : end if
1657 : endif
1658 : end do
1659 :
1660 : ! ----------------------------------------------------------------------- !
1661 : ! Case 2. LCL height is lower than PBL interface ( 'pLCL > ps0(kinv-1)' ) !
1662 : ! ----------------------------------------------------------------------- !
1663 :
1664 : else
1665 0 : cinlcl = 0._r8
1666 0 : do k = kinv, mkx - 1
1667 0 : call conden(ps0(k-1),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check)
1668 0 : if( id_check .eq. 1 ) then
1669 0 : exit_conden(i) = 1._r8
1670 0 : id_exit = .true.
1671 0 : go to 333
1672 : end if
1673 0 : thvubot = thj * ( 1._r8 + zvir*qvj - qlj - qij )
1674 0 : call conden(ps0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check)
1675 0 : if( id_check .eq. 1 ) then
1676 0 : exit_conden(i) = 1._r8
1677 0 : id_exit = .true.
1678 0 : go to 333
1679 : end if
1680 0 : thvutop = thj * ( 1._r8 + zvir*qvj - qlj - qij )
1681 0 : call getbuoy(ps0(k-1),thv0bot(k),ps0(k),thv0top(k),thvubot,thvutop,plfc,cin)
1682 0 : if( plfc .gt. 0._r8 ) then
1683 : klfc = k
1684 : go to 35
1685 : end if
1686 : end do
1687 : endif ! End of CIN case selection
1688 :
1689 : 35 continue
1690 0 : if( cin .lt. 0._r8 ) limit_cin(i) = 1._r8
1691 0 : cin = max(0._r8,cin)
1692 0 : if( klfc .ge. mkx ) then
1693 0 : klfc = mkx
1694 : ! write(iulog,*) 'klfc >= mkx'
1695 0 : exit_klfcmkx(i) = 1._r8
1696 0 : id_exit = .true.
1697 0 : go to 333
1698 : endif
1699 :
1700 : ! ---------------------------------------------------------------------- !
1701 : ! In order to calculate implicit 'cin' (or 'cinlcl'), save the initially !
1702 : ! calculated 'cin' and 'cinlcl', and other related variables. These will !
1703 : ! be restored after calculating implicit CIN. !
1704 : ! ---------------------------------------------------------------------- !
1705 :
1706 0 : if( iter .eq. 1 ) then
1707 0 : cin_i = cin
1708 0 : cinlcl_i = cinlcl
1709 0 : ke = rbuoy / ( rkfre * tkeavg + epsvarw )
1710 0 : kinv_o = kinv
1711 0 : klcl_o = klcl
1712 0 : klfc_o = klfc
1713 0 : plcl_o = plcl
1714 0 : plfc_o = plfc
1715 0 : tkeavg_o = tkeavg
1716 0 : thvlmin_o = thvlmin
1717 0 : qtsrc_o = qtsrc
1718 0 : thvlsrc_o = thvlsrc
1719 0 : thlsrc_o = thlsrc
1720 0 : usrc_o = usrc
1721 0 : vsrc_o = vsrc
1722 0 : thv0lcl_o = thv0lcl
1723 0 : do m = 1, ncnst
1724 0 : trsrc_o(m) = trsrc(m)
1725 : enddo
1726 : endif
1727 :
1728 : ! Modification : If I impose w = max(0.1_r8, w) up to the top interface of
1729 : ! klfc, I should only use cinlfc. That is, if I want to
1730 : ! use cinlcl, I should not impose w = max(0.1_r8, w).
1731 : ! Using cinlcl is equivalent to treating only 'saturated'
1732 : ! moist convection. Note that in this sense, I should keep
1733 : ! the functionality of both cinlfc and cinlcl.
1734 : ! However, the treatment of penetrative entrainment level becomes
1735 : ! ambiguous if I choose 'cinlcl'. Thus, the best option is to use
1736 : ! 'cinlfc'.
1737 :
1738 : ! -------------------------------------------------------------------------- !
1739 : ! Calculate implicit 'cin' by averaging initial and final cins. Note that !
1740 : ! implicit CIN is adopted only when cumulus convection stabilized the system,!
1741 : ! i.e., only when 'del_CIN >0'. If 'del_CIN<=0', just use explicit CIN. Note !
1742 : ! also that since 'cinlcl' is set to zero whenever LCL is below the PBL top, !
1743 : ! (see above CIN calculation part), the use of 'implicit CIN=cinlcl' is not !
1744 : ! good. Thus, when using implicit CIN, always try to only use 'implicit CIN= !
1745 : ! cin', not 'implicit CIN=cinlcl'. However, both 'CIN=cin' and 'CIN=cinlcl' !
1746 : ! are good when using explicit CIN. !
1747 : ! -------------------------------------------------------------------------- !
1748 :
1749 0 : if( iter .ne. 1 ) then
1750 :
1751 0 : cin_f = cin
1752 0 : cinlcl_f = cinlcl
1753 0 : if( use_CINcin ) then
1754 0 : del_CIN = cin_f - cin_i
1755 : else
1756 : del_CIN = cinlcl_f - cinlcl_i
1757 : endif
1758 :
1759 0 : if( del_CIN .gt. 0._r8 ) then
1760 :
1761 : ! -------------------------------------------------------------- !
1762 : ! Calculate implicit 'cin' and 'cinlcl'. Note that when we chose !
1763 : ! to use 'implicit CIN = cin', choose 'cinlcl = cinlcl_i' below: !
1764 : ! because iterative CIN only aims to obtain implicit CIN, once !
1765 : ! we obtained 'implicit CIN=cin', it is good to use the original !
1766 : ! profiles information for all the other variables after that. !
1767 : ! Note 'cinlcl' will be explicitly used in calculating 'wlcl' & !
1768 : ! 'ufrclcl' after calculating 'winv' & 'ufrcinv' at the PBL top !
1769 : ! interface later, after calculating 'cbmf'. !
1770 : ! -------------------------------------------------------------- !
1771 :
1772 0 : alpha = compute_alpha( del_CIN, ke )
1773 0 : cin = cin_i + alpha * del_CIN
1774 0 : if( use_CINcin ) then
1775 : cinlcl = cinlcl_i
1776 : else
1777 : cinlcl = cinlcl_i + alpha * del_cinlcl
1778 : endif
1779 :
1780 : ! ----------------------------------------------------------------- !
1781 : ! Restore the original values from the previous 'iter_cin' step (1) !
1782 : ! to compute correct tendencies for (n+1) time step by implicit CIN !
1783 : ! ----------------------------------------------------------------- !
1784 :
1785 0 : kinv = kinv_o
1786 0 : klcl = klcl_o
1787 0 : klfc = klfc_o
1788 0 : plcl = plcl_o
1789 0 : plfc = plfc_o
1790 0 : tkeavg = tkeavg_o
1791 0 : thvlmin = thvlmin_o
1792 0 : qtsrc = qtsrc_o
1793 0 : thvlsrc = thvlsrc_o
1794 0 : thlsrc = thlsrc_o
1795 0 : usrc = usrc_o
1796 0 : vsrc = vsrc_o
1797 0 : thv0lcl = thv0lcl_o
1798 0 : do m = 1, ncnst
1799 0 : trsrc(m) = trsrc_o(m)
1800 : enddo
1801 :
1802 0 : qv0(:mkx) = qv0_o(:mkx)
1803 0 : ql0(:mkx) = ql0_o(:mkx)
1804 0 : qi0(:mkx) = qi0_o(:mkx)
1805 0 : t0(:mkx) = t0_o(:mkx)
1806 0 : s0(:mkx) = s0_o(:mkx)
1807 0 : u0(:mkx) = u0_o(:mkx)
1808 0 : v0(:mkx) = v0_o(:mkx)
1809 0 : qt0(:mkx) = qt0_o(:mkx)
1810 0 : thl0(:mkx) = thl0_o(:mkx)
1811 0 : thvl0(:mkx) = thvl0_o(:mkx)
1812 0 : ssthl0(:mkx) = ssthl0_o(:mkx)
1813 0 : ssqt0(:mkx) = ssqt0_o(:mkx)
1814 0 : thv0bot(:mkx) = thv0bot_o(:mkx)
1815 0 : thv0top(:mkx) = thv0top_o(:mkx)
1816 0 : thvl0bot(:mkx) = thvl0bot_o(:mkx)
1817 0 : thvl0top(:mkx) = thvl0top_o(:mkx)
1818 0 : ssu0(:mkx) = ssu0_o(:mkx)
1819 0 : ssv0(:mkx) = ssv0_o(:mkx)
1820 0 : do m = 1, ncnst
1821 0 : tr0(:mkx,m) = tr0_o(:mkx,m)
1822 0 : sstr0(:mkx,m) = sstr0_o(:mkx,m)
1823 : enddo
1824 :
1825 : ! ------------------------------------------------------ !
1826 : ! Initialize all fluxes, tendencies, and other variables !
1827 : ! in association with cumulus convection. !
1828 : ! ------------------------------------------------------ !
1829 :
1830 0 : umf(0:mkx) = 0.0_r8
1831 0 : emf(0:mkx) = 0.0_r8
1832 0 : slflx(0:mkx) = 0.0_r8
1833 0 : qtflx(0:mkx) = 0.0_r8
1834 0 : uflx(0:mkx) = 0.0_r8
1835 0 : vflx(0:mkx) = 0.0_r8
1836 0 : qvten(:mkx) = 0.0_r8
1837 0 : qlten(:mkx) = 0.0_r8
1838 0 : qiten(:mkx) = 0.0_r8
1839 0 : sten(:mkx) = 0.0_r8
1840 0 : uten(:mkx) = 0.0_r8
1841 0 : vten(:mkx) = 0.0_r8
1842 0 : qrten(:mkx) = 0.0_r8
1843 0 : qsten(:mkx) = 0.0_r8
1844 0 : dwten(:mkx) = 0.0_r8
1845 0 : diten(:mkx) = 0.0_r8
1846 0 : precip = 0.0_r8
1847 0 : snow = 0.0_r8
1848 0 : evapc(:mkx) = 0.0_r8
1849 0 : cufrc(:mkx) = 0.0_r8
1850 0 : qcu(:mkx) = 0.0_r8
1851 0 : qlu(:mkx) = 0.0_r8
1852 0 : qiu(:mkx) = 0.0_r8
1853 0 : fer(:mkx) = 0.0_r8
1854 0 : fdr(:mkx) = 0.0_r8
1855 0 : qc(:mkx) = 0.0_r8
1856 0 : qc_l(:mkx) = 0.0_r8
1857 0 : qc_i(:mkx) = 0.0_r8
1858 0 : rliq = 0.0_r8
1859 0 : cbmf = 0.0_r8
1860 0 : cnt = real(mkx, r8)
1861 0 : cnb = 0.0_r8
1862 0 : qtten(:mkx) = 0.0_r8
1863 0 : slten(:mkx) = 0.0_r8
1864 0 : ufrc(0:mkx) = 0.0_r8
1865 :
1866 0 : thlu(0:mkx) = 0.0_r8
1867 0 : qtu(0:mkx) = 0.0_r8
1868 0 : uu(0:mkx) = 0.0_r8
1869 0 : vu(0:mkx) = 0.0_r8
1870 0 : wu(0:mkx) = 0.0_r8
1871 0 : thvu(0:mkx) = 0.0_r8
1872 0 : thlu_emf(0:mkx) = 0.0_r8
1873 0 : qtu_emf(0:mkx) = 0.0_r8
1874 0 : uu_emf(0:mkx) = 0.0_r8
1875 0 : vu_emf(0:mkx) = 0.0_r8
1876 :
1877 0 : do m = 1, ncnst
1878 0 : trflx(0:mkx,m) = 0.0_r8
1879 0 : trten(:mkx,m) = 0.0_r8
1880 0 : tru(0:mkx,m) = 0.0_r8
1881 0 : tru_emf(0:mkx,m) = 0.0_r8
1882 : enddo
1883 :
1884 : ! -------------------------------------------------- !
1885 : ! Below are diagnostic output variables for detailed !
1886 : ! analysis of cumulus scheme. !
1887 : ! -------------------------------------------------- !
1888 :
1889 0 : ufrcinvbase = 0.0_r8
1890 0 : ufrclcl = 0.0_r8
1891 0 : winvbase = 0.0_r8
1892 0 : wlcl = 0.0_r8
1893 : emfkbup = 0.0_r8
1894 0 : cbmflimit = 0.0_r8
1895 0 : excessu_arr(:mkx) = 0.0_r8
1896 0 : excess0_arr(:mkx) = 0.0_r8
1897 0 : xc_arr(:mkx) = 0.0_r8
1898 0 : aquad_arr(:mkx) = 0.0_r8
1899 0 : bquad_arr(:mkx) = 0.0_r8
1900 0 : cquad_arr(:mkx) = 0.0_r8
1901 0 : bogbot_arr(:mkx) = 0.0_r8
1902 0 : bogtop_arr(:mkx) = 0.0_r8
1903 :
1904 : else ! When 'del_CIN < 0', use explicit CIN instead of implicit CIN.
1905 :
1906 : ! ----------------------------------------------------------- !
1907 : ! Identifier showing whether explicit or implicit CIN is used !
1908 : ! ----------------------------------------------------------- !
1909 :
1910 0 : ind_delcin(i) = 1._r8
1911 :
1912 : ! --------------------------------------------------------- !
1913 : ! Restore original output values of "iter_cin = 1" and exit !
1914 : ! --------------------------------------------------------- !
1915 :
1916 0 : umf_out(i,0:mkx) = umf_s(0:mkx)
1917 0 : qvten_out(i,:mkx) = qvten_s(:mkx)
1918 0 : qlten_out(i,:mkx) = qlten_s(:mkx)
1919 0 : qiten_out(i,:mkx) = qiten_s(:mkx)
1920 0 : sten_out(i,:mkx) = sten_s(:mkx)
1921 0 : uten_out(i,:mkx) = uten_s(:mkx)
1922 0 : vten_out(i,:mkx) = vten_s(:mkx)
1923 0 : qrten_out(i,:mkx) = qrten_s(:mkx)
1924 0 : qsten_out(i,:mkx) = qsten_s(:mkx)
1925 0 : precip_out(i) = precip_s
1926 0 : snow_out(i) = snow_s
1927 0 : evapc_out(i,:mkx) = evapc_s(:mkx)
1928 0 : cush_inout(i) = cush_s
1929 0 : cufrc_out(i,:mkx) = cufrc_s(:mkx)
1930 0 : slflx_out(i,0:mkx) = slflx_s(0:mkx)
1931 0 : qtflx_out(i,0:mkx) = qtflx_s(0:mkx)
1932 0 : qcu_out(i,:mkx) = qcu_s(:mkx)
1933 0 : qlu_out(i,:mkx) = qlu_s(:mkx)
1934 0 : qiu_out(i,:mkx) = qiu_s(:mkx)
1935 0 : cbmf_out(i) = cbmf_s
1936 0 : qc_out(i,:mkx) = qc_s(:mkx)
1937 0 : rliq_out(i) = rliq_s
1938 0 : cnt_out(i) = cnt_s
1939 0 : cnb_out(i) = cnb_s
1940 0 : do m = 1, ncnst
1941 0 : trten_out(i,:mkx,m) = trten_s(:mkx,m)
1942 : enddo
1943 :
1944 : ! ------------------------------------------------------------------------------ !
1945 : ! Below are diagnostic output variables for detailed analysis of cumulus scheme. !
1946 : ! The order of vertical index is reversed for this internal diagnostic output. !
1947 : ! ------------------------------------------------------------------------------ !
1948 :
1949 0 : fer_out(i,mkx:1:-1) = fer_s(:mkx)
1950 0 : fdr_out(i,mkx:1:-1) = fdr_s(:mkx)
1951 0 : cinh_out(i) = cin_s
1952 0 : cinlclh_out(i) = cinlcl_s
1953 0 : qtten_out(i,mkx:1:-1) = qtten_s(:mkx)
1954 0 : slten_out(i,mkx:1:-1) = slten_s(:mkx)
1955 0 : ufrc_out(i,mkx:0:-1) = ufrc_s(0:mkx)
1956 0 : uflx_out(i,mkx:0:-1) = uflx_s(0:mkx)
1957 0 : vflx_out(i,mkx:0:-1) = vflx_s(0:mkx)
1958 :
1959 0 : ufrcinvbase_out(i) = ufrcinvbase_s
1960 0 : ufrclcl_out(i) = ufrclcl_s
1961 0 : winvbase_out(i) = winvbase_s
1962 0 : wlcl_out(i) = wlcl_s
1963 0 : plcl_out(i) = plcl_s
1964 0 : pinv_out(i) = pinv_s
1965 0 : plfc_out(i) = plfc_s
1966 0 : pbup_out(i) = pbup_s
1967 0 : ppen_out(i) = ppen_s
1968 0 : qtsrc_out(i) = qtsrc_s
1969 0 : thlsrc_out(i) = thlsrc_s
1970 0 : thvlsrc_out(i) = thvlsrc_s
1971 0 : emfkbup_out(i) = emfkbup_s
1972 0 : cbmflimit_out(i) = cbmflimit_s
1973 0 : tkeavg_out(i) = tkeavg_s
1974 0 : zinv_out(i) = zinv_s
1975 0 : rcwp_out(i) = rcwp_s
1976 0 : rlwp_out(i) = rlwp_s
1977 0 : riwp_out(i) = riwp_s
1978 :
1979 0 : wu_out(i,mkx:0:-1) = wu_s(0:mkx)
1980 0 : qtu_out(i,mkx:0:-1) = qtu_s(0:mkx)
1981 0 : thlu_out(i,mkx:0:-1) = thlu_s(0:mkx)
1982 0 : thvu_out(i,mkx:0:-1) = thvu_s(0:mkx)
1983 0 : uu_out(i,mkx:0:-1) = uu_s(0:mkx)
1984 0 : vu_out(i,mkx:0:-1) = vu_s(0:mkx)
1985 0 : qtu_emf_out(i,mkx:0:-1) = qtu_emf_s(0:mkx)
1986 0 : thlu_emf_out(i,mkx:0:-1) = thlu_emf_s(0:mkx)
1987 0 : uu_emf_out(i,mkx:0:-1) = uu_emf_s(0:mkx)
1988 0 : vu_emf_out(i,mkx:0:-1) = vu_emf_s(0:mkx)
1989 0 : uemf_out(i,mkx:0:-1) = uemf_s(0:mkx)
1990 :
1991 0 : dwten_out(i,mkx:1:-1) = dwten_s(:mkx)
1992 0 : diten_out(i,mkx:1:-1) = diten_s(:mkx)
1993 0 : flxrain_out(i,mkx:0:-1) = flxrain_s(0:mkx)
1994 0 : flxsnow_out(i,mkx:0:-1) = flxsnow_s(0:mkx)
1995 0 : ntraprd_out(i,mkx:1:-1) = ntraprd_s(:mkx)
1996 0 : ntsnprd_out(i,mkx:1:-1) = ntsnprd_s(:mkx)
1997 :
1998 0 : excessu_arr_out(i,mkx:1:-1) = excessu_arr_s(:mkx)
1999 0 : excess0_arr_out(i,mkx:1:-1) = excess0_arr_s(:mkx)
2000 0 : xc_arr_out(i,mkx:1:-1) = xc_arr_s(:mkx)
2001 0 : aquad_arr_out(i,mkx:1:-1) = aquad_arr_s(:mkx)
2002 0 : bquad_arr_out(i,mkx:1:-1) = bquad_arr_s(:mkx)
2003 0 : cquad_arr_out(i,mkx:1:-1) = cquad_arr_s(:mkx)
2004 0 : bogbot_arr_out(i,mkx:1:-1) = bogbot_arr_s(:mkx)
2005 0 : bogtop_arr_out(i,mkx:1:-1) = bogtop_arr_s(:mkx)
2006 :
2007 0 : do m = 1, ncnst
2008 0 : trflx_out(i,mkx:0:-1,m) = trflx_s(0:mkx,m)
2009 0 : tru_out(i,mkx:0:-1,m) = tru_s(0:mkx,m)
2010 0 : tru_emf_out(i,mkx:0:-1,m) = tru_emf_s(0:mkx,m)
2011 : enddo
2012 :
2013 : id_exit = .false.
2014 : go to 333
2015 :
2016 : endif
2017 :
2018 : endif
2019 :
2020 : ! ------------------------------------------------------------------ !
2021 : ! Define a release level, 'prel' and release layer, 'krel'. !
2022 : ! 'prel' is the lowest level from which buoyancy sorting occurs, and !
2023 : ! 'krel' is the layer index containing 'prel' in it, similar to the !
2024 : ! previous definitions of 'kinv', 'klcl', and 'klfc'. In order to !
2025 : ! ensure that only PBL scheme works within the PBL, if LCL is below !
2026 : ! PBL top height, then 'krel = kinv', while if LCL is above PBL top !
2027 : ! height, then 'krel = klcl'. Note however that regardless of the !
2028 : ! definition of 'krel', cumulus convection induces fluxes within PBL !
2029 : ! through 'fluxbelowinv'. We can make cumulus convection start from !
2030 : ! any level, even within the PBL by appropriately defining 'krel' & !
2031 : ! 'prel' here. Then it must be accompanied by appropriate definition !
2032 : ! of source air properties, CIN, and re-setting of 'fluxbelowinv', & !
2033 : ! many other stuffs. !
2034 : ! Note that even when 'prel' is located above the PBL top height, we !
2035 : ! still have cumulus convection between PBL top height and 'prel': !
2036 : ! we simply assume that no lateral mixing occurs in this range. !
2037 : ! ------------------------------------------------------------------ !
2038 :
2039 0 : if( klcl .lt. kinv ) then
2040 0 : krel = kinv
2041 0 : prel = ps0(krel-1)
2042 0 : thv0rel = thv0bot(krel)
2043 : else
2044 0 : krel = klcl
2045 0 : prel = plcl
2046 0 : thv0rel = thv0lcl
2047 : endif
2048 :
2049 : ! --------------------------------------------------------------------------- !
2050 : ! Calculate cumulus base mass flux ('cbmf'), fractional area ('ufrcinv'), and !
2051 : ! and mean vertical velocity (winv) of cumulus updraft at PBL top interface. !
2052 : ! Also, calculate updraft fractional area (ufrclcl) and vertical velocity at !
2053 : ! the LCL (wlcl). When LCL is below PBLH, cinlcl = 0 and 'ufrclcl = ufrcinv', !
2054 : ! and 'wlcl = winv. !
2055 : ! Only updrafts strong enough to overcome CIN can rise over PBL top interface.!
2056 : ! Thus, in order to calculate cumulus mass flux at PBL top interface, 'cbmf',!
2057 : ! we need to know 'CIN' ( the strength of potential energy barrier ) and !
2058 : ! 'sigmaw' ( a standard deviation of updraft vertical velocity at the PBL top !
2059 : ! interface, a measure of turbulentce strength in the PBL ). Naturally, the !
2060 : ! ratio of these two variables, 'mu' - normalized CIN by TKE- is key variable !
2061 : ! controlling 'cbmf'. If 'mu' becomes large, only small fraction of updrafts !
2062 : ! with very strong TKE can rise over the PBL - both 'cbmf' and 'ufrc' becomes !
2063 : ! small, but 'winv' becomes large ( this can be easily understood by PDF of w !
2064 : ! at PBL top ). If 'mu' becomes small, lots of updraft can rise over the PBL !
2065 : ! top - both 'cbmf' and 'ufrc' becomes large, but 'winv' becomes small. Thus, !
2066 : ! all of the key variables associated with cumulus convection at the PBL top !
2067 : ! - 'cbmf', 'ufrc', 'winv' where 'cbmf = rho*ufrc*winv' - are a unique functi !
2068 : ! ons of 'mu', normalized CIN. Although these are uniquely determined by 'mu',!
2069 : ! we usually impose two comstraints on 'cbmf' and 'ufrc': (1) because we will !
2070 : ! simply assume that subsidence warming and drying of 'kinv-1' layer in assoc !
2071 : ! iation with 'cbmf' at PBL top interface is confined only in 'kinv-1' layer, !
2072 : ! cbmf must not be larger than the mass within the 'kinv-1' layer. Otherwise, !
2073 : ! instability will occur due to the breaking of stability con. If we consider !
2074 : ! semi-Lagrangian vertical advection scheme and explicitly consider the exten !
2075 : ! t of vertical movement of each layer in association with cumulus mass flux, !
2076 : ! we don't need to impose this constraint. However, using a semi-Lagrangian !
2077 : ! scheme is a future research subject. Note that this constraint should be ap !
2078 : ! plied for all interfaces above PBL top as well as PBL top interface. As a !
2079 : ! result, this 'cbmf' constraint impose a 'lower' limit on mu - 'mumin0'. (2) !
2080 : ! in order for mass flux parameterization - rho*(w'a')= M*(a_c-a_e) - to be !
2081 : ! valid, cumulus updraft fractional area should be much smaller than 1. In !
2082 : ! current code, we impose 'rmaxfrac = 0.1 ~ 0.2' through the whole vertical !
2083 : ! layers where cumulus convection occurs. At the PBL top interface, the same !
2084 : ! constraint is made by imposing another lower 'lower' limit on mu, 'mumin1'. !
2085 : ! After that, also limit 'ufrclcl' to be smaller than 'rmaxfrac' by 'mumin2'. !
2086 : ! --------------------------------------------------------------------------- !
2087 :
2088 : ! --------------------------------------------------------------------------- !
2089 : ! Calculate normalized CIN, 'mu' satisfying all the three constraints imposed !
2090 : ! on 'cbmf'('mumin0'), 'ufrc' at the PBL top - 'ufrcinv' - ( by 'mumin1' from !
2091 : ! a parameter sentence), and 'ufrc' at the LCL - 'ufrclcl' ( by 'mumin2'). !
2092 : ! Note that 'cbmf' does not change between PBL top and LCL because we assume !
2093 : ! that buoyancy sorting does not occur when cumulus updraft is unsaturated. !
2094 : ! --------------------------------------------------------------------------- !
2095 :
2096 : if( use_CINcin ) then
2097 0 : wcrit = sqrt( 2._r8 * cin * rbuoy )
2098 : else
2099 : wcrit = sqrt( 2._r8 * cinlcl * rbuoy )
2100 : endif
2101 0 : sigmaw = sqrt( rkfre * tkeavg + epsvarw )
2102 0 : mu = wcrit/sigmaw/1.4142_r8
2103 0 : if( mu .ge. 3._r8 ) then
2104 : ! write(iulog,*) 'mu >= 3'
2105 : id_exit = .true.
2106 : go to 333
2107 : endif
2108 0 : rho0inv = ps0(kinv-1)/(r*thv0top(kinv-1)*exns0(kinv-1))
2109 0 : cbmf = (rho0inv*sigmaw/2.5066_r8)*exp(-mu**2)
2110 : ! 1. 'cbmf' constraint
2111 0 : cbmflimit = 0.9_r8*dp0(kinv-1)/g/dt
2112 0 : mumin0 = 0._r8
2113 0 : if( cbmf .gt. cbmflimit ) mumin0 = sqrt(-log(2.5066_r8*cbmflimit/rho0inv/sigmaw))
2114 : ! 2. 'ufrcinv' constraint
2115 0 : mu = max(max(mu,mumin0),mumin1)
2116 : ! 3. 'ufrclcl' constraint
2117 0 : mulcl = sqrt(2._r8*cinlcl*rbuoy)/1.4142_r8/sigmaw
2118 0 : mulclstar = sqrt(max(0._r8,2._r8*(exp(-mu**2)/2.5066_r8)**2*(1._r8/erfc(mu)**2-0.25_r8/rmaxfrac**2)))
2119 0 : if( mulcl .gt. 1.e-8_r8 .and. mulcl .gt. mulclstar ) then
2120 0 : mumin2 = compute_mumin2(mulcl,rmaxfrac,mu)
2121 0 : if( mu .gt. mumin2 ) then
2122 0 : write(iulog,*) 'Critical error in mu calculation in UW_ShCu'
2123 0 : call endrun
2124 : endif
2125 0 : mu = max(mu,mumin2)
2126 0 : if( mu .eq. mumin2 ) limit_ufrc(i) = 1._r8
2127 : endif
2128 0 : if( mu .eq. mumin0 ) limit_cbmf(i) = 1._r8
2129 0 : if( mu .eq. mumin1 ) limit_ufrc(i) = 1._r8
2130 :
2131 : ! ------------------------------------------------------------------- !
2132 : ! Calculate final ['cbmf','ufrcinv','winv'] at the PBL top interface. !
2133 : ! Note that final 'cbmf' here is obtained in such that 'ufrcinv' and !
2134 : ! 'ufrclcl' are smaller than ufrcmax with no instability. !
2135 : ! ------------------------------------------------------------------- !
2136 :
2137 0 : cbmf = (rho0inv*sigmaw/2.5066_r8)*exp(-mu**2)
2138 0 : winv = sigmaw*(2._r8/2.5066_r8)*exp(-mu**2)/erfc(mu)
2139 0 : ufrcinv = cbmf/winv/rho0inv
2140 :
2141 : ! ------------------------------------------------------------------- !
2142 : ! Calculate ['ufrclcl','wlcl'] at the LCL. When LCL is below PBL top, !
2143 : ! it automatically becomes 'ufrclcl = ufrcinv' & 'wlcl = winv', since !
2144 : ! it was already set to 'cinlcl=0' if LCL is below PBL top interface. !
2145 : ! Note 'cbmf' at the PBL top is the same as 'cbmf' at the LCL. Note !
2146 : ! also that final 'cbmf' here is obtained in such that 'ufrcinv' and !
2147 : ! 'ufrclcl' are smaller than ufrcmax and there is no instability. !
2148 : ! By construction, it must be 'wlcl > 0' but for assurance, I checked !
2149 : ! this again in the below block. If 'ufrclcl < 0.1%', just exit. !
2150 : ! ------------------------------------------------------------------- !
2151 :
2152 0 : wtw = winv * winv - 2._r8 * cinlcl * rbuoy
2153 0 : if( wtw .le. 0._r8 ) then
2154 : ! write(iulog,*) 'wlcl < 0 at the LCL'
2155 0 : exit_wtw(i) = 1._r8
2156 0 : id_exit = .true.
2157 0 : go to 333
2158 : endif
2159 0 : wlcl = sqrt(wtw)
2160 0 : ufrclcl = cbmf/wlcl/rho0inv
2161 0 : wrel = wlcl
2162 0 : if( ufrclcl .le. 0.0001_r8 ) then
2163 : ! write(iulog,*) 'ufrclcl <= 0.0001'
2164 0 : exit_ufrc(i) = 1._r8
2165 0 : id_exit = .true.
2166 0 : go to 333
2167 : endif
2168 0 : ufrc(krel-1) = ufrclcl
2169 :
2170 : ! ----------------------------------------------------------------------- !
2171 : ! Below is just diagnostic output for detailed analysis of cumulus scheme !
2172 : ! ----------------------------------------------------------------------- !
2173 :
2174 0 : ufrcinvbase = ufrcinv
2175 0 : winvbase = winv
2176 0 : umf(kinv-1:krel-1) = cbmf
2177 0 : wu(kinv-1:krel-1) = winv
2178 :
2179 : ! -------------------------------------------------------------------------- !
2180 : ! Define updraft properties at the level where buoyancy sorting starts to be !
2181 : ! happening, i.e., by definition, at 'prel' level within the release layer. !
2182 : ! Because no lateral entrainment occurs upto 'prel', conservative scalars of !
2183 : ! cumulus updraft at release level is same as those of source air. However, !
2184 : ! horizontal momentums of source air are modified by horizontal PGF forcings !
2185 : ! from PBL top interface to 'prel'. For this case, we should add additional !
2186 : ! horizontal momentum from PBL top interface to 'prel' as will be done below !
2187 : ! to 'usrc' and 'vsrc'. Note that below cumulus updraft properties - umf, wu,!
2188 : ! thlu, qtu, thvu, uu, vu - are defined all interfaces not at the layer mid- !
2189 : ! point. From the index notation of cumulus scheme, wu(k) is the cumulus up- !
2190 : ! draft vertical velocity at the top interface of k layer. !
2191 : ! Diabatic horizontal momentum forcing should be treated as a kind of 'body' !
2192 : ! forcing without actual mass exchange between convective updraft and !
2193 : ! environment, but still taking horizontal momentum from the environment to !
2194 : ! the convective updrafts. Thus, diabatic convective momentum transport !
2195 : ! vertically redistributes environmental horizontal momentum. !
2196 : ! -------------------------------------------------------------------------- !
2197 :
2198 0 : emf(krel-1) = 0._r8
2199 0 : umf(krel-1) = cbmf
2200 0 : wu(krel-1) = wrel
2201 0 : thlu(krel-1) = thlsrc
2202 0 : qtu(krel-1) = qtsrc
2203 0 : call conden(prel,thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check)
2204 0 : if( id_check .eq. 1 ) then
2205 0 : exit_conden(i) = 1._r8
2206 0 : id_exit = .true.
2207 0 : go to 333
2208 : endif
2209 0 : thvu(krel-1) = thj * ( 1._r8 + zvir*qvj - qlj - qij )
2210 :
2211 0 : uplus = 0._r8
2212 0 : vplus = 0._r8
2213 0 : if( krel .eq. kinv ) then
2214 0 : uplus = PGFc * ssu0(kinv) * ( prel - ps0(kinv-1) )
2215 0 : vplus = PGFc * ssv0(kinv) * ( prel - ps0(kinv-1) )
2216 : else
2217 0 : do k = kinv, max(krel-1,kinv)
2218 0 : uplus = uplus + PGFc * ssu0(k) * ( ps0(k) - ps0(k-1) )
2219 0 : vplus = vplus + PGFc * ssv0(k) * ( ps0(k) - ps0(k-1) )
2220 : end do
2221 0 : uplus = uplus + PGFc * ssu0(krel) * ( prel - ps0(krel-1) )
2222 0 : vplus = vplus + PGFc * ssv0(krel) * ( prel - ps0(krel-1) )
2223 : end if
2224 0 : uu(krel-1) = usrc + uplus
2225 0 : vu(krel-1) = vsrc + vplus
2226 :
2227 0 : do m = 1, ncnst
2228 0 : tru(krel-1,m) = trsrc(m)
2229 : enddo
2230 :
2231 : ! -------------------------------------------------------------------------- !
2232 : ! Define environmental properties at the level where buoyancy sorting occurs !
2233 : ! ('pe', normally, layer midpoint except in the 'krel' layer). In the 'krel' !
2234 : ! layer where buoyancy sorting starts to occur, however, 'pe' is defined !
2235 : ! differently because LCL is regarded as lower interface for mixing purpose. !
2236 : ! -------------------------------------------------------------------------- !
2237 :
2238 0 : pe = 0.5_r8 * ( prel + ps0(krel) )
2239 0 : dpe = prel - ps0(krel)
2240 0 : exne = exnf(pe)
2241 0 : thvebot = thv0rel
2242 0 : thle = thl0(krel) + ssthl0(krel) * ( pe - p0(krel) )
2243 0 : qte = qt0(krel) + ssqt0(krel) * ( pe - p0(krel) )
2244 0 : ue = u0(krel) + ssu0(krel) * ( pe - p0(krel) )
2245 0 : ve = v0(krel) + ssv0(krel) * ( pe - p0(krel) )
2246 0 : do m = 1, ncnst
2247 0 : tre(m) = tr0(krel,m) + sstr0(krel,m) * ( pe - p0(krel) )
2248 : enddo
2249 :
2250 : !-------------------------!
2251 : ! Buoyancy-Sorting Mixing !
2252 : !-------------------------!------------------------------------------------ !
2253 : ! !
2254 : ! In order to complete buoyancy-sorting mixing at layer mid-point, and so !
2255 : ! calculate 'updraft mass flux, updraft w velocity, conservative scalars' !
2256 : ! at the upper interface of each layer, we need following 3 information. !
2257 : ! !
2258 : ! 1. Pressure where mixing occurs ('pe'), and temperature at 'pe' which is !
2259 : ! necessary to calculate various thermodynamic coefficients at pe. This !
2260 : ! temperature is obtained by undiluted cumulus properties lifted to pe. !
2261 : ! 2. Undiluted updraft properties at pe - conservative scalar and vertical !
2262 : ! velocity -which are assumed to be the same as the properties at lower !
2263 : ! interface only for calculation of fractional lateral entrainment and !
2264 : ! detrainment rate ( fer(k) and fdr(k) [Pa-1] ), respectively. Final !
2265 : ! values of cumulus conservative scalars and w at the top interface are !
2266 : ! calculated afterward after obtaining fer(k) & fdr(k). !
2267 : ! 3. Environmental properties at pe. !
2268 : ! ------------------------------------------------------------------------- !
2269 :
2270 : ! ------------------------------------------------------------------------ !
2271 : ! Define cumulus scale height. !
2272 : ! Cumulus scale height is defined as the maximum height cumulus can reach. !
2273 : ! In case of premitive code, cumulus scale height ('cush') at the current !
2274 : ! time step was assumed to be the same as 'cush' of previous time step. !
2275 : ! However, I directly calculated cush at each time step using an iterative !
2276 : ! method. Note that within the cumulus scheme, 'cush' information is used !
2277 : ! only at two places during buoyancy-sorting process: !
2278 : ! (1) Even negatively buoyancy mixtures with strong vertical velocity !
2279 : ! enough to rise up to 'rle*scaleh' (rle = 0.1) from pe are entrained !
2280 : ! into cumulus updraft, !
2281 : ! (2) The amount of mass that is involved in buoyancy-sorting mixing !
2282 : ! process at pe is rei(k) = rkm/scaleh/rho*g [Pa-1] !
2283 : ! In terms of (1), I think critical stopping distance might be replaced by !
2284 : ! layer thickness. In future, we will use rei(k) = (0.5*rkm/z0(k)/rho/g). !
2285 : ! In the premitive code, 'scaleh' was largely responsible for the jumping !
2286 : ! variation of precipitation amount. !
2287 : ! ------------------------------------------------------------------------ !
2288 :
2289 0 : scaleh = tscaleh
2290 0 : if( tscaleh .lt. 0.0_r8 ) scaleh = 1000._r8
2291 :
2292 : ! Save time : Set iter_scaleh = 1. This will automatically use 'cush' from the previous time step
2293 : ! at the first implicit iteration. At the second implicit iteration, it will use
2294 : ! the updated 'cush' by the first implicit cin. So, this updating has an effect of
2295 : ! doing one iteration for cush calculation, which is good.
2296 : ! So, only this setting of 'iter_scaleh = 1' is sufficient-enough to save computation time.
2297 : ! OK
2298 :
2299 0 : do iter_scaleh = 1, 3
2300 :
2301 : ! ---------------------------------------------------------------- !
2302 : ! Initialization of 'kbup' and 'kpen' !
2303 : ! ---------------------------------------------------------------- !
2304 : ! 'kbup' is the top-most layer in which cloud buoyancy is positive !
2305 : ! both at the top and bottom interface of the layer. 'kpen' is the !
2306 : ! layer upto which cumulus panetrates ,i.e., cumulus w at the base !
2307 : ! interface is positive, but becomes negative at the top interface.!
2308 : ! Here, we initialize 'kbup' and 'kpen'. These initializations are !
2309 : ! not trivial but important, expecially in calculating turbulent !
2310 : ! fluxes without confliction among several physics as explained in !
2311 : ! detail in the part of turbulent fluxes calculation later. Note !
2312 : ! that regardless of whether 'kbup' and 'kpen' are updated or not !
2313 : ! during updraft motion, penetrative entrainments are dumped down !
2314 : ! across the top interface of 'kbup' later. More specifically,!
2315 : ! penetrative entrainment heat and moisture fluxes are calculated !
2316 : ! from the top interface of 'kbup' layer to the base interface of !
2317 : ! 'kpen' layer. Because of this, initialization of 'kbup' & 'kpen' !
2318 : ! influence the convection system when there are not updated. The !
2319 : ! below initialization of 'kbup = krel' assures that penetrative !
2320 : ! entrainment fluxes always occur at interfaces above the PBL top !
2321 : ! interfaces (i.e., only at interfaces k >=kinv ), which seems to !
2322 : ! be attractable considering that the most correct fluxes at the !
2323 : ! PBL top interface can be ontained from the 'fluxbelowinv' using !
2324 : ! reconstructed PBL height. !
2325 : ! The 'kbup = krel'(after going through the whole buoyancy sorting !
2326 : ! proces during updraft motion) implies that cumulus updraft from !
2327 : ! the PBL top interface can not reach to the LFC,so that 'kbup' is !
2328 : ! not updated during upward. This means that cumulus updraft did !
2329 : ! not fully overcome the buoyancy barrier above just the PBL top. !
2330 : ! If 'kpen' is not updated either ( i.e., cumulus cannot rise over !
2331 : ! the top interface of release layer),penetrative entrainment will !
2332 : ! not happen at any interfaces. If cumulus updraft can rise above !
2333 : ! the release layer but cannot fully overcome the buoyancy barrier !
2334 : ! just above PBL top interface, penetratve entrainment occurs at !
2335 : ! several above interfaces, including the top interface of release !
2336 : ! layer. In the latter case, warming and drying tendencies will be !
2337 : ! be initiated in 'krel' layer. Note current choice of 'kbup=krel' !
2338 : ! is completely compatible with other flux physics without double !
2339 : ! or miss counting turbulent fluxes at any interface. However, the !
2340 : ! alternative choice of 'kbup=krel-1' also has itw own advantage - !
2341 : ! when cumulus updraft cannot overcome buoyancy barrier just above !
2342 : ! PBL top, entrainment warming and drying are concentrated in the !
2343 : ! 'kinv-1' layer instead of 'kinv' layer for this case. This might !
2344 : ! seems to be more dynamically reasonable, but I will choose the !
2345 : ! 'kbup = krel' choice since it is more compatible with the other !
2346 : ! parts of the code, expecially, when we chose ' use_emf=.false. ' !
2347 : ! as explained in detail in turbulent flux calculation part. !
2348 : ! ---------------------------------------------------------------- !
2349 :
2350 0 : kbup = krel
2351 0 : kpen = krel
2352 :
2353 : ! ------------------------------------------------------------ !
2354 : ! Since 'wtw' is continuously updated during vertical motion, !
2355 : ! I need below initialization command within this 'iter_scaleh'!
2356 : ! do loop. Similarily, I need initializations of environmental !
2357 : ! properties at 'krel' layer as below. !
2358 : ! ------------------------------------------------------------ !
2359 :
2360 0 : wtw = wlcl * wlcl
2361 0 : pe = 0.5_r8 * ( prel + ps0(krel) )
2362 0 : dpe = prel - ps0(krel)
2363 0 : exne = exnf(pe)
2364 0 : thvebot = thv0rel
2365 0 : thle = thl0(krel) + ssthl0(krel) * ( pe - p0(krel) )
2366 0 : qte = qt0(krel) + ssqt0(krel) * ( pe - p0(krel) )
2367 0 : ue = u0(krel) + ssu0(krel) * ( pe - p0(krel) )
2368 0 : ve = v0(krel) + ssv0(krel) * ( pe - p0(krel) )
2369 0 : do m = 1, ncnst
2370 0 : tre(m) = tr0(krel,m) + sstr0(krel,m) * ( pe - p0(krel) )
2371 : enddo
2372 :
2373 : ! ----------------------------------------------------------------------- !
2374 : ! Cumulus rises upward from 'prel' ( or base interface of 'krel' layer ) !
2375 : ! until updraft vertical velocity becomes zero. !
2376 : ! Buoyancy sorting is performed via two stages. (1) Using cumulus updraft !
2377 : ! properties at the base interface of each layer,perform buoyancy sorting !
2378 : ! at the layer mid-point, 'pe', and update cumulus properties at the top !
2379 : ! interface, and then (2) by averaging updated cumulus properties at the !
2380 : ! top interface and cumulus properties at the base interface, calculate !
2381 : ! cumulus updraft properties at pe that will be used in buoyancy sorting !
2382 : ! mixing - thlue, qtue and, wue. Using this averaged properties, perform !
2383 : ! buoyancy sorting again at pe, and re-calculate fer(k) and fdr(k). Using !
2384 : ! this recalculated fer(k) and fdr(k), finally calculate cumulus updraft !
2385 : ! properties at the top interface - thlu, qtu, thvu, uu, vu. In the below,!
2386 : ! 'iter_xc = 1' performs the first stage, while 'iter_xc= 2' performs the !
2387 : ! second stage. We can increase the number of iterations, 'nter_xc'.as we !
2388 : ! want, but a sample test indicated that about 3 - 5 iterations produced !
2389 : ! satisfactory converent solution. Finally, identify 'kbup' and 'kpen'. !
2390 : ! ----------------------------------------------------------------------- !
2391 :
2392 0 : do k = krel, mkx - 1 ! Here, 'k' is a layer index.
2393 :
2394 0 : km1 = k - 1
2395 :
2396 0 : thlue = thlu(km1)
2397 0 : qtue = qtu(km1)
2398 0 : wue = wu(km1)
2399 0 : wtwb = wtw
2400 :
2401 0 : do iter_xc = 1, niter_xc
2402 :
2403 0 : wtw = wu(km1) * wu(km1)
2404 :
2405 : ! ---------------------------------------------------------------- !
2406 : ! Calculate environmental and cumulus saturation 'excess' at 'pe'. !
2407 : ! Note that in order to calculate saturation excess, we should use !
2408 : ! liquid water temperature instead of temperature as the argument !
2409 : ! of "qsat". But note normal argument of "qsat" is temperature. !
2410 : ! ---------------------------------------------------------------- !
2411 :
2412 0 : call conden(pe,thle,qte,thj,qvj,qlj,qij,qse,id_check)
2413 0 : if( id_check .eq. 1 ) then
2414 0 : exit_conden(i) = 1._r8
2415 0 : id_exit = .true.
2416 0 : go to 333
2417 : end if
2418 0 : thv0j = thj * ( 1._r8 + zvir*qvj - qlj - qij )
2419 0 : rho0j = pe / ( r * thv0j * exne )
2420 0 : qsat_arg = thle*exne
2421 0 : call qsat(qsat_arg, pe, es, qs)
2422 0 : excess0 = qte - qs
2423 :
2424 0 : call conden(pe,thlue,qtue,thj,qvj,qlj,qij,qse,id_check)
2425 0 : if( id_check .eq. 1 ) then
2426 0 : exit_conden(i) = 1._r8
2427 0 : id_exit = .true.
2428 0 : go to 333
2429 : end if
2430 : ! ----------------------------------------------------------------- !
2431 : ! Detrain excessive condensate larger than 'criqc' from the cumulus !
2432 : ! updraft before performing buoyancy sorting. All I should to do is !
2433 : ! to update 'thlue' & 'que' here. Below modification is completely !
2434 : ! compatible with the other part of the code since 'thule' & 'qtue' !
2435 : ! are used only for buoyancy sorting. I found that as long as I use !
2436 : ! 'niter_xc >= 2', detraining excessive condensate before buoyancy !
2437 : ! sorting has negligible influence on the buoyancy sorting results. !
2438 : ! ----------------------------------------------------------------- !
2439 0 : if( (qlj + qij) .gt. criqc ) then
2440 0 : exql = ( ( qlj + qij ) - criqc ) * qlj / ( qlj + qij )
2441 0 : exqi = ( ( qlj + qij ) - criqc ) * qij / ( qlj + qij )
2442 0 : qtue = qtue - exql - exqi
2443 0 : thlue = thlue + (xlv/cp/exne)*exql + (xls/cp/exne)*exqi
2444 : endif
2445 0 : call conden(pe,thlue,qtue,thj,qvj,qlj,qij,qse,id_check)
2446 0 : if( id_check .eq. 1 ) then
2447 0 : exit_conden(i) = 1._r8
2448 0 : id_exit = .true.
2449 0 : go to 333
2450 : end if
2451 0 : thvj = thj * ( 1._r8 + zvir * qvj - qlj - qij )
2452 0 : tj = thj * exne ! This 'tj' is used for computing thermo. coeffs. below
2453 0 : qsat_arg = thlue*exne
2454 0 : call qsat(qsat_arg, pe, es, qs)
2455 0 : excessu = qtue - qs
2456 :
2457 : ! ------------------------------------------------------------------- !
2458 : ! Calculate critical mixing fraction, 'xc'. Mixture with mixing ratio !
2459 : ! smaller than 'xc' will be entrained into cumulus updraft. Both the !
2460 : ! saturated updrafts with 'positive buoyancy' or 'negative buoyancy + !
2461 : ! strong vertical velocity enough to rise certain threshold distance' !
2462 : ! are kept into the updraft in the below program. If the core updraft !
2463 : ! is unsaturated, we can set 'xc = 0' and let the cumulus convection !
2464 : ! still works or we may exit. !
2465 : ! Current below code does not entrain unsaturated mixture. However it !
2466 : ! should be modified such that it also entrain unsaturated mixture. !
2467 : ! ------------------------------------------------------------------- !
2468 :
2469 : ! ----------------------------------------------------------------- !
2470 : ! cridis : Critical stopping distance for buoyancy sorting purpose. !
2471 : ! scaleh is only used here. !
2472 : ! ----------------------------------------------------------------- !
2473 :
2474 0 : cridis = rle*scaleh ! Original code
2475 : ! cridis = 1._r8*(zs0(k) - zs0(k-1)) ! New code
2476 :
2477 : ! ---------------- !
2478 : ! Buoyancy Sorting !
2479 : ! ---------------- !
2480 :
2481 : ! ----------------------------------------------------------------- !
2482 : ! Case 1 : When both cumulus and env. are unsaturated or saturated. !
2483 : ! ----------------------------------------------------------------- !
2484 :
2485 0 : if( ( excessu .le. 0._r8 .and. excess0 .le. 0._r8 ) .or. ( excessu .ge. 0._r8 .and. excess0 .ge. 0._r8 ) ) then
2486 0 : xc = min(1._r8,max(0._r8,1._r8-2._r8*rbuoy*g*cridis/wue**2._r8*(1._r8-thvj/thv0j)))
2487 : ! Below 3 lines are diagnostic output not influencing
2488 : ! numerical calculations.
2489 0 : aquad = 0._r8
2490 0 : bquad = 0._r8
2491 0 : cquad = 0._r8
2492 : else
2493 : ! -------------------------------------------------- !
2494 : ! Case 2 : When either cumulus or env. is saturated. !
2495 : ! -------------------------------------------------- !
2496 0 : xsat = excessu / ( excessu - excess0 );
2497 0 : thlxsat = thlue + xsat * ( thle - thlue );
2498 0 : qtxsat = qtue + xsat * ( qte - qtue );
2499 0 : call conden(pe,thlxsat,qtxsat,thj,qvj,qlj,qij,qse,id_check)
2500 0 : if( id_check .eq. 1 ) then
2501 0 : exit_conden(i) = 1._r8
2502 0 : id_exit = .true.
2503 0 : go to 333
2504 : end if
2505 0 : thvxsat = thj * ( 1._r8 + zvir * qvj - qlj - qij )
2506 : ! -------------------------------------------------- !
2507 : ! kk=1 : Cumulus Segment, kk=2 : Environment Segment !
2508 : ! -------------------------------------------------- !
2509 0 : do kk = 1, 2
2510 0 : if( kk .eq. 1 ) then
2511 0 : thv_x0 = thvj;
2512 0 : thv_x1 = ( 1._r8 - 1._r8/xsat ) * thvj + ( 1._r8/xsat ) * thvxsat;
2513 : else
2514 0 : thv_x1 = thv0j;
2515 0 : thv_x0 = ( xsat / ( xsat - 1._r8 ) ) * thv0j + ( 1._r8/( 1._r8 - xsat ) ) * thvxsat;
2516 : endif
2517 0 : aquad = wue**2;
2518 0 : bquad = 2._r8*rbuoy*g*cridis*(thv_x1 - thv_x0)/thv0j - 2._r8*wue**2;
2519 0 : cquad = 2._r8*rbuoy*g*cridis*(thv_x0 - thv0j)/thv0j + wue**2;
2520 0 : if( kk .eq. 1 ) then
2521 0 : if( ( bquad**2-4._r8*aquad*cquad ) .ge. 0._r8 ) then
2522 0 : call roots(aquad,bquad,cquad,xs1,xs2,status)
2523 0 : x_cu = min(1._r8,max(0._r8,min(xsat,min(xs1,xs2))))
2524 : else
2525 : x_cu = xsat;
2526 : endif
2527 : else
2528 0 : if( ( bquad**2-4._r8*aquad*cquad) .ge. 0._r8 ) then
2529 0 : call roots(aquad,bquad,cquad,xs1,xs2,status)
2530 0 : x_en = min(1._r8,max(0._r8,max(xsat,min(xs1,xs2))))
2531 : else
2532 : x_en = 1._r8;
2533 : endif
2534 : endif
2535 : enddo
2536 0 : if( x_cu .eq. xsat ) then
2537 0 : xc = max(x_cu, x_en);
2538 : else
2539 : xc = x_cu;
2540 : endif
2541 : endif
2542 :
2543 : ! ------------------------------------------------------------------------ !
2544 : ! Compute fractional lateral entrainment & detrainment rate in each layers.!
2545 : ! The unit of rei(k), fer(k), and fdr(k) is [Pa-1]. Alternative choice of !
2546 : ! 'rei(k)' is also shown below, where coefficient 0.5 was from approximate !
2547 : ! tuning against the BOMEX case. !
2548 : ! In order to prevent the onset of instability in association with cumulus !
2549 : ! induced subsidence advection, cumulus mass flux at the top interface in !
2550 : ! any layer should be smaller than ( 90% of ) total mass within that layer.!
2551 : ! I imposed limits on 'rei(k)' as below, in such that stability condition !
2552 : ! is always satisfied. !
2553 : ! Below limiter of 'rei(k)' becomes negative for some cases, causing error.!
2554 : ! So, for the time being, I came back to the original limiter. !
2555 : ! ------------------------------------------------------------------------ !
2556 0 : ee2 = xc**2
2557 0 : ud2 = 1._r8 - 2._r8*xc + xc**2
2558 : ! rei(k) = ( rkm / scaleh / g / rho0j ) ! Default.
2559 0 : rei(k) = ( 0.5_r8 * rkm / z0(k) / g /rho0j ) ! Alternative.
2560 0 : if( xc .gt. 0.5_r8 ) rei(k) = min(rei(k),0.9_r8*log(dp0(k)/g/dt/umf(km1) + 1._r8)/dpe/(2._r8*xc-1._r8))
2561 0 : fer(k) = rei(k) * ee2
2562 0 : fdr(k) = rei(k) * ud2
2563 :
2564 : ! ------------------------------------------------------------------------------ !
2565 : ! Iteration Start due to 'maxufrc' constraint [ ****************************** ] !
2566 : ! ------------------------------------------------------------------------------ !
2567 :
2568 : ! -------------------------------------------------------------------------- !
2569 : ! Calculate cumulus updraft mass flux and penetrative entrainment mass flux. !
2570 : ! Note that non-zero penetrative entrainment mass flux will be asigned only !
2571 : ! to interfaces from the top interface of 'kbup' layer to the base interface !
2572 : ! of 'kpen' layer as will be shown later. !
2573 : ! -------------------------------------------------------------------------- !
2574 :
2575 0 : umf(k) = umf(km1) * exp( dpe * ( fer(k) - fdr(k) ) )
2576 0 : emf(k) = 0._r8
2577 :
2578 : ! --------------------------------------------------------- !
2579 : ! Compute cumulus updraft properties at the top interface. !
2580 : ! Also use Tayler expansion in order to treat limiting case !
2581 : ! --------------------------------------------------------- !
2582 :
2583 0 : if( fer(k)*dpe .lt. 1.e-4_r8 ) then
2584 0 : thlu(k) = thlu(km1) + ( thle + ssthl0(k) * dpe / 2._r8 - thlu(km1) ) * fer(k) * dpe
2585 0 : qtu(k) = qtu(km1) + ( qte + ssqt0(k) * dpe / 2._r8 - qtu(km1) ) * fer(k) * dpe
2586 0 : uu(k) = uu(km1) + ( ue + ssu0(k) * dpe / 2._r8 - uu(km1) ) * fer(k) * dpe - PGFc * ssu0(k) * dpe
2587 0 : vu(k) = vu(km1) + ( ve + ssv0(k) * dpe / 2._r8 - vu(km1) ) * fer(k) * dpe - PGFc * ssv0(k) * dpe
2588 0 : do m = 1, ncnst
2589 0 : tru(k,m) = tru(km1,m) + ( tre(m) + sstr0(k,m) * dpe / 2._r8 - tru(km1,m) ) * fer(k) * dpe
2590 : enddo
2591 : else
2592 : thlu(k) = ( thle + ssthl0(k) / fer(k) - ssthl0(k) * dpe / 2._r8 ) - &
2593 0 : ( thle + ssthl0(k) * dpe / 2._r8 - thlu(km1) + ssthl0(k) / fer(k) ) * exp(-fer(k) * dpe)
2594 : qtu(k) = ( qte + ssqt0(k) / fer(k) - ssqt0(k) * dpe / 2._r8 ) - &
2595 0 : ( qte + ssqt0(k) * dpe / 2._r8 - qtu(km1) + ssqt0(k) / fer(k) ) * exp(-fer(k) * dpe)
2596 : uu(k) = ( ue + ( 1._r8 - PGFc ) * ssu0(k) / fer(k) - ssu0(k) * dpe / 2._r8 ) - &
2597 0 : ( ue + ssu0(k) * dpe / 2._r8 - uu(km1) + ( 1._r8 - PGFc ) * ssu0(k) / fer(k) ) * exp(-fer(k) * dpe)
2598 : vu(k) = ( ve + ( 1._r8 - PGFc ) * ssv0(k) / fer(k) - ssv0(k) * dpe / 2._r8 ) - &
2599 0 : ( ve + ssv0(k) * dpe / 2._r8 - vu(km1) + ( 1._r8 - PGFc ) * ssv0(k) / fer(k) ) * exp(-fer(k) * dpe)
2600 0 : do m = 1, ncnst
2601 0 : tru(k,m) = ( tre(m) + sstr0(k,m) / fer(k) - sstr0(k,m) * dpe / 2._r8 ) - &
2602 0 : ( tre(m) + sstr0(k,m) * dpe / 2._r8 - tru(km1,m) + sstr0(k,m) / fer(k) ) * exp(-fer(k) * dpe)
2603 : enddo
2604 : end if
2605 :
2606 : !------------------------------------------------------------------- !
2607 : ! Expel some of cloud water and ice from cumulus updraft at the top !
2608 : ! interface. Note that this is not 'detrainment' term but a 'sink' !
2609 : ! term of cumulus updraft qt ( or one part of 'source' term of mean !
2610 : ! environmental qt ). At this stage, as the most simplest choice, if !
2611 : ! condensate amount within cumulus updraft is larger than a critical !
2612 : ! value, 'criqc', expels the surplus condensate from cumulus updraft !
2613 : ! to the environment. A certain fraction ( e.g., 'frc_sus' ) of this !
2614 : ! expelled condesnate will be in a form that can be suspended in the !
2615 : ! layer k where it was formed, while the other fraction, '1-frc_sus' !
2616 : ! will be in a form of precipitatble (e.g.,can potentially fall down !
2617 : ! across the base interface of layer k ). In turn we should describe !
2618 : ! subsequent falling of precipitable condensate ('1-frc_sus') across !
2619 : ! the base interface of the layer k, & evaporation of precipitating !
2620 : ! water in the below layer k-1 and associated evaporative cooling of !
2621 : ! the later, k-1, and falling of 'non-evaporated precipitating water !
2622 : ! ( which was initially formed in layer k ) and a newly-formed preci !
2623 : ! pitable water in the layer, k-1', across the base interface of the !
2624 : ! lower layer k-1. Cloud microphysics should correctly describe all !
2625 : ! of these process. In a near future, I should significantly modify !
2626 : ! this cloud microphysics, including precipitation-induced downdraft !
2627 : ! also. !
2628 : ! ------------------------------------------------------------------ !
2629 :
2630 0 : call conden(ps0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check)
2631 0 : if( id_check .eq. 1 ) then
2632 0 : exit_conden(i) = 1._r8
2633 0 : id_exit = .true.
2634 0 : go to 333
2635 : end if
2636 0 : if( (qlj + qij) .gt. criqc ) then
2637 0 : exql = ( ( qlj + qij ) - criqc ) * qlj / ( qlj + qij )
2638 0 : exqi = ( ( qlj + qij ) - criqc ) * qij / ( qlj + qij )
2639 : ! ---------------------------------------------------------------- !
2640 : ! It is very important to re-update 'qtu' and 'thlu' at the upper !
2641 : ! interface after expelling condensate from cumulus updraft at the !
2642 : ! top interface of the layer. As mentioned above, this is a 'sink' !
2643 : ! of cumulus qt (or equivalently, a 'source' of environmentasl qt),!
2644 : ! not a regular convective'detrainment'. !
2645 : ! ---------------------------------------------------------------- !
2646 0 : qtu(k) = qtu(k) - exql - exqi
2647 0 : thlu(k) = thlu(k) + (xlv/cp/exns0(k))*exql + (xls/cp/exns0(k))*exqi
2648 : ! ---------------------------------------------------------------- !
2649 : ! Expelled cloud condensate into the environment from the updraft. !
2650 : ! After all the calculation later, 'dwten' and 'diten' will have a !
2651 : ! unit of [ kg/kg/s ], because it is a tendency of qt. Restoration !
2652 : ! of 'dwten' and 'diten' to this correct unit through multiplying !
2653 : ! 'umf(k)*g/dp0(k)' will be performed later after finally updating !
2654 : ! 'umf' using a 'rmaxfrac' constraint near the end of this updraft !
2655 : ! buoyancy sorting loop. !
2656 : ! ---------------------------------------------------------------- !
2657 0 : dwten(k) = exql
2658 0 : diten(k) = exqi
2659 : else
2660 0 : dwten(k) = 0._r8
2661 0 : diten(k) = 0._r8
2662 : endif
2663 : ! ----------------------------------------------------------------- !
2664 : ! Update 'thvu(k)' after detraining condensate from cumulus updraft.!
2665 : ! ----------------------------------------------------------------- !
2666 0 : call conden(ps0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check)
2667 0 : if( id_check .eq. 1 ) then
2668 0 : exit_conden(i) = 1._r8
2669 0 : id_exit = .true.
2670 0 : go to 333
2671 : end if
2672 0 : thvu(k) = thj * ( 1._r8 + zvir * qvj - qlj - qij )
2673 :
2674 : ! ----------------------------------------------------------- !
2675 : ! Calculate updraft vertical velocity at the upper interface. !
2676 : ! In order to calculate 'wtw' at the upper interface, we use !
2677 : ! 'wtw' at the lower interface. Note 'wtw' is continuously !
2678 : ! updated as cumulus updraft rises. !
2679 : ! ----------------------------------------------------------- !
2680 :
2681 0 : bogbot = rbuoy * ( thvu(km1) / thvebot - 1._r8 ) ! Cloud buoyancy at base interface
2682 0 : bogtop = rbuoy * ( thvu(k) / thv0top(k) - 1._r8 ) ! Cloud buoyancy at top interface
2683 :
2684 0 : delbog = bogtop - bogbot
2685 0 : drage = fer(k) * ( 1._r8 + rdrag )
2686 0 : expfac = exp(-2._r8*drage*dpe)
2687 :
2688 0 : wtwb = wtw
2689 0 : if( drage*dpe .gt. 1.e-3_r8 ) then
2690 0 : wtw = wtw*expfac + (delbog + (1._r8-expfac)*(bogbot + delbog/(-2._r8*drage*dpe)))/(rho0j*drage)
2691 : else
2692 0 : wtw = wtw + dpe * ( bogbot + bogtop ) / rho0j
2693 : endif
2694 :
2695 : ! Force the plume rise at least to klfc of the undiluted plume.
2696 : ! Because even the below is not complete, I decided not to include this.
2697 :
2698 : ! if( k .le. klfc ) then
2699 : ! wtw = max( 1.e-2_r8, wtw )
2700 : ! endif
2701 :
2702 : ! -------------------------------------------------------------- !
2703 : ! Repeat 'iter_xc' iteration loop until 'iter_xc = niter_xc'. !
2704 : ! Also treat the case even when wtw < 0 at the 'kpen' interface. !
2705 : ! -------------------------------------------------------------- !
2706 :
2707 0 : if( wtw .gt. 0._r8 ) then
2708 0 : thlue = 0.5_r8 * ( thlu(km1) + thlu(k) )
2709 0 : qtue = 0.5_r8 * ( qtu(km1) + qtu(k) )
2710 0 : wue = 0.5_r8 * sqrt( max( wtwb + wtw, 0._r8 ) )
2711 : else
2712 : go to 111
2713 : endif
2714 :
2715 : enddo ! End of 'iter_xc' loop
2716 :
2717 : 111 continue
2718 :
2719 : ! --------------------------------------------------------------------------- !
2720 : ! Add the contribution of self-detrainment to vertical variations of cumulus !
2721 : ! updraft mass flux. The reason why we are trying to include self-detrainment !
2722 : ! is as follows. In current scheme, vertical variation of updraft mass flux !
2723 : ! is not fully consistent with the vertical variation of updraft vertical w. !
2724 : ! For example, within a given layer, let's assume that cumulus w is positive !
2725 : ! at the base interface, while negative at the top interface. This means that !
2726 : ! cumulus updraft cannot reach to the top interface of the layer. However, !
2727 : ! cumulus updraft mass flux at the top interface is not zero according to the !
2728 : ! vertical tendency equation of cumulus mass flux. Ideally, cumulus updraft !
2729 : ! mass flux at the top interface should be zero for this case. In order to !
2730 : ! assures that cumulus updraft mass flux goes to zero when cumulus updraft !
2731 : ! vertical velocity goes to zero, we are imposing self-detrainment term as !
2732 : ! below by considering layer-mean cloud buoyancy and cumulus updraft vertical !
2733 : ! velocity square at the top interface. Use of auto-detrainment term will be !
2734 : ! determined by setting 'use_self_detrain=.true.' in the parameter sentence. !
2735 : ! --------------------------------------------------------------------------- !
2736 :
2737 : if( use_self_detrain ) then
2738 : autodet = min( 0.5_r8*g*(bogbot+bogtop)/(max(wtw,0._r8)+1.e-4_r8), 0._r8 )
2739 : umf(k) = umf(k) * exp( 0.637_r8*(dpe/rho0j/g) * autodet )
2740 : end if
2741 0 : if( umf(k) .eq. 0._r8 ) wtw = -1._r8
2742 :
2743 : ! -------------------------------------- !
2744 : ! Below block is just a dignostic output !
2745 : ! -------------------------------------- !
2746 :
2747 0 : excessu_arr(k) = excessu
2748 0 : excess0_arr(k) = excess0
2749 0 : xc_arr(k) = xc
2750 0 : aquad_arr(k) = aquad
2751 0 : bquad_arr(k) = bquad
2752 0 : cquad_arr(K) = cquad
2753 0 : bogbot_arr(k) = bogbot
2754 0 : bogtop_arr(k) = bogtop
2755 :
2756 : ! ------------------------------------------------------------------- !
2757 : ! 'kbup' is the upper most layer in which cloud buoyancy is positive !
2758 : ! both at the base and top interface. 'kpen' is the upper most layer !
2759 : ! up to cumulus can reach. Usually, 'kpen' is located higher than the !
2760 : ! 'kbup'. Note we initialized these by 'kbup = krel' & 'kpen = krel'. !
2761 : ! As explained before, it is possible that only 'kpen' is updated, !
2762 : ! while 'kbup' keeps its initialization value. For this case, current !
2763 : ! scheme will simply turns-off penetrative entrainment fluxes and use !
2764 : ! normal buoyancy-sorting fluxes for 'kbup <= k <= kpen-1' interfaces,!
2765 : ! in order to describe shallow continental cumulus convection. !
2766 : ! ------------------------------------------------------------------- !
2767 :
2768 : ! if( bogbot .gt. 0._r8 .and. bogtop .gt. 0._r8 ) then
2769 : ! if( bogtop .gt. 0._r8 ) then
2770 0 : if( bogtop .gt. 0._r8 .and. wtw .gt. 0._r8 ) then
2771 0 : kbup = k
2772 : end if
2773 :
2774 0 : if( wtw .le. 0._r8 ) then
2775 : kpen = k
2776 : go to 45
2777 : end if
2778 :
2779 0 : wu(k) = sqrt(wtw)
2780 0 : if( wu(k) .gt. 100._r8 ) then
2781 0 : exit_wu(i) = 1._r8
2782 0 : id_exit = .true.
2783 0 : go to 333
2784 : endif
2785 :
2786 : ! ---------------------------------------------------------------------------- !
2787 : ! Iteration end due to 'rmaxfrac' constraint [ ***************************** ] !
2788 : ! ---------------------------------------------------------------------------- !
2789 :
2790 : ! ---------------------------------------------------------------------- !
2791 : ! Calculate updraft fractional area at the upper interface and set upper !
2792 : ! limit to 'ufrc' by 'rmaxfrac'. In order to keep the consistency among !
2793 : ! ['ufrc','umf','wu (or wtw)'], if ufrc is limited by 'rmaxfrac', either !
2794 : ! 'umf' or 'wu' should be changed. Although both 'umf' and 'wu (wtw)' at !
2795 : ! the current upper interface are used for updating 'umf' & 'wu' at the !
2796 : ! next upper interface, 'umf' is a passive variable not influencing the !
2797 : ! buoyancy sorting process in contrast to 'wtw'. This is a reason why we !
2798 : ! adjusted 'umf' instead of 'wtw'. In turn we updated 'fdr' here instead !
2799 : ! of 'fer', which guarantees that all previously updated thermodynamic !
2800 : ! variables at the upper interface before applying 'rmaxfrac' constraint !
2801 : ! are already internally consistent, even though 'ufrc' is limited by !
2802 : ! 'rmaxfrac'. Thus, we don't need to go through interation loop again.If !
2803 : ! If we update 'fer' however, we should go through above iteration loop. !
2804 : ! ---------------------------------------------------------------------- !
2805 :
2806 0 : rhos0j = ps0(k) / ( r * 0.5_r8 * ( thv0bot(k+1) + thv0top(k) ) * exns0(k) )
2807 0 : ufrc(k) = umf(k) / ( rhos0j * wu(k) )
2808 0 : if( ufrc(k) .gt. rmaxfrac ) then
2809 0 : limit_ufrc(i) = 1._r8
2810 0 : ufrc(k) = rmaxfrac
2811 0 : umf(k) = rmaxfrac * rhos0j * wu(k)
2812 0 : fdr(k) = fer(k) - log( umf(k) / umf(km1) ) / dpe
2813 : endif
2814 :
2815 : ! ------------------------------------------------------------ !
2816 : ! Update environmental properties for at the mid-point of next !
2817 : ! upper layer for use in buoyancy sorting. !
2818 : ! ------------------------------------------------------------ !
2819 :
2820 0 : pe = p0(k+1)
2821 0 : dpe = dp0(k+1)
2822 0 : exne = exn0(k+1)
2823 0 : thvebot = thv0bot(k+1)
2824 0 : thle = thl0(k+1)
2825 0 : qte = qt0(k+1)
2826 0 : ue = u0(k+1)
2827 0 : ve = v0(k+1)
2828 0 : do m = 1, ncnst
2829 0 : tre(m) = tr0(k+1,m)
2830 : enddo
2831 :
2832 : end do ! End of cumulus updraft loop from the 'krel' layer to 'kpen' layer.
2833 :
2834 : ! ------------------------------------------------------------------------------- !
2835 : ! Up to this point, we finished all of buoyancy sorting processes from the 'krel' !
2836 : ! layer to 'kpen' layer: at the top interface of individual layers, we calculated !
2837 : ! updraft and penetrative mass fluxes [ umf(k) & emf(k) = 0 ], updraft fractional !
2838 : ! area [ ufrc(k) ], updraft vertical velocity [ wu(k) ], updraft thermodynamic !
2839 : ! variables [thlu(k),qtu(k),uu(k),vu(k),thvu(k)]. In the layer,we also calculated !
2840 : ! fractional entrainment-detrainment rate [ fer(k), fdr(k) ], and detrainment ten !
2841 : ! dency of water and ice from cumulus updraft [ dwten(k), diten(k) ]. In addition,!
2842 : ! we updated and identified 'krel' and 'kpen' layer index, if any. In the 'kpen' !
2843 : ! layer, we calculated everything mentioned above except the 'wu(k)' and 'ufrc(k)'!
2844 : ! since a real value of updraft vertical velocity is not defined at the kpen top !
2845 : ! interface (note 'ufrc' at the top interface of layer is calculated from 'umf(k)'!
2846 : ! and 'wu(k)'). As mentioned before, special treatment is required when 'kbup' is !
2847 : ! not updated and so 'kbup = krel'. !
2848 : ! ------------------------------------------------------------------------------- !
2849 :
2850 : ! ------------------------------------------------------------------------------ !
2851 : ! During the 'iter_scaleh' iteration loop, non-physical ( with non-zero values ) !
2852 : ! values can remain in the variable arrays above (also 'including' in case of wu !
2853 : ! and ufrc at the top interface) the 'kpen' layer. This can happen when the kpen !
2854 : ! layer index identified from the 'iter_scaleh = 1' iteration loop is located at !
2855 : ! above the kpen layer index identified from 'iter_scaleh = 3' iteration loop. !
2856 : ! Thus, in the following calculations, we should only use the values in each !
2857 : ! variables only up to finally identified 'kpen' layer & 'kpen' interface except !
2858 : ! 'wu' and 'ufrc' at the top interface of 'kpen' layer. Note that in order to !
2859 : ! prevent any problems due to these non-physical values, I re-initialized the !
2860 : ! values of [ umf(kpen:mkx), emf(kpen:mkx), dwten(kpen+1:mkx), diten(kpen+1:mkx),!
2861 : ! fer(kpen:mkx), fdr(kpen+1:mkx), ufrc(kpen:mkx) ] to be zero after 'iter_scaleh'!
2862 : ! do loop. !
2863 : ! ------------------------------------------------------------------------------ !
2864 :
2865 : 45 continue
2866 :
2867 : ! ------------------------------------------------------------------------------ !
2868 : ! Calculate 'ppen( < 0 )', updarft penetrative distance from the lower interface !
2869 : ! of 'kpen' layer. Note that bogbot & bogtop at the 'kpen' layer either when fer !
2870 : ! is zero or non-zero was already calculated above. !
2871 : ! It seems that below qudarature solving formula is valid only when bogbot < 0. !
2872 : ! Below solving equation is clearly wrong ! I should revise this ! !
2873 : ! ------------------------------------------------------------------------------ !
2874 :
2875 0 : if( drage .eq. 0._r8 ) then
2876 0 : aquad = ( bogtop - bogbot ) / ( ps0(kpen) - ps0(kpen-1) )
2877 0 : bquad = 2._r8 * bogbot
2878 0 : cquad = -wu(kpen-1)**2 * rho0j
2879 0 : call roots(aquad,bquad,cquad,xc1,xc2,status)
2880 0 : if( status .eq. 0 ) then
2881 0 : if( xc1 .le. 0._r8 .and. xc2 .le. 0._r8 ) then
2882 0 : ppen = max( xc1, xc2 )
2883 0 : ppen = min( 0._r8,max( -dp0(kpen), ppen ) )
2884 0 : elseif( xc1 .gt. 0._r8 .and. xc2 .gt. 0._r8 ) then
2885 0 : ppen = -dp0(kpen)
2886 0 : write(iulog,*) 'Warning : UW-Cumulus penetrates upto kpen interface'
2887 : else
2888 0 : ppen = min( xc1, xc2 )
2889 0 : ppen = min( 0._r8,max( -dp0(kpen), ppen ) )
2890 : endif
2891 : else
2892 0 : ppen = -dp0(kpen)
2893 0 : write(iulog,*) 'Warning : UW-Cumulus penetrates upto kpen interface'
2894 : endif
2895 : else
2896 0 : ppen = compute_ppen(wtwb,drage,bogbot,bogtop,rho0j,dp0(kpen))
2897 : endif
2898 0 : if( ppen .eq. -dp0(kpen) .or. ppen .eq. 0._r8 ) limit_ppen(i) = 1._r8
2899 :
2900 : ! -------------------------------------------------------------------- !
2901 : ! Re-calculate the amount of expelled condensate from cloud updraft !
2902 : ! at the cumulus top. This is necessary for refined calculations of !
2903 : ! bulk cloud microphysics at the cumulus top. Note that ppen < 0._r8 !
2904 : ! In the below, I explicitly calculate 'thlu_top' & 'qtu_top' by !
2905 : ! using non-zero 'fer(kpen)'. !
2906 : ! -------------------------------------------------------------------- !
2907 :
2908 0 : if( fer(kpen)*(-ppen) .lt. 1.e-4_r8 ) then
2909 0 : thlu_top = thlu(kpen-1) + ( thl0(kpen) + ssthl0(kpen) * (-ppen) / 2._r8 - thlu(kpen-1) ) * fer(kpen) * (-ppen)
2910 0 : qtu_top = qtu(kpen-1) + ( qt0(kpen) + ssqt0(kpen) * (-ppen) / 2._r8 - qtu(kpen-1) ) * fer(kpen) * (-ppen)
2911 : else
2912 : thlu_top = ( thl0(kpen) + ssthl0(kpen) / fer(kpen) - ssthl0(kpen) * (-ppen) / 2._r8 ) - &
2913 0 : ( thl0(kpen) + ssthl0(kpen) * (-ppen) / 2._r8 - thlu(kpen-1) + ssthl0(kpen) / fer(kpen) ) &
2914 0 : * exp(-fer(kpen) * (-ppen))
2915 : qtu_top = ( qt0(kpen) + ssqt0(kpen) / fer(kpen) - ssqt0(kpen) * (-ppen) / 2._r8 ) - &
2916 : ( qt0(kpen) + ssqt0(kpen) * (-ppen) / 2._r8 - qtu(kpen-1) + ssqt0(kpen) / fer(kpen) ) &
2917 0 : * exp(-fer(kpen) * (-ppen))
2918 : end if
2919 :
2920 0 : call conden(ps0(kpen-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check)
2921 0 : if( id_check .eq. 1 ) then
2922 0 : exit_conden(i) = 1._r8
2923 0 : id_exit = .true.
2924 0 : go to 333
2925 : end if
2926 0 : exntop = ((ps0(kpen-1)+ppen)/p00)**rovcp
2927 0 : if( (qlj + qij) .gt. criqc ) then
2928 0 : dwten(kpen) = ( ( qlj + qij ) - criqc ) * qlj / ( qlj + qij )
2929 0 : diten(kpen) = ( ( qlj + qij ) - criqc ) * qij / ( qlj + qij )
2930 0 : qtu_top = qtu_top - dwten(kpen) - diten(kpen)
2931 0 : thlu_top = thlu_top + (xlv/cp/exntop)*dwten(kpen) + (xls/cp/exntop)*diten(kpen)
2932 : else
2933 0 : dwten(kpen) = 0._r8
2934 0 : diten(kpen) = 0._r8
2935 : endif
2936 :
2937 : ! ----------------------------------------------------------------------- !
2938 : ! Calculate cumulus scale height as the top height that cumulus can reach.!
2939 : ! ----------------------------------------------------------------------- !
2940 :
2941 0 : rhos0j = ps0(kpen-1)/(r*0.5_r8*(thv0bot(kpen)+thv0top(kpen-1))*exns0(kpen-1))
2942 0 : cush = zs0(kpen-1) - ppen/rhos0j/g
2943 0 : scaleh = cush
2944 :
2945 : end do ! End of 'iter_scaleh' loop.
2946 :
2947 : ! -------------------------------------------------------------------- !
2948 : ! The 'forcedCu' is logical identifier saying whether cumulus updraft !
2949 : ! overcome the buoyancy barrier just above the PBL top. If it is true, !
2950 : ! cumulus did not overcome the barrier - this is a shallow convection !
2951 : ! with negative cloud buoyancy, mimicking shallow continental cumulus !
2952 : ! convection. Depending on 'forcedCu' parameter, treatment of heat & !
2953 : ! moisture fluxes at the entraining interfaces, 'kbup <= k < kpen - 1' !
2954 : ! will be set up in a different ways, as will be shown later. !
2955 : ! -------------------------------------------------------------------- !
2956 :
2957 0 : if( kbup .eq. krel ) then
2958 0 : forcedCu = .true.
2959 0 : limit_shcu(i) = 1._r8
2960 : else
2961 0 : forcedCu = .false.
2962 0 : limit_shcu(i) = 0._r8
2963 : endif
2964 :
2965 : ! ------------------------------------------------------------------ !
2966 : ! Filtering of unerasonable cumulus adjustment here. This is a very !
2967 : ! important process which should be done cautiously. Various ways of !
2968 : ! filtering are possible depending on cases mainly using the indices !
2969 : ! of key layers - 'klcl','kinv','krel','klfc','kbup','kpen'. At this !
2970 : ! stage, the followings are all possible : 'kinv >= 2', 'klcl >= 1', !
2971 : ! 'krel >= kinv', 'kbup >= krel', 'kpen >= krel'. I must design this !
2972 : ! filtering very cautiously, in such that none of realistic cumulus !
2973 : ! convection is arbitrarily turned-off. Potentially, I might turn-off!
2974 : ! cumulus convection if layer-mean 'ql > 0' in the 'kinv-1' layer,in !
2975 : ! order to suppress cumulus convection growing, based at the Sc top. !
2976 : ! This is one of potential future modifications. Note that ppen < 0. !
2977 : ! ------------------------------------------------------------------ !
2978 :
2979 0 : cldhgt = ps0(kpen-1) + ppen
2980 0 : if( forcedCu ) then
2981 : ! write(iulog,*) 'forcedCu - did not overcome initial buoyancy barrier'
2982 0 : exit_cufilter(i) = 1._r8
2983 0 : id_exit = .true.
2984 0 : go to 333
2985 : end if
2986 : ! Limit 'additional shallow cumulus' for DYCOMS simulation.
2987 : ! if( cldhgt.ge.88000._r8 ) then
2988 : ! id_exit = .true.
2989 : ! go to 333
2990 : ! end if
2991 :
2992 : ! ------------------------------------------------------------------------------ !
2993 : ! Re-initializing some key variables above the 'kpen' layer in order to suppress !
2994 : ! the influence of non-physical values above 'kpen', in association with the use !
2995 : ! of 'iter_scaleh' loop. Note that umf, emf, ufrc are defined at the interfaces !
2996 : ! (0:mkx), while 'dwten','diten', 'fer', 'fdr' are defined at layer mid-points. !
2997 : ! Initialization of 'fer' and 'fdr' is for correct writing purpose of diagnostic !
2998 : ! output. Note that we set umf(kpen)=emf(kpen)=ufrc(kpen)=0, in consistent with !
2999 : ! wtw < 0 at the top interface of 'kpen' layer. However, we still have non-zero !
3000 : ! expelled cloud condensate in the 'kpen' layer. !
3001 : ! ------------------------------------------------------------------------------ !
3002 :
3003 0 : umf(kpen:mkx) = 0._r8
3004 0 : emf(kpen:mkx) = 0._r8
3005 0 : ufrc(kpen:mkx) = 0._r8
3006 0 : dwten(kpen+1:mkx) = 0._r8
3007 0 : diten(kpen+1:mkx) = 0._r8
3008 0 : fer(kpen+1:mkx) = 0._r8
3009 0 : fdr(kpen+1:mkx) = 0._r8
3010 :
3011 : ! ------------------------------------------------------------------------ !
3012 : ! Calculate downward penetrative entrainment mass flux, 'emf(k) < 0', and !
3013 : ! thermodynamic properties of penetratively entrained airs at entraining !
3014 : ! interfaces. emf(k) is defined from the top interface of the layer kbup !
3015 : ! to the bottom interface of the layer 'kpen'. Note even when kbup = krel,!
3016 : ! i.e.,even when 'kbup' was not updated in the above buoyancy sorting do !
3017 : ! loop (i.e., 'kbup' remains as the initialization value), below do loop !
3018 : ! of penetrative entrainment flux can be performed without any conceptual !
3019 : ! or logical problems, because we have already computed all the variables !
3020 : ! necessary for performing below penetrative entrainment block. !
3021 : ! In the below 'do' loop, 'k' is an interface index at which non-zero 'emf'!
3022 : ! (penetrative entrainment mass flux) is calculated. Since cumulus updraft !
3023 : ! is negatively buoyant in the layers between the top interface of 'kbup' !
3024 : ! layer (interface index, kbup) and the top interface of 'kpen' layer, the !
3025 : ! fractional lateral entrainment, fer(k) within these layers will be close !
3026 : ! to zero - so it is likely that only strong lateral detrainment occurs in !
3027 : ! thses layers. Under this situation,we can easily calculate the amount of !
3028 : ! detrainment cumulus air into these negatively buoyanct layers by simply !
3029 : ! comparing cumulus updraft mass fluxes between the base and top interface !
3030 : ! of each layer: emf(k) = emf(k-1)*exp(-fdr(k)*dp0(k)) !
3031 : ! ~ emf(k-1)*(1-rei(k)*dp0(k)) !
3032 : ! emf(k-1)-emf(k) ~ emf(k-1)*rei(k)*dp0(k) !
3033 : ! Current code assumes that about 'rpen~10' times of these detrained mass !
3034 : ! are penetratively re-entrained down into the 'k-1' interface. And all of !
3035 : ! these detrained masses are finally dumped down into the top interface of !
3036 : ! 'kbup' layer. Thus, the amount of penetratively entrained air across the !
3037 : ! top interface of 'kbup' layer with 'rpen~10' becomes too large. !
3038 : ! Note that this penetrative entrainment part can be completely turned-off !
3039 : ! and we can simply use normal buoyancy-sorting involved turbulent fluxes !
3040 : ! by modifying 'penetrative entrainment fluxes' part below. !
3041 : ! ------------------------------------------------------------------------ !
3042 :
3043 : ! -----------------------------------------------------------------------!
3044 : ! Calculate entrainment mass flux and conservative scalars of entraining !
3045 : ! free air at interfaces of 'kbup <= k < kpen - 1' !
3046 : ! ---------------------------------------------------------------------- !
3047 :
3048 0 : do k = 0, mkx
3049 0 : thlu_emf(k) = thlu(k)
3050 0 : qtu_emf(k) = qtu(k)
3051 0 : uu_emf(k) = uu(k)
3052 0 : vu_emf(k) = vu(k)
3053 0 : do m = 1, ncnst
3054 0 : tru_emf(k,m) = tru(k,m)
3055 : enddo
3056 : end do
3057 :
3058 0 : do k = kpen - 1, kbup, -1 ! Here, 'k' is an interface index at which
3059 : ! penetrative entrainment fluxes are calculated.
3060 :
3061 0 : rhos0j = ps0(k) / ( r * 0.5_r8 * ( thv0bot(k+1) + thv0top(k) ) * exns0(k) )
3062 :
3063 0 : if( k .eq. kpen - 1 ) then
3064 :
3065 : ! ------------------------------------------------------------------------ !
3066 : ! Note that 'ppen' has already been calculated in the above 'iter_scaleh' !
3067 : ! loop assuming zero lateral entrainmentin the layer 'kpen'. !
3068 : ! ------------------------------------------------------------------------ !
3069 :
3070 : ! -------------------------------------------------------------------- !
3071 : ! Calculate returning mass flux, emf ( < 0 ) !
3072 : ! Current penetrative entrainment rate with 'rpen~10' is too large and !
3073 : ! future refinement is necessary including the definition of 'thl','qt'!
3074 : ! of penetratively entrained air. Penetratively entrained airs across !
3075 : ! the 'kpen-1' interface is assumed to have the properties of the base !
3076 : ! interface of 'kpen' layer. Note that 'emf ~ - umf/ufrc = - w * rho'. !
3077 : ! Thus, below limit sets an upper limit of |emf| to be ~ 10cm/s, which !
3078 : ! is very loose constraint. Here, I used more restricted constraint on !
3079 : ! the limit of emf, assuming 'emf' cannot exceed a net mass within the !
3080 : ! layer above the interface. Similar to the case of warming and drying !
3081 : ! due to cumulus updraft induced compensating subsidence, penetrative !
3082 : ! entrainment induces compensating upwelling - in order to prevent !
3083 : ! numerical instability in association with compensating upwelling, we !
3084 : ! should similarily limit the amount of penetrative entrainment at the !
3085 : ! interface by the amount of masses within the layer just above the !
3086 : ! penetratively entraining interface. !
3087 : ! -------------------------------------------------------------------- !
3088 :
3089 0 : if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.1_r8*rhos0j ) limit_emf(i) = 1._r8
3090 0 : if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.9_r8*dp0(kpen)/g/dt ) limit_emf(i) = 1._r8
3091 :
3092 0 : emf(k) = max( max( umf(k)*ppen*rei(kpen)*rpen, -0.1_r8*rhos0j), -0.9_r8*dp0(kpen)/g/dt)
3093 0 : thlu_emf(k) = thl0(kpen) + ssthl0(kpen) * ( ps0(k) - p0(kpen) )
3094 0 : qtu_emf(k) = qt0(kpen) + ssqt0(kpen) * ( ps0(k) - p0(kpen) )
3095 0 : uu_emf(k) = u0(kpen) + ssu0(kpen) * ( ps0(k) - p0(kpen) )
3096 0 : vu_emf(k) = v0(kpen) + ssv0(kpen) * ( ps0(k) - p0(kpen) )
3097 0 : do m = 1, ncnst
3098 0 : tru_emf(k,m) = tr0(kpen,m) + sstr0(kpen,m) * ( ps0(k) - p0(kpen) )
3099 : enddo
3100 :
3101 : else ! if(k.lt.kpen-1).
3102 :
3103 : ! --------------------------------------------------------------------------- !
3104 : ! Note we are coming down from the higher interfaces to the lower interfaces. !
3105 : ! Also note that 'emf < 0'. So, below operation is a summing not subtracting. !
3106 : ! In order to ensure numerical stability, I imposed a modified correct limit !
3107 : ! of '-0.9*dp0(k+1)/g/dt' on emf(k). !
3108 : ! --------------------------------------------------------------------------- !
3109 :
3110 : if( use_cumpenent ) then ! Original Cumulative Penetrative Entrainment
3111 :
3112 0 : if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1_r8*rhos0j ) limit_emf(i) = 1
3113 0 : if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9_r8*dp0(k+1)/g/dt ) limit_emf(i) = 1
3114 0 : emf(k) = max(max(emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen, -0.1_r8*rhos0j), -0.9_r8*dp0(k+1)/g/dt )
3115 0 : if( abs(emf(k)) .gt. abs(emf(k+1)) ) then
3116 0 : thlu_emf(k) = ( thlu_emf(k+1) * emf(k+1) + thl0(k+1) * ( emf(k) - emf(k+1) ) ) / emf(k)
3117 0 : qtu_emf(k) = ( qtu_emf(k+1) * emf(k+1) + qt0(k+1) * ( emf(k) - emf(k+1) ) ) / emf(k)
3118 0 : uu_emf(k) = ( uu_emf(k+1) * emf(k+1) + u0(k+1) * ( emf(k) - emf(k+1) ) ) / emf(k)
3119 0 : vu_emf(k) = ( vu_emf(k+1) * emf(k+1) + v0(k+1) * ( emf(k) - emf(k+1) ) ) / emf(k)
3120 0 : do m = 1, ncnst
3121 0 : tru_emf(k,m) = ( tru_emf(k+1,m) * emf(k+1) + tr0(k+1,m) * ( emf(k) - emf(k+1) ) ) / emf(k)
3122 : enddo
3123 : else
3124 0 : thlu_emf(k) = thl0(k+1)
3125 0 : qtu_emf(k) = qt0(k+1)
3126 0 : uu_emf(k) = u0(k+1)
3127 0 : vu_emf(k) = v0(k+1)
3128 0 : do m = 1, ncnst
3129 0 : tru_emf(k,m) = tr0(k+1,m)
3130 : enddo
3131 : endif
3132 :
3133 : else ! Alternative Non-Cumulative Penetrative Entrainment
3134 :
3135 : if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1_r8*rhos0j ) limit_emf(i) = 1
3136 : if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9_r8*dp0(k+1)/g/dt ) limit_emf(i) = 1
3137 : emf(k) = max(max(-umf(k)*dp0(k+1)*rei(k+1)*rpen, -0.1_r8*rhos0j), -0.9_r8*dp0(k+1)/g/dt )
3138 : thlu_emf(k) = thl0(k+1)
3139 : qtu_emf(k) = qt0(k+1)
3140 : uu_emf(k) = u0(k+1)
3141 : vu_emf(k) = v0(k+1)
3142 : do m = 1, ncnst
3143 : tru_emf(k,m) = tr0(k+1,m)
3144 : enddo
3145 :
3146 : endif
3147 :
3148 : endif
3149 :
3150 : ! ---------------------------------------------------------------------------- !
3151 : ! In this GCM modeling framework, all what we should do is to calculate heat !
3152 : ! and moisture fluxes at the given geometrically-fixed height interfaces - we !
3153 : ! don't need to worry about movement of material height surface in association !
3154 : ! with compensating subsidence or unwelling, in contrast to the bulk modeling. !
3155 : ! In this geometrically fixed height coordinate system, heat and moisture flux !
3156 : ! at the geometrically fixed height handle everything - a movement of material !
3157 : ! surface is implicitly treated automatically. Note that in terms of turbulent !
3158 : ! heat and moisture fluxes at model interfaces, both the cumulus updraft mass !
3159 : ! flux and penetratively entraining mass flux play the same role -both of them !
3160 : ! warms and dries the 'kbup' layer, cools and moistens the 'kpen' layer, and !
3161 : ! cools and moistens any intervening layers between 'kbup' and 'kpen' layers. !
3162 : ! It is important to note these identical roles on turbulent heat and moisture !
3163 : ! fluxes of 'umf' and 'emf'. !
3164 : ! When 'kbup' is a stratocumulus-topped PBL top interface, increase of 'rpen' !
3165 : ! is likely to strongly diffuse stratocumulus top interface, resulting in the !
3166 : ! reduction of cloud fraction. In this sense, the 'kbup' interface has a very !
3167 : ! important meaning and role : across the 'kbup' interface, strong penetrative !
3168 : ! entrainment occurs, thus any sharp gradient properties across that interface !
3169 : ! are easily diffused through strong mass exchange. Thus, an initialization of !
3170 : ! 'kbup' (and also 'kpen') should be done very cautiously as mentioned before. !
3171 : ! In order to prevent this stron diffusion for the shallow cumulus convection !
3172 : ! based at the Sc top, it seems to be good to initialize 'kbup = krel', rather !
3173 : ! that 'kbup = krel-1'. !
3174 : ! ---------------------------------------------------------------------------- !
3175 :
3176 : end do
3177 :
3178 : !------------------------------------------------------------------ !
3179 : ! !
3180 : ! Compute turbulent heat, moisture, momentum flux at all interfaces !
3181 : ! !
3182 : !------------------------------------------------------------------ !
3183 : ! It is very important to note that in calculating turbulent fluxes !
3184 : ! below, we must not double count turbulent flux at any interefaces.!
3185 : ! In the below, turbulent fluxes at the interfaces (interface index !
3186 : ! k) are calculated by the following 4 blocks in consecutive order: !
3187 : ! !
3188 : ! (1) " 0 <= k <= kinv - 1 " : PBL fluxes. !
3189 : ! From 'fluxbelowinv' using reconstructed PBL height. Currently,!
3190 : ! the reconstructed PBLs are independently calculated for each !
3191 : ! individual conservative scalar variables ( qt, thl, u, v ) in !
3192 : ! each 'fluxbelowinv', instead of being uniquely calculated by !
3193 : ! using thvl. Turbulent flux at the surface is assumed to be 0. !
3194 : ! (2) " kinv <= k <= krel - 1 " : Non-buoyancy sorting fluxes !
3195 : ! Assuming cumulus mass flux and cumulus updraft thermodynamic !
3196 : ! properties (except u, v which are modified by the PGFc during !
3197 : ! upward motion) are conserved during a updraft motion from the !
3198 : ! PBL top interface to the release level. If these layers don't !
3199 : ! exist (e,g, when 'krel = kinv'), then current routine do not !
3200 : ! perform this routine automatically. So I don't need to modify !
3201 : ! anything. !
3202 : ! (3) " krel <= k <= kbup - 1 " : Buoyancy sorting fluxes !
3203 : ! From laterally entraining-detraining buoyancy sorting plumes. !
3204 : ! (4) " kbup <= k < kpen-1 " : Penetrative entrainment fluxes !
3205 : ! From penetratively entraining plumes, !
3206 : ! !
3207 : ! In case of normal situation, turbulent interfaces in each groups !
3208 : ! are mutually independent of each other. Thus double flux counting !
3209 : ! or ambiguous flux counting requiring the choice among the above 4 !
3210 : ! groups do not occur normally. However, in case that cumulus plume !
3211 : ! could not completely overcome the buoyancy barrier just above the !
3212 : ! PBL top interface and so 'kbup = krel' (.forcedCu=.true.) ( here, !
3213 : ! it can be either 'kpen = krel' as the initialization, or ' kpen > !
3214 : ! krel' if cumulus updraft just penetrated over the top of release !
3215 : ! layer ). If this happens, we should be very careful in organizing !
3216 : ! the sequence of the 4 calculation routines above - note that the !
3217 : ! routine located at the later has the higher priority. Additional !
3218 : ! feature I must consider is that when 'kbup = kinv - 1' (this is a !
3219 : ! combined situation of 'kbup=krel-1' & 'krel = kinv' when I chose !
3220 : ! 'kbup=krel-1' instead of current choice of 'kbup=krel'), a strong !
3221 : ! penetrative entrainment fluxes exists at the PBL top interface, & !
3222 : ! all of these fluxes are concentrated (deposited) within the layer !
3223 : ! just below PBL top interface (i.e., 'kinv-1' layer). On the other !
3224 : ! hand, in case of 'fluxbelowinv', only the compensating subsidence !
3225 : ! effect is concentrated in the 'kinv-1' layer and 'pure' turbulent !
3226 : ! heat and moisture fluxes ( 'pure' means the fluxes not associated !
3227 : ! with compensating subsidence) are linearly distributed throughout !
3228 : ! the whole PBL. Thus different choice of the above flux groups can !
3229 : ! produce very different results. Output variable should be written !
3230 : ! consistently to the choice of computation sequences. !
3231 : ! When the case of 'kbup = krel(-1)' happens,another way to dealing !
3232 : ! with this case is to simply ' exit ' the whole cumulus convection !
3233 : ! calculation without performing any cumulus convection. We can !
3234 : ! choose this approach by specifying a condition in the 'Filtering !
3235 : ! of unreasonable cumulus adjustment' just after 'iter_scaleh'. But !
3236 : ! this seems not to be a good choice (although this choice was used !
3237 : ! previous code ), since it might arbitrary damped-out the shallow !
3238 : ! cumulus convection over the continent land, where shallow cumulus !
3239 : ! convection tends to be negatively buoyant. !
3240 : ! ----------------------------------------------------------------- !
3241 :
3242 : ! --------------------------------------------------- !
3243 : ! 1. PBL fluxes : 0 <= k <= kinv - 1 !
3244 : ! All the information necessary to reconstruct PBL !
3245 : ! height are passed to 'fluxbelowinv'. !
3246 : ! --------------------------------------------------- !
3247 :
3248 0 : xsrc = qtsrc
3249 0 : xmean = qt0(kinv)
3250 0 : xtop = qt0(kinv+1) + ssqt0(kinv+1) * ( ps0(kinv) - p0(kinv+1) )
3251 0 : xbot = qt0(kinv-1) + ssqt0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )
3252 0 : call fluxbelowinv( cbmf, ps0(0:mkx), mkx, kinv, dt, xsrc, xmean, xtop, xbot, xflx )
3253 0 : qtflx(0:kinv-1) = xflx(0:kinv-1)
3254 :
3255 0 : xsrc = thlsrc
3256 0 : xmean = thl0(kinv)
3257 0 : xtop = thl0(kinv+1) + ssthl0(kinv+1) * ( ps0(kinv) - p0(kinv+1) )
3258 0 : xbot = thl0(kinv-1) + ssthl0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )
3259 0 : call fluxbelowinv( cbmf, ps0(0:mkx), mkx, kinv, dt, xsrc, xmean, xtop, xbot, xflx )
3260 0 : slflx(0:kinv-1) = cp * exns0(0:kinv-1) * xflx(0:kinv-1)
3261 :
3262 0 : xsrc = usrc
3263 0 : xmean = u0(kinv)
3264 0 : xtop = u0(kinv+1) + ssu0(kinv+1) * ( ps0(kinv) - p0(kinv+1) )
3265 0 : xbot = u0(kinv-1) + ssu0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )
3266 0 : call fluxbelowinv( cbmf, ps0(0:mkx), mkx, kinv, dt, xsrc, xmean, xtop, xbot, xflx )
3267 0 : uflx(0:kinv-1) = xflx(0:kinv-1)
3268 :
3269 0 : xsrc = vsrc
3270 0 : xmean = v0(kinv)
3271 0 : xtop = v0(kinv+1) + ssv0(kinv+1) * ( ps0(kinv) - p0(kinv+1) )
3272 0 : xbot = v0(kinv-1) + ssv0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )
3273 0 : call fluxbelowinv( cbmf, ps0(0:mkx), mkx, kinv, dt, xsrc, xmean, xtop, xbot, xflx )
3274 0 : vflx(0:kinv-1) = xflx(0:kinv-1)
3275 :
3276 0 : do m = 1, ncnst
3277 0 : xsrc = trsrc(m)
3278 0 : xmean = tr0(kinv,m)
3279 0 : xtop = tr0(kinv+1,m) + sstr0(kinv+1,m) * ( ps0(kinv) - p0(kinv+1) )
3280 0 : xbot = tr0(kinv-1,m) + sstr0(kinv-1,m) * ( ps0(kinv-1) - p0(kinv-1) )
3281 0 : call fluxbelowinv( cbmf, ps0(0:mkx), mkx, kinv, dt, xsrc, xmean, xtop, xbot, xflx )
3282 0 : trflx(0:kinv-1,m) = xflx(0:kinv-1)
3283 : enddo
3284 :
3285 : ! -------------------------------------------------------------- !
3286 : ! 2. Non-buoyancy sorting fluxes : kinv <= k <= krel - 1 !
3287 : ! Note that when 'krel = kinv', below block is never executed !
3288 : ! as in a desirable, expected way ( but I must check if this !
3289 : ! is the case ). The non-buoyancy sorting fluxes are computed !
3290 : ! only when 'krel > kinv'. !
3291 : ! -------------------------------------------------------------- !
3292 :
3293 0 : uplus = 0._r8
3294 0 : vplus = 0._r8
3295 0 : do k = kinv, krel - 1
3296 0 : kp1 = k + 1
3297 0 : qtflx(k) = cbmf * ( qtsrc - ( qt0(kp1) + ssqt0(kp1) * ( ps0(k) - p0(kp1) ) ) )
3298 0 : slflx(k) = cbmf * ( thlsrc - ( thl0(kp1) + ssthl0(kp1) * ( ps0(k) - p0(kp1) ) ) ) * cp * exns0(k)
3299 0 : uplus = uplus + PGFc * ssu0(k) * ( ps0(k) - ps0(k-1) )
3300 0 : vplus = vplus + PGFc * ssv0(k) * ( ps0(k) - ps0(k-1) )
3301 0 : uflx(k) = cbmf * ( usrc + uplus - ( u0(kp1) + ssu0(kp1) * ( ps0(k) - p0(kp1) ) ) )
3302 0 : vflx(k) = cbmf * ( vsrc + vplus - ( v0(kp1) + ssv0(kp1) * ( ps0(k) - p0(kp1) ) ) )
3303 0 : do m = 1, ncnst
3304 0 : trflx(k,m) = cbmf * ( trsrc(m) - ( tr0(kp1,m) + sstr0(kp1,m) * ( ps0(k) - p0(kp1) ) ) )
3305 : enddo
3306 : end do
3307 :
3308 : ! ------------------------------------------------------------------------ !
3309 : ! 3. Buoyancy sorting fluxes : krel <= k <= kbup - 1 !
3310 : ! In case that 'kbup = krel - 1 ' ( or even in case 'kbup = krel' ), !
3311 : ! buoyancy sorting fluxes are not calculated, which is consistent, !
3312 : ! desirable feature. !
3313 : ! ------------------------------------------------------------------------ !
3314 :
3315 0 : do k = krel, kbup - 1
3316 0 : kp1 = k + 1
3317 0 : slflx(k) = cp * exns0(k) * umf(k) * ( thlu(k) - ( thl0(kp1) + ssthl0(kp1) * ( ps0(k) - p0(kp1) ) ) )
3318 0 : qtflx(k) = umf(k) * ( qtu(k) - ( qt0(kp1) + ssqt0(kp1) * ( ps0(k) - p0(kp1) ) ) )
3319 0 : uflx(k) = umf(k) * ( uu(k) - ( u0(kp1) + ssu0(kp1) * ( ps0(k) - p0(kp1) ) ) )
3320 0 : vflx(k) = umf(k) * ( vu(k) - ( v0(kp1) + ssv0(kp1) * ( ps0(k) - p0(kp1) ) ) )
3321 0 : do m = 1, ncnst
3322 0 : trflx(k,m) = umf(k) * ( tru(k,m) - ( tr0(kp1,m) + sstr0(kp1,m) * ( ps0(k) - p0(kp1) ) ) )
3323 : enddo
3324 : end do
3325 :
3326 : ! ------------------------------------------------------------------------- !
3327 : ! 4. Penetrative entrainment fluxes : kbup <= k <= kpen - 1 !
3328 : ! The only confliction that can happen is when 'kbup = kinv-1'. For this !
3329 : ! case, turbulent flux at kinv-1 is calculated both from 'fluxbelowinv' !
3330 : ! and here as penetrative entrainment fluxes. Since penetrative flux is !
3331 : ! calculated later, flux at 'kinv - 1 ' will be that of penetrative flux.!
3332 : ! However, turbulent flux calculated at 'kinv - 1' from penetrative entr.!
3333 : ! is less attractable, since more reasonable turbulent flux at 'kinv-1' !
3334 : ! should be obtained from 'fluxbelowinv', by considering re-constructed !
3335 : ! inversion base height. This conflicting problem can be solved if we can!
3336 : ! initialize 'kbup = krel', instead of kbup = krel - 1. This choice seems!
3337 : ! to be more reasonable since it is not conflicted with 'fluxbelowinv' in!
3338 : ! calculating fluxes at 'kinv - 1' ( for this case, flux at 'kinv-1' is !
3339 : ! always from 'fluxbelowinv' ), and flux at 'krel-1' is calculated from !
3340 : ! the non-buoyancy sorting flux without being competed with penetrative !
3341 : ! entrainment fluxes. Even when we use normal cumulus flux instead of !
3342 : ! penetrative entrainment fluxes at 'kbup <= k <= kpen-1' interfaces, !
3343 : ! the initialization of kbup=krel perfectly works without any conceptual !
3344 : ! confliction. Thus it seems to be much better to choose 'kbup = krel' !
3345 : ! initialization of 'kbup', which is current choice. !
3346 : ! Note that below formula uses conventional updraft cumulus fluxes for !
3347 : ! shallow cumulus which did not overcome the first buoyancy barrier above!
3348 : ! PBL top while uses penetrative entrainment fluxes for the other cases !
3349 : ! 'kbup <= k <= kpen-1' interfaces. Depending on cases, however, I can !
3350 : ! selelct different choice. !
3351 : ! ------------------------------------------------------------------------------------------------------------------ !
3352 : ! if( forcedCu ) then !
3353 : ! slflx(k) = cp * exns0(k) * umf(k) * ( thlu(k) - ( thl0(kp1) + ssthl0(kp1) * ( ps0(k) - p0(kp1) ) ) ) !
3354 : ! qtflx(k) = umf(k) * ( qtu(k) - ( qt0(kp1) + ssqt0(kp1) * ( ps0(k) - p0(kp1) ) ) ) !
3355 : ! uflx(k) = umf(k) * ( uu(k) - ( u0(kp1) + ssu0(kp1) * ( ps0(k) - p0(kp1) ) ) ) !
3356 : ! vflx(k) = umf(k) * ( vu(k) - ( v0(kp1) + ssv0(kp1) * ( ps0(k) - p0(kp1) ) ) ) !
3357 : ! do m = 1, ncnst !
3358 : ! trflx(k,m) = umf(k) * ( tru(k,m) - ( tr0(kp1,m) + sstr0(kp1,m) * ( ps0(k) - p0(kp1) ) ) ) !
3359 : ! enddo !
3360 : ! else !
3361 : ! slflx(k) = cp * exns0(k) * emf(k) * ( thlu_emf(k) - ( thl0(k) + ssthl0(k) * ( ps0(k) - p0(k) ) ) ) !
3362 : ! qtflx(k) = emf(k) * ( qtu_emf(k) - ( qt0(k) + ssqt0(k) * ( ps0(k) - p0(k) ) ) ) !
3363 : ! uflx(k) = emf(k) * ( uu_emf(k) - ( u0(k) + ssu0(k) * ( ps0(k) - p0(k) ) ) ) !
3364 : ! vflx(k) = emf(k) * ( vu_emf(k) - ( v0(k) + ssv0(k) * ( ps0(k) - p0(k) ) ) ) !
3365 : ! do m = 1, ncnst !
3366 : ! trflx(k,m) = emf(k) * ( tru_emf(k,m) - ( tr0(k,m) + sstr0(k,m) * ( ps0(k) - p0(k) ) ) ) !
3367 : ! enddo !
3368 : ! endif !
3369 : ! !
3370 : ! if( use_uppenent ) then ! Combined Updraft + Penetrative Entrainment Flux !
3371 : ! slflx(k) = cp * exns0(k) * umf(k) * ( thlu(k) - ( thl0(kp1) + ssthl0(kp1) * ( ps0(k) - p0(kp1) ) ) ) + & !
3372 : ! cp * exns0(k) * emf(k) * ( thlu_emf(k) - ( thl0(k) + ssthl0(k) * ( ps0(k) - p0(k) ) ) ) !
3373 : ! qtflx(k) = umf(k) * ( qtu(k) - ( qt0(kp1) + ssqt0(kp1) * ( ps0(k) - p0(kp1) ) ) ) + & !
3374 : ! emf(k) * ( qtu_emf(k) - ( qt0(k) + ssqt0(k) * ( ps0(k) - p0(k) ) ) ) !
3375 : ! uflx(k) = umf(k) * ( uu(k) - ( u0(kp1) + ssu0(kp1) * ( ps0(k) - p0(kp1) ) ) ) + & !
3376 : ! emf(k) * ( uu_emf(k) - ( u0(k) + ssu0(k) * ( ps0(k) - p0(k) ) ) ) !
3377 : ! vflx(k) = umf(k) * ( vu(k) - ( v0(kp1) + ssv0(kp1) * ( ps0(k) - p0(kp1) ) ) ) + & !
3378 : ! emf(k) * ( vu_emf(k) - ( v0(k) + ssv0(k) * ( ps0(k) - p0(k) ) ) ) !
3379 : ! do m = 1, ncnst !
3380 : ! trflx(k,m) = umf(k) * ( tru(k,m) - ( tr0(kp1,m) + sstr0(kp1,m) * ( ps0(k) - p0(kp1) ) ) ) + & !
3381 : ! emf(k) * ( tru_emf(k,m) - ( tr0(k,m) + sstr0(k,m) * ( ps0(k) - p0(k) ) ) ) !
3382 : ! enddo !
3383 : ! ------------------------------------------------------------------------------------------------------------------ !
3384 :
3385 0 : do k = kbup, kpen - 1
3386 0 : kp1 = k + 1
3387 0 : slflx(k) = cp * exns0(k) * emf(k) * ( thlu_emf(k) - ( thl0(k) + ssthl0(k) * ( ps0(k) - p0(k) ) ) )
3388 0 : qtflx(k) = emf(k) * ( qtu_emf(k) - ( qt0(k) + ssqt0(k) * ( ps0(k) - p0(k) ) ) )
3389 0 : uflx(k) = emf(k) * ( uu_emf(k) - ( u0(k) + ssu0(k) * ( ps0(k) - p0(k) ) ) )
3390 0 : vflx(k) = emf(k) * ( vu_emf(k) - ( v0(k) + ssv0(k) * ( ps0(k) - p0(k) ) ) )
3391 0 : do m = 1, ncnst
3392 0 : trflx(k,m) = emf(k) * ( tru_emf(k,m) - ( tr0(k,m) + sstr0(k,m) * ( ps0(k) - p0(k) ) ) )
3393 : enddo
3394 : end do
3395 :
3396 : ! ------------------------------------------- !
3397 : ! Turn-off cumulus momentum flux as an option !
3398 : ! ------------------------------------------- !
3399 :
3400 : if( .not. use_momenflx ) then
3401 : uflx(0:mkx) = 0._r8
3402 : vflx(0:mkx) = 0._r8
3403 : endif
3404 :
3405 : ! -------------------------------------------------------- !
3406 : ! Condensate tendency by compensating subsidence/upwelling !
3407 : ! -------------------------------------------------------- !
3408 :
3409 0 : uemf(0:mkx) = 0._r8
3410 0 : do k = 0, kinv - 2 ! Assume linear updraft mass flux within the PBL.
3411 0 : uemf(k) = cbmf * ( ps0(0) - ps0(k) ) / ( ps0(0) - ps0(kinv-1) )
3412 : end do
3413 0 : uemf(kinv-1:krel-1) = cbmf
3414 0 : uemf(krel:kbup-1) = umf(krel:kbup-1)
3415 0 : uemf(kbup:kpen-1) = emf(kbup:kpen-1) ! Only use penetrative entrainment flux consistently.
3416 :
3417 0 : comsub(1:mkx) = 0._r8
3418 0 : do k = 1, kpen
3419 0 : comsub(k) = 0.5_r8 * ( uemf(k) + uemf(k-1) )
3420 : end do
3421 :
3422 0 : do k = 1, kpen
3423 0 : if( comsub(k) .ge. 0._r8 ) then
3424 0 : if( k .eq. mkx ) then
3425 : thlten_sub = 0._r8
3426 : qtten_sub = 0._r8
3427 : qlten_sub = 0._r8
3428 : qiten_sub = 0._r8
3429 : nlten_sub = 0._r8
3430 : niten_sub = 0._r8
3431 : else
3432 0 : thlten_sub = g * comsub(k) * ( thl0(k+1) - thl0(k) ) / ( p0(k) - p0(k+1) )
3433 0 : qtten_sub = g * comsub(k) * ( qt0(k+1) - qt0(k) ) / ( p0(k) - p0(k+1) )
3434 0 : qlten_sub = g * comsub(k) * ( ql0(k+1) - ql0(k) ) / ( p0(k) - p0(k+1) )
3435 0 : qiten_sub = g * comsub(k) * ( qi0(k+1) - qi0(k) ) / ( p0(k) - p0(k+1) )
3436 0 : nlten_sub = g * comsub(k) * ( tr0(k+1,ixnumliq) - tr0(k,ixnumliq) ) / ( p0(k) - p0(k+1) )
3437 0 : niten_sub = g * comsub(k) * ( tr0(k+1,ixnumice) - tr0(k,ixnumice) ) / ( p0(k) - p0(k+1) )
3438 : endif
3439 : else
3440 0 : if( k .eq. 1 ) then
3441 : thlten_sub = 0._r8
3442 : qtten_sub = 0._r8
3443 : qlten_sub = 0._r8
3444 : qiten_sub = 0._r8
3445 : nlten_sub = 0._r8
3446 : niten_sub = 0._r8
3447 : else
3448 0 : thlten_sub = g * comsub(k) * ( thl0(k) - thl0(k-1) ) / ( p0(k-1) - p0(k) )
3449 0 : qtten_sub = g * comsub(k) * ( qt0(k) - qt0(k-1) ) / ( p0(k-1) - p0(k) )
3450 0 : qlten_sub = g * comsub(k) * ( ql0(k) - ql0(k-1) ) / ( p0(k-1) - p0(k) )
3451 0 : qiten_sub = g * comsub(k) * ( qi0(k) - qi0(k-1) ) / ( p0(k-1) - p0(k) )
3452 0 : nlten_sub = g * comsub(k) * ( tr0(k,ixnumliq) - tr0(k-1,ixnumliq) ) / ( p0(k-1) - p0(k) )
3453 0 : niten_sub = g * comsub(k) * ( tr0(k,ixnumice) - tr0(k-1,ixnumice) ) / ( p0(k-1) - p0(k) )
3454 : endif
3455 : endif
3456 0 : thl_prog = thl0(k) + thlten_sub * dt
3457 0 : qt_prog = max( qt0(k) + qtten_sub * dt, 1.e-12_r8 )
3458 0 : call conden(p0(k),thl_prog,qt_prog,thj,qvj,qlj,qij,qse,id_check)
3459 0 : if( id_check .eq. 1 ) then
3460 : id_exit = .true.
3461 : go to 333
3462 : endif
3463 : ! qlten_sink(k) = ( qlj - ql0(k) ) / dt
3464 : ! qiten_sink(k) = ( qij - qi0(k) ) / dt
3465 0 : qlten_sink(k) = max( qlten_sub, - ql0(k) / dt ) ! For consistency with prognostic macrophysics scheme
3466 0 : qiten_sink(k) = max( qiten_sub, - qi0(k) / dt ) ! For consistency with prognostic macrophysics scheme
3467 0 : nlten_sink(k) = max( nlten_sub, - tr0(k,ixnumliq) / dt )
3468 0 : niten_sink(k) = max( niten_sub, - tr0(k,ixnumice) / dt )
3469 : end do
3470 :
3471 : ! --------------------------------------------- !
3472 : ! !
3473 : ! Calculate convective tendencies at each layer !
3474 : ! !
3475 : ! --------------------------------------------- !
3476 :
3477 : ! ----------------- !
3478 : ! Momentum tendency !
3479 : ! ----------------- !
3480 :
3481 0 : do k = 1, kpen
3482 0 : km1 = k - 1
3483 0 : uten(k) = ( uflx(km1) - uflx(k) ) * g / dp0(k)
3484 0 : vten(k) = ( vflx(km1) - vflx(k) ) * g / dp0(k)
3485 0 : uf(k) = u0(k) + uten(k) * dt
3486 0 : vf(k) = v0(k) + vten(k) * dt
3487 : ! do m = 1, ncnst
3488 : ! trten(k,m) = ( trflx(km1,m) - trflx(k,m) ) * g / dp0(k)
3489 : ! ! Limit trten(k,m) such that negative value is not developed.
3490 : ! ! This limitation does not conserve grid-mean tracers and future
3491 : ! ! refinement is required for tracer-conserving treatment.
3492 : ! trten(k,m) = max(trten(k,m),-tr0(k,m)/dt)
3493 : ! enddo
3494 : end do
3495 :
3496 : ! ----------------------------------------------------------------- !
3497 : ! Tendencies of thermodynamic variables. !
3498 : ! This part requires a careful treatment of bulk cloud microphysics.!
3499 : ! Relocations of 'precipitable condensates' either into the surface !
3500 : ! or into the tendency of 'krel' layer will be performed just after !
3501 : ! finishing the below 'do-loop'. !
3502 : ! ----------------------------------------------------------------- !
3503 :
3504 : rliq = 0._r8
3505 : rainflx = 0._r8
3506 : snowflx = 0._r8
3507 :
3508 0 : do k = 1, kpen
3509 :
3510 0 : km1 = k - 1
3511 :
3512 : ! ------------------------------------------------------------------------------ !
3513 : ! Compute 'slten', 'qtten', 'qvten', 'qlten', 'qiten', and 'sten' !
3514 : ! !
3515 : ! Key assumptions made in this 'cumulus scheme' are : !
3516 : ! 1. Cumulus updraft expels condensate into the environment at the top interface !
3517 : ! of each layer. Note that in addition to this expel process ('source' term), !
3518 : ! cumulus updraft can modify layer mean condensate through normal detrainment !
3519 : ! forcing or compensating subsidence. !
3520 : ! 2. Expelled water can be either 'sustaining' or 'precipitating' condensate. By !
3521 : ! definition, 'suataining condensate' will remain in the layer where it was !
3522 : ! formed, while 'precipitating condensate' will fall across the base of the !
3523 : ! layer where it was formed. !
3524 : ! 3. All precipitating condensates are assumed to fall into the release layer or !
3525 : ! ground as soon as it was formed without being evaporated during the falling !
3526 : ! process down to the desinated layer ( either release layer of surface ). !
3527 : ! ------------------------------------------------------------------------------ !
3528 :
3529 : ! ------------------------------------------------------------------------- !
3530 : ! 'dwten(k)','diten(k)' : Production rate of condensate within the layer k !
3531 : ! [ kg/kg/s ] by the expels of condensate from cumulus updraft. !
3532 : ! It is important to note that in terms of moisture tendency equation, this !
3533 : ! is a 'source' term of enviromental 'qt'. More importantly, these source !
3534 : ! are already counted in the turbulent heat and moisture fluxes we computed !
3535 : ! until now, assuming all the expelled condensate remain in the layer where !
3536 : ! it was formed. Thus, in calculation of 'qtten' and 'slten' below, we MUST !
3537 : ! NOT add or subtract these terms explicitly in order not to double or miss !
3538 : ! count, unless some expelled condensates fall down out of the layer. Note !
3539 : ! this falling-down process ( i.e., precipitation process ) and associated !
3540 : ! 'qtten' and 'slten' and production of surface precipitation flux will be !
3541 : ! treated later in 'zm_conv_evap' in 'convect_shallow_tend' subroutine. !
3542 : ! In below, we are converting expelled cloud condensate into correct unit. !
3543 : ! I found that below use of '0.5 * (umf(k-1) + umf(k))' causes conservation !
3544 : ! errors at some columns in global simulation. So, I returned to originals. !
3545 : ! This will cause no precipitation flux at 'kpen' layer since umf(kpen)=0. !
3546 : ! ------------------------------------------------------------------------- !
3547 :
3548 0 : dwten(k) = dwten(k) * 0.5_r8 * ( umf(k-1) + umf(k) ) * g / dp0(k) ! [ kg/kg/s ]
3549 0 : diten(k) = diten(k) * 0.5_r8 * ( umf(k-1) + umf(k) ) * g / dp0(k) ! [ kg/kg/s ]
3550 :
3551 : ! dwten(k) = dwten(k) * umf(k) * g / dp0(k) ! [ kg/kg/s ]
3552 : ! diten(k) = diten(k) * umf(k) * g / dp0(k) ! [ kg/kg/s ]
3553 :
3554 : ! --------------------------------------------------------------------------- !
3555 : ! 'qrten(k)','qsten(k)' : Production rate of rain and snow within the layer k !
3556 : ! [ kg/kg/s ] by cumulus expels of condensates to the environment.!
3557 : ! This will be falled-out of the layer where it was formed and will be dumped !
3558 : ! dumped into the release layer assuming that there is no evaporative cooling !
3559 : ! while precipitable condensate moves to the relaes level. This is reasonable !
3560 : ! assumtion if cumulus is purely vertical and so the path along which precita !
3561 : ! ble condensate falls is fully saturared. This 're-allocation' process of !
3562 : ! precipitable condensate into the release layer is fully described in this !
3563 : ! convection scheme. After that, the dumped water into the release layer will !
3564 : ! falling down across the base of release layer ( or LCL, if exact treatment !
3565 : ! is required ) and will be allowed to be evaporated in layers below release !
3566 : ! layer, and finally non-zero surface precipitation flux will be calculated. !
3567 : ! This latter process will be separately treated 'zm_conv_evap' routine. !
3568 : ! --------------------------------------------------------------------------- !
3569 :
3570 0 : qrten(k) = frc_rasn * dwten(k)
3571 0 : qsten(k) = frc_rasn * diten(k)
3572 :
3573 : ! ----------------------------------------------------------------------- !
3574 : ! 'rainflx','snowflx' : Cumulative rain and snow flux integrated from the !
3575 : ! [ kg/m2/s ] release leyer to the 'kpen' layer. Note that even !
3576 : ! though wtw(kpen) < 0 (and umf(kpen) = 0) at the top interface of 'kpen' !
3577 : ! layer, 'dwten(kpen)' and diten(kpen) were calculated after calculating !
3578 : ! explicit cloud top height. Thus below calculation of precipitation flux !
3579 : ! is correct. Note that precipitating condensates are formed only in the !
3580 : ! layers from 'krel' to 'kpen', including the two layers. !
3581 : ! ----------------------------------------------------------------------- !
3582 :
3583 0 : rainflx = rainflx + qrten(k) * dp0(k) / g
3584 0 : snowflx = snowflx + qsten(k) * dp0(k) / g
3585 :
3586 : ! ------------------------------------------------------------------------ !
3587 : ! 'slten(k)','qtten(k)' !
3588 : ! Note that 'slflx(k)' and 'qtflx(k)' we have calculated already included !
3589 : ! all the contributions of (1) expels of condensate (dwten(k), diten(k)), !
3590 : ! (2) mass detrainment ( delta * umf * ( qtu - qt ) ), & (3) compensating !
3591 : ! subsidence ( M * dqt / dz ). Thus 'slflx(k)' and 'qtflx(k)' we computed !
3592 : ! is a hybrid turbulent flux containing one part of 'source' term - expel !
3593 : ! of condensate. In order to calculate 'slten' and 'qtten', we should add !
3594 : ! additional 'source' term, if any. If the expelled condensate falls down !
3595 : ! across the base of the layer, it will be another sink (negative source) !
3596 : ! term. Note also that we included frictional heating terms in the below !
3597 : ! calculation of 'slten'. !
3598 : ! ------------------------------------------------------------------------ !
3599 :
3600 0 : slten(k) = ( slflx(km1) - slflx(k) ) * g / dp0(k)
3601 0 : if( k .eq. 1 ) then
3602 : slten(k) = slten(k) - g / 4._r8 / dp0(k) * ( &
3603 0 : uflx(k)*(uf(k+1) - uf(k) + u0(k+1) - u0(k)) + &
3604 0 : vflx(k)*(vf(k+1) - vf(k) + v0(k+1) - v0(k)))
3605 0 : elseif( k .ge. 2 .and. k .le. kpen-1 ) then
3606 : slten(k) = slten(k) - g / 4._r8 / dp0(k) * ( &
3607 0 : uflx(k)*(uf(k+1) - uf(k) + u0(k+1) - u0(k)) + &
3608 0 : uflx(k-1)*(uf(k) - uf(k-1) + u0(k) - u0(k-1)) + &
3609 : vflx(k)*(vf(k+1) - vf(k) + v0(k+1) - v0(k)) + &
3610 0 : vflx(k-1)*(vf(k) - vf(k-1) + v0(k) - v0(k-1)))
3611 0 : elseif( k .eq. kpen ) then
3612 : slten(k) = slten(k) - g / 4._r8 / dp0(k) * ( &
3613 0 : uflx(k-1)*(uf(k) - uf(k-1) + u0(k) - u0(k-1)) + &
3614 0 : vflx(k-1)*(vf(k) - vf(k-1) + v0(k) - v0(k-1)))
3615 : endif
3616 0 : qtten(k) = ( qtflx(km1) - qtflx(k) ) * g / dp0(k)
3617 :
3618 : ! ---------------------------------------------------------------------------- !
3619 : ! Compute condensate tendency, including reserved condensate !
3620 : ! We assume that eventual detachment and detrainment occurs in kbup layer due !
3621 : ! to downdraft buoyancy sorting. In the layer above the kbup, only penetrative !
3622 : ! entrainment exists. Penetrative entrained air is assumed not to contain any !
3623 : ! condensate. !
3624 : ! ---------------------------------------------------------------------------- !
3625 :
3626 : ! Compute in-cumulus condensate at the layer mid-point.
3627 :
3628 0 : if( k .lt. krel .or. k .gt. kpen ) then
3629 0 : qlu_mid = 0._r8
3630 0 : qiu_mid = 0._r8
3631 0 : qlj = 0._r8
3632 0 : qij = 0._r8
3633 0 : elseif( k .eq. krel ) then
3634 0 : call conden(prel,thlu(krel-1),qtu(krel-1),thj,qvj,qlj,qij,qse,id_check)
3635 0 : if( id_check .eq. 1 ) then
3636 0 : exit_conden(i) = 1._r8
3637 0 : id_exit = .true.
3638 0 : go to 333
3639 : endif
3640 0 : qlubelow = qlj
3641 0 : qiubelow = qij
3642 0 : call conden(ps0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check)
3643 0 : if( id_check .eq. 1 ) then
3644 0 : exit_conden(i) = 1._r8
3645 0 : id_exit = .true.
3646 0 : go to 333
3647 : end if
3648 0 : qlu_mid = 0.5_r8 * ( qlubelow + qlj ) * ( prel - ps0(k) )/( ps0(k-1) - ps0(k) )
3649 0 : qiu_mid = 0.5_r8 * ( qiubelow + qij ) * ( prel - ps0(k) )/( ps0(k-1) - ps0(k) )
3650 0 : elseif( k .eq. kpen ) then
3651 0 : call conden(ps0(k-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check)
3652 0 : if( id_check .eq. 1 ) then
3653 0 : exit_conden(i) = 1._r8
3654 0 : id_exit = .true.
3655 0 : go to 333
3656 : end if
3657 0 : qlu_mid = 0.5_r8 * ( qlubelow + qlj ) * ( -ppen ) /( ps0(k-1) - ps0(k) )
3658 0 : qiu_mid = 0.5_r8 * ( qiubelow + qij ) * ( -ppen ) /( ps0(k-1) - ps0(k) )
3659 0 : qlu_top = qlj
3660 0 : qiu_top = qij
3661 : else
3662 0 : call conden(ps0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check)
3663 0 : if( id_check .eq. 1 ) then
3664 0 : exit_conden(i) = 1._r8
3665 0 : id_exit = .true.
3666 0 : go to 333
3667 : end if
3668 0 : qlu_mid = 0.5_r8 * ( qlubelow + qlj )
3669 0 : qiu_mid = 0.5_r8 * ( qiubelow + qij )
3670 : endif
3671 0 : qlubelow = qlj
3672 0 : qiubelow = qij
3673 :
3674 : ! 1. Sustained Precipitation
3675 :
3676 0 : qc_l(k) = ( 1._r8 - frc_rasn ) * dwten(k) ! [ kg/kg/s ]
3677 0 : qc_i(k) = ( 1._r8 - frc_rasn ) * diten(k) ! [ kg/kg/s ]
3678 :
3679 : ! 2. Detrained Condensate
3680 :
3681 0 : if( k .le. kbup ) then
3682 0 : qc_l(k) = qc_l(k) + g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * qlu_mid ! [ kg/kg/s ]
3683 0 : qc_i(k) = qc_i(k) + g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * qiu_mid ! [ kg/kg/s ]
3684 0 : qc_lm = - g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * ql0(k)
3685 0 : qc_im = - g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * qi0(k)
3686 : ! Below 'nc_lm', 'nc_im' should be used only when frc_rasn = 1.
3687 0 : nc_lm = - g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * tr0(k,ixnumliq)
3688 0 : nc_im = - g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * tr0(k,ixnumice)
3689 : else
3690 : qc_lm = 0._r8
3691 : qc_im = 0._r8
3692 : nc_lm = 0._r8
3693 : nc_im = 0._r8
3694 : endif
3695 :
3696 : ! 3. Detached Updraft
3697 :
3698 0 : if( k .eq. kbup ) then
3699 0 : qc_l(k) = qc_l(k) + g * umf(k) * qlj / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
3700 0 : qc_i(k) = qc_i(k) + g * umf(k) * qij / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
3701 0 : qc_lm = qc_lm - g * umf(k) * ql0(k) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
3702 0 : qc_im = qc_im - g * umf(k) * qi0(k) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
3703 0 : nc_lm = nc_lm - g * umf(k) * tr0(k,ixnumliq) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
3704 0 : nc_im = nc_im - g * umf(k) * tr0(k,ixnumice) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
3705 : endif
3706 :
3707 : ! 4. Cumulative Penetrative entrainment detrained in the 'kbup' layer
3708 : ! Explicitly compute the properties detrained penetrative entrained airs in k = kbup layer.
3709 :
3710 0 : if( k .eq. kbup ) then
3711 0 : call conden(p0(k),thlu_emf(k),qtu_emf(k),thj,qvj,ql_emf_kbup,qi_emf_kbup,qse,id_check)
3712 0 : if( id_check .eq. 1 ) then
3713 : id_exit = .true.
3714 : go to 333
3715 : endif
3716 0 : if( ql_emf_kbup .gt. 0._r8 ) then
3717 0 : nl_emf_kbup = tru_emf(k,ixnumliq)
3718 : else
3719 : nl_emf_kbup = 0._r8
3720 : endif
3721 0 : if( qi_emf_kbup .gt. 0._r8 ) then
3722 0 : ni_emf_kbup = tru_emf(k,ixnumice)
3723 : else
3724 : ni_emf_kbup = 0._r8
3725 : endif
3726 0 : qc_lm = qc_lm - g * emf(k) * ( ql_emf_kbup - ql0(k) ) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
3727 0 : qc_im = qc_im - g * emf(k) * ( qi_emf_kbup - qi0(k) ) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
3728 0 : nc_lm = nc_lm - g * emf(k) * ( nl_emf_kbup - tr0(k,ixnumliq) ) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
3729 0 : nc_im = nc_im - g * emf(k) * ( ni_emf_kbup - tr0(k,ixnumice) ) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
3730 : endif
3731 :
3732 0 : qlten_det = qc_l(k) + qc_lm
3733 0 : qiten_det = qc_i(k) + qc_im
3734 :
3735 : ! --------------------------------------------------------------------------------- !
3736 : ! 'qlten(k)','qiten(k)','qvten(k)','sten(k)' !
3737 : ! Note that falling of precipitation will be treated later. !
3738 : ! The prevension of negative 'qv,ql,qi' will be treated later in positive_moisture. !
3739 : ! --------------------------------------------------------------------------------- !
3740 :
3741 : if( use_expconten ) then
3742 : if( use_unicondet ) then
3743 : qc_l(k) = 0._r8
3744 : qc_i(k) = 0._r8
3745 : qlten(k) = frc_rasn * dwten(k) + qlten_sink(k) + qlten_det
3746 : qiten(k) = frc_rasn * diten(k) + qiten_sink(k) + qiten_det
3747 : else
3748 0 : qlten(k) = qc_l(k) + frc_rasn * dwten(k) + ( max( 0._r8, ql0(k) + ( qc_lm + qlten_sink(k) ) * dt ) - ql0(k) ) / dt
3749 0 : qiten(k) = qc_i(k) + frc_rasn * diten(k) + ( max( 0._r8, qi0(k) + ( qc_im + qiten_sink(k) ) * dt ) - qi0(k) ) / dt
3750 0 : trten(k,ixnumliq) = max( nc_lm + nlten_sink(k), - tr0(k,ixnumliq) / dt )
3751 0 : trten(k,ixnumice) = max( nc_im + niten_sink(k), - tr0(k,ixnumice) / dt )
3752 : endif
3753 : else
3754 : if( use_unicondet ) then
3755 : qc_l(k) = 0._r8
3756 : qc_i(k) = 0._r8
3757 : endif
3758 : qlten(k) = dwten(k) + ( qtten(k) - dwten(k) - diten(k) ) * ( ql0(k) / qt0(k) )
3759 : qiten(k) = diten(k) + ( qtten(k) - dwten(k) - diten(k) ) * ( qi0(k) / qt0(k) )
3760 : endif
3761 :
3762 0 : qvten(k) = qtten(k) - qlten(k) - qiten(k)
3763 0 : sten(k) = slten(k) + xlv * qlten(k) + xls * qiten(k)
3764 :
3765 : ! -------------------------------------------------------------------------- !
3766 : ! 'rliq' : Verticall-integrated 'suspended cloud condensate' !
3767 : ! [m/s] This is so called 'reserved liquid water' in other subroutines !
3768 : ! of CAM, since the contribution of this term should not be included into !
3769 : ! the tendency of each layer or surface flux (precip) within this cumulus !
3770 : ! scheme. The adding of this term to the layer tendency will be done inthe !
3771 : ! 'stratiform_tend', just after performing sediment process there. !
3772 : ! The main problem of these rather going-back-and-forth and stupid-seeming !
3773 : ! approach is that the sediment process of suspendened condensate will not !
3774 : ! be treated at all in the 'stratiform_tend'. !
3775 : ! Note that 'precip' [m/s] is vertically-integrated total 'rain+snow' formed !
3776 : ! from the cumulus updraft. Important : in the below, 1000 is rhoh2o ( water !
3777 : ! density ) [ kg/m^3 ] used for unit conversion from [ kg/m^2/s ] to [ m/s ] !
3778 : ! for use in stratiform.F90. !
3779 : ! -------------------------------------------------------------------------- !
3780 :
3781 0 : qc(k) = qc_l(k) + qc_i(k)
3782 0 : rliq = rliq + qc(k) * dp0(k) / g / 1000._r8 ! [ m/s ]
3783 :
3784 : end do
3785 :
3786 0 : precip = rainflx + snowflx ! [ kg/m2/s ]
3787 0 : snow = snowflx ! [ kg/m2/s ]
3788 :
3789 : ! ---------------------------------------------------------------- !
3790 : ! Now treats the 'evaporation' and 'melting' of rain ( qrten ) and !
3791 : ! snow ( qsten ) during falling process. Below algorithms are from !
3792 : ! 'zm_conv_evap' but with some modification, which allows separate !
3793 : ! treatment of 'rain' and 'snow' condensates. Note that I included !
3794 : ! the evaporation dynamics into the convection scheme for complete !
3795 : ! development of cumulus scheme especially in association with the !
3796 : ! implicit CIN closure. In compatible with this internal treatment !
3797 : ! of evaporation, I should modify 'convect_shallow', in such that !
3798 : ! 'zm_conv_evap' is not performed when I choose UW PBL-Cu schemes. !
3799 : ! ---------------------------------------------------------------- !
3800 :
3801 0 : evpint_rain = 0._r8
3802 0 : evpint_snow = 0._r8
3803 0 : flxrain(0:mkx) = 0._r8
3804 0 : flxsnow(0:mkx) = 0._r8
3805 0 : ntraprd(:mkx) = 0._r8
3806 0 : ntsnprd(:mkx) = 0._r8
3807 :
3808 0 : do k = mkx, 1, -1 ! 'k' is a layer index : 'mkx'('1') is the top ('bottom') layer
3809 :
3810 : ! ----------------------------------------------------------------------------- !
3811 : ! flxsntm [kg/m2/s] : Downward snow flux at the top of each layer after melting.!
3812 : ! snowmlt [kg/kg/s] : Snow melting tendency. !
3813 : ! Below allows melting of snow when it goes down into the warm layer below. !
3814 : ! ----------------------------------------------------------------------------- !
3815 :
3816 0 : if( t0(k) .gt. 273.16_r8 ) then
3817 0 : snowmlt = max( 0._r8, flxsnow(k) * g / dp0(k) )
3818 : else
3819 : snowmlt = 0._r8
3820 : endif
3821 :
3822 : ! ----------------------------------------------------------------- !
3823 : ! Evaporation rate of 'rain' and 'snow' in the layer k, [ kg/kg/s ] !
3824 : ! where 'rain' and 'snow' are coming down from the upper layers. !
3825 : ! I used the same evaporative efficiency both for 'rain' and 'snow'.!
3826 : ! Note that evaporation is not allowed in the layers 'k >= krel' by !
3827 : ! assuming that inside of cumulus cloud, across which precipitation !
3828 : ! is falling down, is fully saturated. !
3829 : ! The asumptions in association with the 'evplimit_rain(snow)' are !
3830 : ! 1. Do not allow evaporation to supersate the layer !
3831 : ! 2. Do not evaporate more than the flux falling into the layer !
3832 : ! 3. Total evaporation cannot exceed the input total surface flux !
3833 : ! ----------------------------------------------------------------- !
3834 :
3835 0 : call qsat(t0(k), p0(k), es, qs)
3836 0 : subsat = max( ( 1._r8 - qv0(k)/qs ), 0._r8 )
3837 : if( noevap_krelkpen ) then
3838 : if( k .ge. krel ) subsat = 0._r8
3839 : endif
3840 :
3841 0 : evprain = kevp * subsat * sqrt(flxrain(k)+snowmlt*dp0(k)/g)
3842 0 : evpsnow = kevp * subsat * sqrt(max(flxsnow(k)-snowmlt*dp0(k)/g,0._r8))
3843 :
3844 0 : evplimit = max( 0._r8, ( qw0_in(i,k) - qv0(k) ) / dt )
3845 :
3846 0 : evplimit_rain = min( evplimit, ( flxrain(k) + snowmlt * dp0(k) / g ) * g / dp0(k) )
3847 0 : evplimit_rain = min( evplimit_rain, ( rainflx - evpint_rain ) * g / dp0(k) )
3848 0 : evprain = max(0._r8,min( evplimit_rain, evprain ))
3849 :
3850 0 : evplimit_snow = min( evplimit, max( flxsnow(k) - snowmlt * dp0(k) / g , 0._r8 ) * g / dp0(k) )
3851 0 : evplimit_snow = min( evplimit_snow, ( snowflx - evpint_snow ) * g / dp0(k) )
3852 0 : evpsnow = max(0._r8,min( evplimit_snow, evpsnow ))
3853 :
3854 0 : if( ( evprain + evpsnow ) .gt. evplimit ) then
3855 0 : tmp1 = evprain * evplimit / ( evprain + evpsnow )
3856 0 : tmp2 = evpsnow * evplimit / ( evprain + evpsnow )
3857 0 : evprain = tmp1
3858 0 : evpsnow = tmp2
3859 : endif
3860 :
3861 0 : evapc(k) = evprain + evpsnow
3862 :
3863 : ! ------------------------------------------------------------- !
3864 : ! Vertically-integrated evaporative fluxes of 'rain' and 'snow' !
3865 : ! ------------------------------------------------------------- !
3866 :
3867 0 : evpint_rain = evpint_rain + evprain * dp0(k) / g
3868 0 : evpint_snow = evpint_snow + evpsnow * dp0(k) / g
3869 :
3870 : ! -------------------------------------------------------------- !
3871 : ! Net 'rain' and 'snow' production rate in the layer [ kg/kg/s ] !
3872 : ! -------------------------------------------------------------- !
3873 :
3874 0 : ntraprd(k) = qrten(k) - evprain + snowmlt
3875 0 : ntsnprd(k) = qsten(k) - evpsnow - snowmlt
3876 :
3877 : ! -------------------------------------------------------------------------------- !
3878 : ! Downward fluxes of 'rain' and 'snow' fluxes at the base of the layer [ kg/m2/s ] !
3879 : ! Note that layer index increases with height. !
3880 : ! -------------------------------------------------------------------------------- !
3881 :
3882 0 : flxrain(k-1) = flxrain(k) + ntraprd(k) * dp0(k) / g
3883 0 : flxsnow(k-1) = flxsnow(k) + ntsnprd(k) * dp0(k) / g
3884 0 : flxrain(k-1) = max( flxrain(k-1), 0._r8 )
3885 0 : if( flxrain(k-1) .eq. 0._r8 ) ntraprd(k) = -flxrain(k) * g / dp0(k)
3886 0 : flxsnow(k-1) = max( flxsnow(k-1), 0._r8 )
3887 0 : if( flxsnow(k-1) .eq. 0._r8 ) ntsnprd(k) = -flxsnow(k) * g / dp0(k)
3888 :
3889 : ! ---------------------------------- !
3890 : ! Calculate thermodynamic tendencies !
3891 : ! --------------------------------------------------------------------------- !
3892 : ! Note that equivalently, we can write tendency formula of 'sten' and 'slten' !
3893 : ! by 'sten(k) = sten(k) - xlv*evprain - xls*evpsnow - (xls-xlv)*snowmlt' & !
3894 : ! 'slten(k) = sten(k) - xlv*qlten(k) - xls*qiten(k)'. !
3895 : ! The above formula is equivalent to the below formula. However below formula !
3896 : ! is preferred since we have already imposed explicit constraint on 'ntraprd' !
3897 : ! and 'ntsnprd' in case that flxrain(k-1) < 0 & flxsnow(k-1) < 0._r8 !
3898 : ! Note : In future, I can elborate the limiting of 'qlten','qvten','qiten' !
3899 : ! such that that energy and moisture conservation error is completely !
3900 : ! suppressed. !
3901 : ! Re-storation to the positive condensate will be performed later below !
3902 : ! --------------------------------------------------------------------------- !
3903 :
3904 0 : qlten(k) = qlten(k) - qrten(k)
3905 0 : qiten(k) = qiten(k) - qsten(k)
3906 0 : qvten(k) = qvten(k) + evprain + evpsnow
3907 0 : qtten(k) = qlten(k) + qiten(k) + qvten(k)
3908 : if( ( qv0(k) + qvten(k)*dt ) .lt. qmin(1) .or. &
3909 0 : ( ql0(k) + qlten(k)*dt ) .lt. qmin(ixcldliq) .or. &
3910 0 : ( qi0(k) + qiten(k)*dt ) .lt. qmin(ixcldice) ) then
3911 0 : limit_negcon(i) = 1._r8
3912 : end if
3913 0 : sten(k) = sten(k) - xlv*evprain - xls*evpsnow - (xls-xlv)*snowmlt
3914 0 : slten(k) = sten(k) - xlv*qlten(k) - xls*qiten(k)
3915 :
3916 : ! slten(k) = slten(k) + xlv * ntraprd(k) + xls * ntsnprd(k)
3917 : ! sten(k) = slten(k) + xlv * qlten(k) + xls * qiten(k)
3918 :
3919 : end do
3920 :
3921 : ! ------------------------------------------------------------- !
3922 : ! Calculate final surface flux of precipitation, rain, and snow !
3923 : ! Convert unit to [m/s] for use in 'check_energy_chng'. !
3924 : ! ------------------------------------------------------------- !
3925 :
3926 0 : precip = ( flxrain(0) + flxsnow(0) ) / 1000._r8
3927 0 : snow = flxsnow(0) / 1000._r8
3928 :
3929 : ! --------------------------------------------------------------------------- !
3930 : ! Until now, all the calculations are done completely in this shallow cumulus !
3931 : ! scheme. If you want to use this cumulus scheme other than CAM, then do not !
3932 : ! perform below block. However, for compatible use with the other subroutines !
3933 : ! in CAM, I should subtract the effect of 'qc(k)' ('rliq') from the tendency !
3934 : ! equation in each layer, since this effect will be separately added later in !
3935 : ! in 'stratiform_tend' just after performing sediment process there. In order !
3936 : ! to be consistent with 'stratiform_tend', just subtract qc(k) from tendency !
3937 : ! equation of each layer, but do not add it to the 'precip'. Apprently, this !
3938 : ! will violate energy and moisture conservations. However, when performing !
3939 : ! conservation check in 'tphysbc.F90' just after 'convect_shallow_tend', we !
3940 : ! will add 'qc(k)' ( rliq ) to the surface flux term just for the purpose of !
3941 : ! passing the energy-moisture conservation check. Explicit adding-back of 'qc'!
3942 : ! to the individual layer tendency equation will be done in 'stratiform_tend' !
3943 : ! after performing sediment process there. Simply speaking, in 'tphysbc' just !
3944 : ! after 'convect_shallow_tend', we will dump 'rliq' into surface as a 'rain' !
3945 : ! in order to satisfy energy and moisture conservation, and in the following !
3946 : ! 'stratiform_tend', we will restore it back to 'qlten(k)' ( 'ice' will go to !
3947 : ! 'water' there) from surface precipitation. This is a funny but conceptually !
3948 : ! entertaining procedure. One concern I have for this complex process is that !
3949 : ! output-writed stratiform precipitation amount will be underestimated due to !
3950 : ! arbitrary subtracting of 'rliq' in stratiform_tend, where !
3951 : ! ' prec_str = prec_sed + prec_pcw - rliq' and 'rliq' is not real but fake. !
3952 : ! However, as shown in 'srfxfer.F90', large scale precipitation amount (PRECL)!
3953 : ! that is writed-output is corrected written since in 'srfxfer.F90', PRECL = !
3954 : ! 'prec_sed + prec_pcw', without including 'rliq'. So current code is correct.!
3955 : ! Note also in 'srfxfer.F90', convective precipitation amount is 'PRECC = !
3956 : ! prec_zmc(i) + prec_cmf(i)' which is also correct. !
3957 : ! --------------------------------------------------------------------------- !
3958 :
3959 0 : do k = 1, kpen
3960 0 : qtten(k) = qtten(k) - qc(k)
3961 0 : qlten(k) = qlten(k) - qc_l(k)
3962 0 : qiten(k) = qiten(k) - qc_i(k)
3963 0 : slten(k) = slten(k) + ( xlv * qc_l(k) + xls * qc_i(k) )
3964 : ! ---------------------------------------------------------------------- !
3965 : ! Since all reserved condensates will be treated as liquid water in the !
3966 : ! 'check_energy_chng' & 'stratiform_tend' without an explicit conversion !
3967 : ! algorithm, I should consider explicitly the energy conversions between !
3968 : ! 'ice' and 'liquid' - i.e., I should convert 'ice' to 'liquid' and the !
3969 : ! necessary energy for this conversion should be subtracted from 'sten'. !
3970 : ! Without this conversion here, energy conservation error come out. Note !
3971 : ! that there should be no change of 'qvten(k)'. !
3972 : ! ---------------------------------------------------------------------- !
3973 0 : sten(k) = sten(k) - ( xls - xlv ) * qc_i(k)
3974 : end do
3975 :
3976 : ! --------------------------------------------------------------- !
3977 : ! Prevent the onset-of negative condensate at the next time step !
3978 : ! Potentially, this block can be moved just in front of the above !
3979 : ! block. !
3980 : ! --------------------------------------------------------------- !
3981 :
3982 : ! Modification : I should check whether this 'positive_moisture_single' routine is
3983 : ! consistent with the one used in UW PBL and cloud macrophysics schemes.
3984 : ! Modification : Below may overestimate resulting 'ql, qi' if we use the new 'qc_l', 'qc_i'
3985 : ! in combination with the original computation of qlten, qiten. However,
3986 : ! if we use new 'qlten,qiten', there is no problem.
3987 :
3988 0 : qv0_star(:mkx) = qv0(:mkx) + qvten(:mkx) * dt
3989 0 : ql0_star(:mkx) = ql0(:mkx) + qlten(:mkx) * dt
3990 0 : qi0_star(:mkx) = qi0(:mkx) + qiten(:mkx) * dt
3991 0 : s0_star(:mkx) = s0(:mkx) + sten(:mkx) * dt
3992 0 : call positive_moisture_single( xlv, xls, mkx, dt, qmin(1), qmin(ixcldliq), qmin(ixcldice), &
3993 0 : dp0, qv0_star, ql0_star, qi0_star, s0_star, qvten, qlten, qiten, sten )
3994 0 : qtten(:mkx) = qvten(:mkx) + qlten(:mkx) + qiten(:mkx)
3995 0 : slten(:mkx) = sten(:mkx) - xlv * qlten(:mkx) - xls * qiten(:mkx)
3996 :
3997 : ! --------------------- !
3998 : ! Tendencies of tracers !
3999 : ! --------------------- !
4000 :
4001 0 : do m = 4, ncnst
4002 :
4003 0 : if( m .ne. ixnumliq .and. m .ne. ixnumice ) then
4004 :
4005 0 : trmin = qmin(m)
4006 0 : trflx_d(0:mkx) = 0._r8
4007 0 : trflx_u(0:mkx) = 0._r8
4008 0 : do k = 1, mkx-1
4009 0 : if( cnst_get_type_byind(m) .eq. 'wet' ) then
4010 0 : pdelx = dp0(k)
4011 : else
4012 0 : pdelx = dpdry0(k)
4013 : endif
4014 0 : km1 = k - 1
4015 0 : dum = ( tr0(k,m) - trmin ) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + trflx_d(km1)
4016 0 : trflx_d(k) = min( 0._r8, dum )
4017 : enddo
4018 0 : do k = mkx, 2, -1
4019 0 : if( cnst_get_type_byind(m) .eq. 'wet' ) then
4020 0 : pdelx = dp0(k)
4021 : else
4022 0 : pdelx = dpdry0(k)
4023 : endif
4024 0 : km1 = k - 1
4025 0 : dum = ( tr0(k,m) - trmin ) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + &
4026 0 : trflx_d(km1) - trflx_d(k) - trflx_u(k)
4027 0 : trflx_u(km1) = max( 0._r8, -dum )
4028 : enddo
4029 0 : do k = 1, mkx
4030 0 : if( cnst_get_type_byind(m) .eq. 'wet' ) then
4031 0 : pdelx = dp0(k)
4032 : else
4033 0 : pdelx = dpdry0(k)
4034 : endif
4035 0 : km1 = k - 1
4036 : ! Check : I should re-check whether '_u', '_d' are correctly ordered in
4037 : ! the below tendency computation.
4038 0 : trten(k,m) = ( trflx(km1,m) - trflx(k,m) + &
4039 : trflx_d(km1) - trflx_d(k) + &
4040 0 : trflx_u(km1) - trflx_u(k) ) * g / pdelx
4041 : enddo
4042 :
4043 : endif
4044 :
4045 : enddo
4046 :
4047 : ! ---------------------------------------------------------------- !
4048 : ! Cumpute default diagnostic outputs !
4049 : ! Note that since 'qtu(krel-1:kpen-1)' & 'thlu(krel-1:kpen-1)' has !
4050 : ! been adjusted after detraining cloud condensate into environment !
4051 : ! during cumulus updraft motion, below calculations will exactly !
4052 : ! reproduce in-cloud properties as shown in the output analysis. !
4053 : ! ---------------------------------------------------------------- !
4054 :
4055 0 : call conden(prel,thlu(krel-1),qtu(krel-1),thj,qvj,qlj,qij,qse,id_check)
4056 0 : if( id_check .eq. 1 ) then
4057 0 : exit_conden(i) = 1._r8
4058 0 : id_exit = .true.
4059 0 : go to 333
4060 : end if
4061 0 : qcubelow = qlj + qij
4062 0 : qlubelow = qlj
4063 0 : qiubelow = qij
4064 0 : rcwp = 0._r8
4065 0 : rlwp = 0._r8
4066 0 : riwp = 0._r8
4067 :
4068 : ! --------------------------------------------------------------------- !
4069 : ! In the below calculations, I explicitly considered cloud base ( LCL ) !
4070 : ! and cloud top height ( ps0(kpen-1) + ppen ) !
4071 : ! ----------------------------------------------------------------------!
4072 0 : do k = krel, kpen ! This is a layer index
4073 : ! ------------------------------------------------------------------ !
4074 : ! Calculate cumulus condensate at the upper interface of each layer. !
4075 : ! Note 'ppen < 0' and at 'k=kpen' layer, I used 'thlu_top'&'qtu_top' !
4076 : ! which explicitly considered zero or non-zero 'fer(kpen)'. !
4077 : ! ------------------------------------------------------------------ !
4078 0 : if( k .eq. kpen ) then
4079 0 : call conden(ps0(k-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check)
4080 : else
4081 0 : call conden(ps0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check)
4082 : endif
4083 0 : if( id_check .eq. 1 ) then
4084 0 : exit_conden(i) = 1._r8
4085 0 : id_exit = .true.
4086 0 : go to 333
4087 : end if
4088 : ! ---------------------------------------------------------------- !
4089 : ! Calculate in-cloud mean LWC ( qlu(k) ), IWC ( qiu(k) ), & layer !
4090 : ! mean cumulus fraction ( cufrc(k) ), vertically-integrated layer !
4091 : ! mean LWP and IWP. Expel some of in-cloud condensate at the upper !
4092 : ! interface if it is largr than criqc. Note cumulus cloud fraction !
4093 : ! is assumed to be twice of core updraft fractional area. Thus LWP !
4094 : ! and IWP will be twice of actual value coming from our scheme. !
4095 : ! ---------------------------------------------------------------- !
4096 0 : qcu(k) = 0.5_r8 * ( qcubelow + qlj + qij )
4097 0 : qlu(k) = 0.5_r8 * ( qlubelow + qlj )
4098 0 : qiu(k) = 0.5_r8 * ( qiubelow + qij )
4099 0 : cufrc(k) = ( ufrc(k-1) + ufrc(k) )
4100 0 : if( k .eq. krel ) then
4101 0 : cufrc(k) = ( ufrclcl + ufrc(k) )*( prel - ps0(k) )/( ps0(k-1) - ps0(k) )
4102 0 : else if( k .eq. kpen ) then
4103 0 : cufrc(k) = ( ufrc(k-1) + 0._r8 )*( -ppen ) /( ps0(k-1) - ps0(k) )
4104 0 : if( (qlj + qij) .gt. criqc ) then
4105 0 : qcu(k) = 0.5_r8 * ( qcubelow + criqc )
4106 0 : qlu(k) = 0.5_r8 * ( qlubelow + criqc * qlj / ( qlj + qij ) )
4107 0 : qiu(k) = 0.5_r8 * ( qiubelow + criqc * qij / ( qlj + qij ) )
4108 : endif
4109 : endif
4110 0 : rcwp = rcwp + ( qlu(k) + qiu(k) ) * ( ps0(k-1) - ps0(k) ) / g * cufrc(k)
4111 0 : rlwp = rlwp + qlu(k) * ( ps0(k-1) - ps0(k) ) / g * cufrc(k)
4112 0 : riwp = riwp + qiu(k) * ( ps0(k-1) - ps0(k) ) / g * cufrc(k)
4113 0 : qcubelow = qlj + qij
4114 0 : qlubelow = qlj
4115 0 : qiubelow = qij
4116 : end do
4117 : ! ------------------------------------ !
4118 : ! Cloud top and base interface indices !
4119 : ! ------------------------------------ !
4120 0 : cnt = real( kpen, r8 )
4121 0 : cnb = real( krel - 1, r8 )
4122 :
4123 : ! ------------------------------------------------------------------------- !
4124 : ! End of formal calculation. Below blocks are for implicit CIN calculations !
4125 : ! with re-initialization and save variables at iter_cin = 1._r8 !
4126 : ! ------------------------------------------------------------------------- !
4127 :
4128 : ! --------------------------------------------------------------- !
4129 : ! Adjust the original input profiles for implicit CIN calculation !
4130 : ! --------------------------------------------------------------- !
4131 :
4132 0 : if( iter .ne. iter_cin ) then
4133 :
4134 : ! ------------------------------------------------------------------- !
4135 : ! Save the output from "iter_cin = 1" !
4136 : ! These output will be writed-out if "iter_cin = 1" was not performed !
4137 : ! for some reasons. !
4138 : ! ------------------------------------------------------------------- !
4139 :
4140 0 : qv0_s(:mkx) = qv0(:mkx) + qvten(:mkx) * dt
4141 0 : ql0_s(:mkx) = ql0(:mkx) + qlten(:mkx) * dt
4142 0 : qi0_s(:mkx) = qi0(:mkx) + qiten(:mkx) * dt
4143 0 : s0_s(:mkx) = s0(:mkx) + sten(:mkx) * dt
4144 0 : u0_s(:mkx) = u0(:mkx) + uten(:mkx) * dt
4145 0 : v0_s(:mkx) = v0(:mkx) + vten(:mkx) * dt
4146 0 : qt0_s(:mkx) = qv0_s(:mkx) + ql0_s(:mkx) + qi0_s(:mkx)
4147 0 : t0_s(:mkx) = t0(:mkx) + sten(:mkx) * dt / cp
4148 0 : do m = 1, ncnst
4149 0 : tr0_s(:mkx,m) = tr0(:mkx,m) + trten(:mkx,m) * dt
4150 : enddo
4151 :
4152 0 : umf_s(0:mkx) = umf(0:mkx)
4153 0 : qvten_s(:mkx) = qvten(:mkx)
4154 0 : qlten_s(:mkx) = qlten(:mkx)
4155 0 : qiten_s(:mkx) = qiten(:mkx)
4156 0 : sten_s(:mkx) = sten(:mkx)
4157 0 : uten_s(:mkx) = uten(:mkx)
4158 0 : vten_s(:mkx) = vten(:mkx)
4159 0 : qrten_s(:mkx) = qrten(:mkx)
4160 0 : qsten_s(:mkx) = qsten(:mkx)
4161 0 : precip_s = precip
4162 0 : snow_s = snow
4163 0 : evapc_s(:mkx) = evapc(:mkx)
4164 0 : cush_s = cush
4165 0 : cufrc_s(:mkx) = cufrc(:mkx)
4166 0 : slflx_s(0:mkx) = slflx(0:mkx)
4167 0 : qtflx_s(0:mkx) = qtflx(0:mkx)
4168 0 : qcu_s(:mkx) = qcu(:mkx)
4169 0 : qlu_s(:mkx) = qlu(:mkx)
4170 0 : qiu_s(:mkx) = qiu(:mkx)
4171 0 : fer_s(:mkx) = fer(:mkx)
4172 0 : fdr_s(:mkx) = fdr(:mkx)
4173 0 : cin_s = cin
4174 0 : cinlcl_s = cinlcl
4175 0 : cbmf_s = cbmf
4176 0 : rliq_s = rliq
4177 0 : qc_s(:mkx) = qc(:mkx)
4178 0 : cnt_s = cnt
4179 0 : cnb_s = cnb
4180 0 : qtten_s(:mkx) = qtten(:mkx)
4181 0 : slten_s(:mkx) = slten(:mkx)
4182 0 : ufrc_s(0:mkx) = ufrc(0:mkx)
4183 :
4184 0 : uflx_s(0:mkx) = uflx(0:mkx)
4185 0 : vflx_s(0:mkx) = vflx(0:mkx)
4186 :
4187 0 : ufrcinvbase_s = ufrcinvbase
4188 0 : ufrclcl_s = ufrclcl
4189 0 : winvbase_s = winvbase
4190 0 : wlcl_s = wlcl
4191 0 : plcl_s = plcl
4192 0 : pinv_s = ps0(kinv-1)
4193 0 : plfc_s = plfc
4194 0 : pbup_s = ps0(kbup)
4195 0 : ppen_s = ps0(kpen-1) + ppen
4196 0 : qtsrc_s = qtsrc
4197 0 : thlsrc_s = thlsrc
4198 0 : thvlsrc_s = thvlsrc
4199 0 : emfkbup_s = emf(kbup)
4200 0 : cbmflimit_s = cbmflimit
4201 0 : tkeavg_s = tkeavg
4202 0 : zinv_s = zs0(kinv-1)
4203 0 : rcwp_s = rcwp
4204 0 : rlwp_s = rlwp
4205 0 : riwp_s = riwp
4206 :
4207 0 : wu_s(0:mkx) = wu(0:mkx)
4208 0 : qtu_s(0:mkx) = qtu(0:mkx)
4209 0 : thlu_s(0:mkx) = thlu(0:mkx)
4210 0 : thvu_s(0:mkx) = thvu(0:mkx)
4211 0 : uu_s(0:mkx) = uu(0:mkx)
4212 0 : vu_s(0:mkx) = vu(0:mkx)
4213 0 : qtu_emf_s(0:mkx) = qtu_emf(0:mkx)
4214 0 : thlu_emf_s(0:mkx) = thlu_emf(0:mkx)
4215 0 : uu_emf_s(0:mkx) = uu_emf(0:mkx)
4216 0 : vu_emf_s(0:mkx) = vu_emf(0:mkx)
4217 0 : uemf_s(0:mkx) = uemf(0:mkx)
4218 :
4219 0 : dwten_s(:mkx) = dwten(:mkx)
4220 0 : diten_s(:mkx) = diten(:mkx)
4221 0 : flxrain_s(0:mkx) = flxrain(0:mkx)
4222 0 : flxsnow_s(0:mkx) = flxsnow(0:mkx)
4223 0 : ntraprd_s(:mkx) = ntraprd(:mkx)
4224 0 : ntsnprd_s(:mkx) = ntsnprd(:mkx)
4225 :
4226 0 : excessu_arr_s(:mkx) = excessu_arr(:mkx)
4227 0 : excess0_arr_s(:mkx) = excess0_arr(:mkx)
4228 0 : xc_arr_s(:mkx) = xc_arr(:mkx)
4229 0 : aquad_arr_s(:mkx) = aquad_arr(:mkx)
4230 0 : bquad_arr_s(:mkx) = bquad_arr(:mkx)
4231 0 : cquad_arr_s(:mkx) = cquad_arr(:mkx)
4232 0 : bogbot_arr_s(:mkx) = bogbot_arr(:mkx)
4233 0 : bogtop_arr_s(:mkx) = bogtop_arr(:mkx)
4234 :
4235 0 : do m = 1, ncnst
4236 0 : trten_s(:mkx,m) = trten(:mkx,m)
4237 0 : trflx_s(0:mkx,m) = trflx(0:mkx,m)
4238 0 : tru_s(0:mkx,m) = tru(0:mkx,m)
4239 0 : tru_emf_s(0:mkx,m) = tru_emf(0:mkx,m)
4240 : enddo
4241 :
4242 : ! ----------------------------------------------------------------------------- !
4243 : ! Recalculate environmental variables for new cin calculation at "iter_cin = 2" !
4244 : ! using the updated state variables. Perform only for variables necessary for !
4245 : ! the new cin calculation. !
4246 : ! ----------------------------------------------------------------------------- !
4247 :
4248 0 : qv0(:mkx) = qv0_s(:mkx)
4249 0 : ql0(:mkx) = ql0_s(:mkx)
4250 0 : qi0(:mkx) = qi0_s(:mkx)
4251 0 : s0(:mkx) = s0_s(:mkx)
4252 0 : t0(:mkx) = t0_s(:mkx)
4253 :
4254 0 : qt0(:mkx) = (qv0(:mkx) + ql0(:mkx) + qi0(:mkx))
4255 0 : thl0(:mkx) = (t0(:mkx) - xlv*ql0(:mkx)/cp - xls*qi0(:mkx)/cp)/exn0(:mkx)
4256 0 : thvl0(:mkx) = (1._r8 + zvir*qt0(:mkx))*thl0(:mkx)
4257 :
4258 0 : ssthl0 = slope(mkx,thl0,p0) ! Dimension of ssthl0(:mkx) is implicit
4259 0 : ssqt0 = slope(mkx,qt0 ,p0)
4260 0 : ssu0 = slope(mkx,u0 ,p0)
4261 0 : ssv0 = slope(mkx,v0 ,p0)
4262 0 : do m = 1, ncnst
4263 0 : sstr0(:mkx,m) = slope(mkx,tr0(:mkx,m),p0)
4264 : enddo
4265 :
4266 0 : do k = 1, mkx
4267 :
4268 0 : thl0bot = thl0(k) + ssthl0(k) * ( ps0(k-1) - p0(k) )
4269 0 : qt0bot = qt0(k) + ssqt0(k) * ( ps0(k-1) - p0(k) )
4270 0 : call conden(ps0(k-1),thl0bot,qt0bot,thj,qvj,qlj,qij,qse,id_check)
4271 0 : if( id_check .eq. 1 ) then
4272 0 : exit_conden(i) = 1._r8
4273 0 : id_exit = .true.
4274 0 : go to 333
4275 : end if
4276 0 : thv0bot(k) = thj * ( 1._r8 + zvir*qvj - qlj - qij )
4277 0 : thvl0bot(k) = thl0bot * ( 1._r8 + zvir*qt0bot )
4278 :
4279 0 : thl0top = thl0(k) + ssthl0(k) * ( ps0(k) - p0(k) )
4280 0 : qt0top = qt0(k) + ssqt0(k) * ( ps0(k) - p0(k) )
4281 0 : call conden(ps0(k),thl0top,qt0top,thj,qvj,qlj,qij,qse,id_check)
4282 0 : if( id_check .eq. 1 ) then
4283 0 : exit_conden(i) = 1._r8
4284 0 : id_exit = .true.
4285 0 : go to 333
4286 : end if
4287 0 : thv0top(k) = thj * ( 1._r8 + zvir*qvj - qlj - qij )
4288 0 : thvl0top(k) = thl0top * ( 1._r8 + zvir*qt0top )
4289 :
4290 : end do
4291 :
4292 : endif ! End of 'if(iter .ne. iter_cin)' if sentence.
4293 :
4294 : end do ! End of implicit CIN loop (cin_iter)
4295 :
4296 : ! ----------------------- !
4297 : ! Update Output Variables !
4298 : ! ----------------------- !
4299 :
4300 0 : umf_out(i,0:mkx) = umf(0:mkx)
4301 0 : slflx_out(i,0:mkx) = slflx(0:mkx)
4302 0 : qtflx_out(i,0:mkx) = qtflx(0:mkx)
4303 : !the indices are not reversed, these variables go into compute_mcshallow_inv, this is why they are called "flxprc1" and "flxsnow1".
4304 0 : flxprc1_out(i,0:mkx) = flxrain(0:mkx) + flxsnow(0:mkx)
4305 0 : flxsnow1_out(i,0:mkx) = flxsnow(0:mkx)
4306 0 : qvten_out(i,:mkx) = qvten(:mkx)
4307 0 : qlten_out(i,:mkx) = qlten(:mkx)
4308 0 : qiten_out(i,:mkx) = qiten(:mkx)
4309 0 : sten_out(i,:mkx) = sten(:mkx)
4310 0 : uten_out(i,:mkx) = uten(:mkx)
4311 0 : vten_out(i,:mkx) = vten(:mkx)
4312 0 : qrten_out(i,:mkx) = qrten(:mkx)
4313 0 : qsten_out(i,:mkx) = qsten(:mkx)
4314 0 : precip_out(i) = precip
4315 0 : snow_out(i) = snow
4316 0 : evapc_out(i,:mkx) = evapc(:mkx)
4317 0 : cufrc_out(i,:mkx) = cufrc(:mkx)
4318 0 : qcu_out(i,:mkx) = qcu(:mkx)
4319 0 : qlu_out(i,:mkx) = qlu(:mkx)
4320 0 : qiu_out(i,:mkx) = qiu(:mkx)
4321 0 : cush_inout(i) = cush
4322 0 : cbmf_out(i) = cbmf
4323 0 : rliq_out(i) = rliq
4324 0 : qc_out(i,:mkx) = qc(:mkx)
4325 0 : cnt_out(i) = cnt
4326 0 : cnb_out(i) = cnb
4327 :
4328 0 : do m = 1, ncnst
4329 0 : trten_out(i,:mkx,m) = trten(:mkx,m)
4330 : enddo
4331 :
4332 : ! ------------------------------------------------- !
4333 : ! Below are specific diagnostic output for detailed !
4334 : ! analysis of cumulus scheme !
4335 : ! ------------------------------------------------- !
4336 :
4337 0 : fer_out(i,mkx:1:-1) = fer(:mkx)
4338 0 : fdr_out(i,mkx:1:-1) = fdr(:mkx)
4339 0 : cinh_out(i) = cin
4340 0 : cinlclh_out(i) = cinlcl
4341 0 : qtten_out(i,mkx:1:-1) = qtten(:mkx)
4342 0 : slten_out(i,mkx:1:-1) = slten(:mkx)
4343 0 : ufrc_out(i,mkx:0:-1) = ufrc(0:mkx)
4344 0 : uflx_out(i,mkx:0:-1) = uflx(0:mkx)
4345 0 : vflx_out(i,mkx:0:-1) = vflx(0:mkx)
4346 :
4347 0 : ufrcinvbase_out(i) = ufrcinvbase
4348 0 : ufrclcl_out(i) = ufrclcl
4349 0 : winvbase_out(i) = winvbase
4350 0 : wlcl_out(i) = wlcl
4351 0 : plcl_out(i) = plcl
4352 0 : pinv_out(i) = ps0(kinv-1)
4353 0 : plfc_out(i) = plfc
4354 0 : pbup_out(i) = ps0(kbup)
4355 0 : ppen_out(i) = ps0(kpen-1) + ppen
4356 0 : qtsrc_out(i) = qtsrc
4357 0 : thlsrc_out(i) = thlsrc
4358 0 : thvlsrc_out(i) = thvlsrc
4359 0 : emfkbup_out(i) = emf(kbup)
4360 0 : cbmflimit_out(i) = cbmflimit
4361 0 : tkeavg_out(i) = tkeavg
4362 0 : zinv_out(i) = zs0(kinv-1)
4363 0 : rcwp_out(i) = rcwp
4364 0 : rlwp_out(i) = rlwp
4365 0 : riwp_out(i) = riwp
4366 :
4367 0 : wu_out(i,mkx:0:-1) = wu(0:mkx)
4368 0 : qtu_out(i,mkx:0:-1) = qtu(0:mkx)
4369 0 : thlu_out(i,mkx:0:-1) = thlu(0:mkx)
4370 0 : thvu_out(i,mkx:0:-1) = thvu(0:mkx)
4371 0 : uu_out(i,mkx:0:-1) = uu(0:mkx)
4372 0 : vu_out(i,mkx:0:-1) = vu(0:mkx)
4373 0 : qtu_emf_out(i,mkx:0:-1) = qtu_emf(0:mkx)
4374 0 : thlu_emf_out(i,mkx:0:-1) = thlu_emf(0:mkx)
4375 0 : uu_emf_out(i,mkx:0:-1) = uu_emf(0:mkx)
4376 0 : vu_emf_out(i,mkx:0:-1) = vu_emf(0:mkx)
4377 0 : uemf_out(i,mkx:0:-1) = uemf(0:mkx)
4378 :
4379 0 : dwten_out(i,mkx:1:-1) = dwten(:mkx)
4380 0 : diten_out(i,mkx:1:-1) = diten(:mkx)
4381 0 : flxrain_out(i,mkx:0:-1) = flxrain(0:mkx)
4382 0 : flxsnow_out(i,mkx:0:-1) = flxsnow(0:mkx)
4383 0 : ntraprd_out(i,mkx:1:-1) = ntraprd(:mkx)
4384 0 : ntsnprd_out(i,mkx:1:-1) = ntsnprd(:mkx)
4385 :
4386 0 : excessu_arr_out(i,mkx:1:-1) = excessu_arr(:mkx)
4387 0 : excess0_arr_out(i,mkx:1:-1) = excess0_arr(:mkx)
4388 0 : xc_arr_out(i,mkx:1:-1) = xc_arr(:mkx)
4389 0 : aquad_arr_out(i,mkx:1:-1) = aquad_arr(:mkx)
4390 0 : bquad_arr_out(i,mkx:1:-1) = bquad_arr(:mkx)
4391 0 : cquad_arr_out(i,mkx:1:-1) = cquad_arr(:mkx)
4392 0 : bogbot_arr_out(i,mkx:1:-1) = bogbot_arr(:mkx)
4393 0 : bogtop_arr_out(i,mkx:1:-1) = bogtop_arr(:mkx)
4394 :
4395 0 : do m = 1, ncnst
4396 0 : trflx_out(i,mkx:0:-1,m) = trflx(0:mkx,m)
4397 0 : tru_out(i,mkx:0:-1,m) = tru(0:mkx,m)
4398 0 : tru_emf_out(i,mkx:0:-1,m) = tru_emf(0:mkx,m)
4399 : enddo
4400 :
4401 0 : 333 if(id_exit) then ! Exit without cumulus convection
4402 :
4403 0 : exit_UWCu(i) = 1._r8
4404 :
4405 : ! --------------------------------------------------------------------- !
4406 : ! Initialize output variables when cumulus convection was not performed.!
4407 : ! --------------------------------------------------------------------- !
4408 :
4409 0 : umf_out(i,0:mkx) = 0._r8
4410 0 : slflx_out(i,0:mkx) = 0._r8
4411 0 : qtflx_out(i,0:mkx) = 0._r8
4412 0 : qvten_out(i,:mkx) = 0._r8
4413 0 : qlten_out(i,:mkx) = 0._r8
4414 0 : qiten_out(i,:mkx) = 0._r8
4415 0 : sten_out(i,:mkx) = 0._r8
4416 0 : uten_out(i,:mkx) = 0._r8
4417 0 : vten_out(i,:mkx) = 0._r8
4418 0 : qrten_out(i,:mkx) = 0._r8
4419 0 : qsten_out(i,:mkx) = 0._r8
4420 0 : precip_out(i) = 0._r8
4421 0 : snow_out(i) = 0._r8
4422 0 : evapc_out(i,:mkx) = 0._r8
4423 0 : cufrc_out(i,:mkx) = 0._r8
4424 0 : qcu_out(i,:mkx) = 0._r8
4425 0 : qlu_out(i,:mkx) = 0._r8
4426 0 : qiu_out(i,:mkx) = 0._r8
4427 0 : cush_inout(i) = -1._r8
4428 0 : cbmf_out(i) = 0._r8
4429 0 : rliq_out(i) = 0._r8
4430 0 : qc_out(i,:mkx) = 0._r8
4431 0 : cnt_out(i) = 1._r8
4432 0 : cnb_out(i) = real(mkx, r8)
4433 :
4434 0 : fer_out(i,mkx:1:-1) = 0._r8
4435 0 : fdr_out(i,mkx:1:-1) = 0._r8
4436 0 : cinh_out(i) = -1._r8
4437 0 : cinlclh_out(i) = -1._r8
4438 0 : qtten_out(i,mkx:1:-1) = 0._r8
4439 0 : slten_out(i,mkx:1:-1) = 0._r8
4440 0 : ufrc_out(i,mkx:0:-1) = 0._r8
4441 0 : uflx_out(i,mkx:0:-1) = 0._r8
4442 0 : vflx_out(i,mkx:0:-1) = 0._r8
4443 :
4444 0 : ufrcinvbase_out(i) = 0._r8
4445 0 : ufrclcl_out(i) = 0._r8
4446 0 : winvbase_out(i) = 0._r8
4447 0 : wlcl_out(i) = 0._r8
4448 0 : plcl_out(i) = 0._r8
4449 0 : pinv_out(i) = 0._r8
4450 0 : plfc_out(i) = 0._r8
4451 0 : pbup_out(i) = 0._r8
4452 0 : ppen_out(i) = 0._r8
4453 0 : qtsrc_out(i) = 0._r8
4454 0 : thlsrc_out(i) = 0._r8
4455 0 : thvlsrc_out(i) = 0._r8
4456 0 : emfkbup_out(i) = 0._r8
4457 0 : cbmflimit_out(i) = 0._r8
4458 0 : tkeavg_out(i) = 0._r8
4459 0 : zinv_out(i) = 0._r8
4460 0 : rcwp_out(i) = 0._r8
4461 0 : rlwp_out(i) = 0._r8
4462 0 : riwp_out(i) = 0._r8
4463 :
4464 0 : wu_out(i,mkx:0:-1) = 0._r8
4465 0 : qtu_out(i,mkx:0:-1) = 0._r8
4466 0 : thlu_out(i,mkx:0:-1) = 0._r8
4467 0 : thvu_out(i,mkx:0:-1) = 0._r8
4468 0 : uu_out(i,mkx:0:-1) = 0._r8
4469 0 : vu_out(i,mkx:0:-1) = 0._r8
4470 0 : qtu_emf_out(i,mkx:0:-1) = 0._r8
4471 0 : thlu_emf_out(i,mkx:0:-1) = 0._r8
4472 0 : uu_emf_out(i,mkx:0:-1) = 0._r8
4473 0 : vu_emf_out(i,mkx:0:-1) = 0._r8
4474 0 : uemf_out(i,mkx:0:-1) = 0._r8
4475 :
4476 0 : dwten_out(i,mkx:1:-1) = 0._r8
4477 0 : diten_out(i,mkx:1:-1) = 0._r8
4478 0 : flxrain_out(i,mkx:0:-1) = 0._r8
4479 0 : flxsnow_out(i,mkx:0:-1) = 0._r8
4480 0 : ntraprd_out(i,mkx:1:-1) = 0._r8
4481 0 : ntsnprd_out(i,mkx:1:-1) = 0._r8
4482 :
4483 0 : excessu_arr_out(i,mkx:1:-1) = 0._r8
4484 0 : excess0_arr_out(i,mkx:1:-1) = 0._r8
4485 0 : xc_arr_out(i,mkx:1:-1) = 0._r8
4486 0 : aquad_arr_out(i,mkx:1:-1) = 0._r8
4487 0 : bquad_arr_out(i,mkx:1:-1) = 0._r8
4488 0 : cquad_arr_out(i,mkx:1:-1) = 0._r8
4489 0 : bogbot_arr_out(i,mkx:1:-1) = 0._r8
4490 0 : bogtop_arr_out(i,mkx:1:-1) = 0._r8
4491 :
4492 0 : do m = 1, ncnst
4493 0 : trten_out(i,:mkx,m) = 0._r8
4494 0 : trflx_out(i,mkx:0:-1,m) = 0._r8
4495 0 : tru_out(i,mkx:0:-1,m) = 0._r8
4496 0 : tru_emf_out(i,mkx:0:-1,m) = 0._r8
4497 : enddo
4498 :
4499 : end if
4500 :
4501 : end do ! end of big i loop for each column.
4502 :
4503 : ! ---------------------------------------- !
4504 : ! Writing main diagnostic output variables !
4505 : ! ---------------------------------------- !
4506 :
4507 0 : call outfld( 'qtflx_Cu' , qtflx_out(:,mkx:0:-1), mix, lchnk )
4508 0 : call outfld( 'slflx_Cu' , slflx_out(:,mkx:0:-1), mix, lchnk )
4509 0 : call outfld( 'uflx_Cu' , uflx_out, mix, lchnk )
4510 0 : call outfld( 'vflx_Cu' , vflx_out, mix, lchnk )
4511 :
4512 0 : call outfld( 'qtten_Cu' , qtten_out, mix, lchnk )
4513 0 : call outfld( 'slten_Cu' , slten_out, mix, lchnk )
4514 0 : call outfld( 'uten_Cu' , uten_out(:,mkx:1:-1), mix, lchnk )
4515 0 : call outfld( 'vten_Cu' , vten_out(:,mkx:1:-1), mix, lchnk )
4516 0 : call outfld( 'qvten_Cu' , qvten_out(:,mkx:1:-1), mix, lchnk )
4517 0 : call outfld( 'qlten_Cu' , qlten_out(:,mkx:1:-1), mix, lchnk )
4518 0 : call outfld( 'qiten_Cu' , qiten_out(:,mkx:1:-1), mix, lchnk )
4519 :
4520 0 : call outfld( 'cbmf_Cu' , cbmf_out, mix, lchnk )
4521 0 : call outfld( 'ufrcinvbase_Cu' , ufrcinvbase_out, mix, lchnk )
4522 0 : call outfld( 'ufrclcl_Cu' , ufrclcl_out, mix, lchnk )
4523 0 : call outfld( 'winvbase_Cu' , winvbase_out, mix, lchnk )
4524 0 : call outfld( 'wlcl_Cu' , wlcl_out, mix, lchnk )
4525 0 : call outfld( 'plcl_Cu' , plcl_out, mix, lchnk )
4526 0 : call outfld( 'pinv_Cu' , pinv_out, mix, lchnk )
4527 0 : call outfld( 'plfc_Cu' , plfc_out, mix, lchnk )
4528 0 : call outfld( 'pbup_Cu' , pbup_out, mix, lchnk )
4529 0 : call outfld( 'ppen_Cu' , ppen_out, mix, lchnk )
4530 0 : call outfld( 'qtsrc_Cu' , qtsrc_out, mix, lchnk )
4531 0 : call outfld( 'thlsrc_Cu' , thlsrc_out, mix, lchnk )
4532 0 : call outfld( 'thvlsrc_Cu' , thvlsrc_out, mix, lchnk )
4533 0 : call outfld( 'emfkbup_Cu' , emfkbup_out, mix, lchnk )
4534 0 : call outfld( 'cin_Cu' , cinh_out, mix, lchnk )
4535 0 : call outfld( 'cinlcl_Cu' , cinlclh_out, mix, lchnk )
4536 0 : call outfld( 'cbmflimit_Cu' , cbmflimit_out, mix, lchnk )
4537 0 : call outfld( 'tkeavg_Cu' , tkeavg_out, mix, lchnk )
4538 0 : call outfld( 'zinv_Cu' , zinv_out, mix, lchnk )
4539 0 : call outfld( 'rcwp_Cu' , rcwp_out, mix, lchnk )
4540 0 : call outfld( 'rlwp_Cu' , rlwp_out, mix, lchnk )
4541 0 : call outfld( 'riwp_Cu' , riwp_out, mix, lchnk )
4542 0 : call outfld( 'tophgt_Cu' , cush_inout, mix, lchnk )
4543 :
4544 0 : call outfld( 'wu_Cu' , wu_out, mix, lchnk )
4545 0 : call outfld( 'ufrc_Cu' , ufrc_out, mix, lchnk )
4546 0 : call outfld( 'qtu_Cu' , qtu_out, mix, lchnk )
4547 0 : call outfld( 'thlu_Cu' , thlu_out, mix, lchnk )
4548 0 : call outfld( 'thvu_Cu' , thvu_out, mix, lchnk )
4549 0 : call outfld( 'uu_Cu' , uu_out, mix, lchnk )
4550 0 : call outfld( 'vu_Cu' , vu_out, mix, lchnk )
4551 0 : call outfld( 'qtu_emf_Cu' , qtu_emf_out, mix, lchnk )
4552 0 : call outfld( 'thlu_emf_Cu' , thlu_emf_out, mix, lchnk )
4553 0 : call outfld( 'uu_emf_Cu' , uu_emf_out, mix, lchnk )
4554 0 : call outfld( 'vu_emf_Cu' , vu_emf_out, mix, lchnk )
4555 0 : call outfld( 'umf_Cu' , umf_out(:,mkx:0:-1), mix, lchnk )
4556 0 : call outfld( 'uemf_Cu' , uemf_out, mix, lchnk )
4557 0 : call outfld( 'qcu_Cu' , qcu_out(:,mkx:1:-1), mix, lchnk )
4558 0 : call outfld( 'qlu_Cu' , qlu_out(:,mkx:1:-1), mix, lchnk )
4559 0 : call outfld( 'qiu_Cu' , qiu_out(:,mkx:1:-1), mix, lchnk )
4560 0 : call outfld( 'cufrc_Cu' , cufrc_out(:,mkx:1:-1), mix, lchnk )
4561 0 : call outfld( 'fer_Cu' , fer_out, mix, lchnk )
4562 0 : call outfld( 'fdr_Cu' , fdr_out, mix, lchnk )
4563 :
4564 0 : call outfld( 'dwten_Cu' , dwten_out, mix, lchnk )
4565 0 : call outfld( 'diten_Cu' , diten_out, mix, lchnk )
4566 0 : call outfld( 'qrten_Cu' , qrten_out(:,mkx:1:-1), mix, lchnk )
4567 0 : call outfld( 'qsten_Cu' , qsten_out(:,mkx:1:-1), mix, lchnk )
4568 0 : call outfld( 'flxrain_Cu' , flxrain_out, mix, lchnk )
4569 0 : call outfld( 'flxsnow_Cu' , flxsnow_out, mix, lchnk )
4570 0 : call outfld( 'ntraprd_Cu' , ntraprd_out, mix, lchnk )
4571 0 : call outfld( 'ntsnprd_Cu' , ntsnprd_out, mix, lchnk )
4572 :
4573 0 : call outfld( 'excessu_Cu' , excessu_arr_out, mix, lchnk )
4574 0 : call outfld( 'excess0_Cu' , excess0_arr_out, mix, lchnk )
4575 0 : call outfld( 'xc_Cu' , xc_arr_out, mix, lchnk )
4576 0 : call outfld( 'aquad_Cu' , aquad_arr_out, mix, lchnk )
4577 0 : call outfld( 'bquad_Cu' , bquad_arr_out, mix, lchnk )
4578 0 : call outfld( 'cquad_Cu' , cquad_arr_out, mix, lchnk )
4579 0 : call outfld( 'bogbot_Cu' , bogbot_arr_out, mix, lchnk )
4580 0 : call outfld( 'bogtop_Cu' , bogtop_arr_out, mix, lchnk )
4581 :
4582 0 : call outfld( 'exit_UWCu_Cu' , exit_UWCu, mix, lchnk )
4583 0 : call outfld( 'exit_conden_Cu' , exit_conden, mix, lchnk )
4584 0 : call outfld( 'exit_klclmkx_Cu' , exit_klclmkx, mix, lchnk )
4585 0 : call outfld( 'exit_klfcmkx_Cu' , exit_klfcmkx, mix, lchnk )
4586 0 : call outfld( 'exit_ufrc_Cu' , exit_ufrc, mix, lchnk )
4587 0 : call outfld( 'exit_wtw_Cu' , exit_wtw, mix, lchnk )
4588 0 : call outfld( 'exit_drycore_Cu' , exit_drycore, mix, lchnk )
4589 0 : call outfld( 'exit_wu_Cu' , exit_wu, mix, lchnk )
4590 0 : call outfld( 'exit_cufilter_Cu', exit_cufilter, mix, lchnk )
4591 0 : call outfld( 'exit_kinv1_Cu' , exit_kinv1, mix, lchnk )
4592 0 : call outfld( 'exit_rei_Cu' , exit_rei, mix, lchnk )
4593 :
4594 0 : call outfld( 'limit_shcu_Cu' , limit_shcu, mix, lchnk )
4595 0 : call outfld( 'limit_negcon_Cu' , limit_negcon, mix, lchnk )
4596 0 : call outfld( 'limit_ufrc_Cu' , limit_ufrc, mix, lchnk )
4597 0 : call outfld( 'limit_ppen_Cu' , limit_ppen, mix, lchnk )
4598 0 : call outfld( 'limit_emf_Cu' , limit_emf, mix, lchnk )
4599 0 : call outfld( 'limit_cinlcl_Cu' , limit_cinlcl, mix, lchnk )
4600 0 : call outfld( 'limit_cin_Cu' , limit_cin, mix, lchnk )
4601 0 : call outfld( 'limit_cbmf_Cu' , limit_cbmf, mix, lchnk )
4602 0 : call outfld( 'limit_rei_Cu' , limit_rei, mix, lchnk )
4603 0 : call outfld( 'ind_delcin_Cu' , ind_delcin, mix, lchnk )
4604 :
4605 0 : return
4606 :
4607 0 : end subroutine compute_uwshcu
4608 :
4609 : ! ------------------------------ !
4610 : ! !
4611 : ! Beginning of subroutine blocks !
4612 : ! !
4613 : ! ------------------------------ !
4614 :
4615 0 : subroutine getbuoy(pbot,thv0bot,ptop,thv0top,thvubot,thvutop,plfc,cin)
4616 : ! ----------------------------------------------------------- !
4617 : ! Subroutine to calculate integrated CIN [ J/kg = m2/s2 ] and !
4618 : ! 'cinlcl, plfc' if any. Assume 'thv' is linear in each layer !
4619 : ! both for cumulus and environment. Note that this subroutine !
4620 : ! only include positive CIN in calculation - if there are any !
4621 : ! negative CIN, it is assumed to be zero. This is slightly !
4622 : ! different from 'single_cin' below, where both positive and !
4623 : ! negative CIN are included. !
4624 : ! ----------------------------------------------------------- !
4625 : real(r8) pbot,thv0bot,ptop,thv0top,thvubot,thvutop,plfc,cin,frc
4626 :
4627 0 : if( thvubot .gt. thv0bot .and. thvutop .gt. thv0top ) then
4628 0 : plfc = pbot
4629 0 : return
4630 0 : elseif( thvubot .le. thv0bot .and. thvutop .le. thv0top ) then
4631 : cin = cin - ( (thvubot/thv0bot - 1._r8) + (thvutop/thv0top - 1._r8)) * (pbot - ptop) / &
4632 0 : ( pbot/(r*thv0bot*exnf(pbot)) + ptop/(r*thv0top*exnf(ptop)) )
4633 0 : elseif( thvubot .gt. thv0bot .and. thvutop .le. thv0top ) then
4634 0 : frc = ( thvutop/thv0top - 1._r8 ) / ( (thvutop/thv0top - 1._r8) - (thvubot/thv0bot - 1._r8) )
4635 : cin = cin - ( thvutop/thv0top - 1._r8 ) * ( (ptop + frc*(pbot - ptop)) - ptop ) / &
4636 0 : ( pbot/(r*thv0bot*exnf(pbot)) + ptop/(r*thv0top*exnf(ptop)) )
4637 : else
4638 0 : frc = ( thvubot/thv0bot - 1._r8 ) / ( (thvubot/thv0bot - 1._r8) - (thvutop/thv0top - 1._r8) )
4639 0 : plfc = pbot - frc * ( pbot - ptop )
4640 : cin = cin - ( thvubot/thv0bot - 1._r8)*(pbot - plfc)/ &
4641 0 : ( pbot/(r*thv0bot*exnf(pbot)) + ptop/(r*thv0top * exnf(ptop)))
4642 : endif
4643 :
4644 : return
4645 0 : end subroutine getbuoy
4646 :
4647 0 : function single_cin(pbot,thv0bot,ptop,thv0top,thvubot,thvutop)
4648 : ! ------------------------------------------------------- !
4649 : ! Function to calculate a single layer CIN by summing all !
4650 : ! positive and negative CIN. !
4651 : ! ------------------------------------------------------- !
4652 : real(r8) :: single_cin
4653 : real(r8) pbot,thv0bot,ptop,thv0top,thvubot,thvutop
4654 :
4655 : single_cin = ( (1._r8 - thvubot/thv0bot) + (1._r8 - thvutop/thv0top)) * ( pbot - ptop ) / &
4656 0 : ( pbot/(r*thv0bot*exnf(pbot)) + ptop/(r*thv0top*exnf(ptop)) )
4657 : return
4658 : end function single_cin
4659 :
4660 :
4661 0 : subroutine conden(p,thl,qt,th,qv,ql,qi,rvls,id_check)
4662 : ! --------------------------------------------------------------------- !
4663 : ! Calculate thermodynamic properties from a given set of ( p, thl, qt ) !
4664 : ! --------------------------------------------------------------------- !
4665 : implicit none
4666 : real(r8), intent(in) :: p
4667 : real(r8), intent(in) :: thl
4668 : real(r8), intent(in) :: qt
4669 : real(r8), intent(out) :: th
4670 : real(r8), intent(out) :: qv
4671 : real(r8), intent(out) :: ql
4672 : real(r8), intent(out) :: qi
4673 : real(r8), intent(out) :: rvls
4674 : integer , intent(out) :: id_check
4675 : real(r8) :: tc,temps,t
4676 : real(r8) :: leff, nu, qc
4677 : integer :: iteration
4678 : real(r8) :: es ! Saturation vapor pressure
4679 : real(r8) :: qs ! Saturation spec. humidity
4680 :
4681 :
4682 0 : tc = thl*exnf(p)
4683 : ! Modification : In order to be compatible with the dlf treatment in stratiform.F90,
4684 : ! we may use ( 268.15, 238.15 ) with 30K ramping instead of 20 K,
4685 : ! in computing ice fraction below.
4686 : ! Note that 'cldfrc_fice' uses ( 243.15, 263.15 ) with 20K ramping for stratus.
4687 0 : nu = max(min((268._r8 - tc)/20._r8,1.0_r8),0.0_r8) ! Fraction of ice in the condensate.
4688 0 : leff = (1._r8 - nu)*xlv + nu*xls ! This is an estimate that hopefully speeds convergence
4689 :
4690 : ! --------------------------------------------------------------------------- !
4691 : ! Below "temps" and "rvls" are just initial guesses for iteration loop below. !
4692 : ! Note that the output "temps" from the below iteration loop is "temperature" !
4693 : ! NOT "liquid temperature". !
4694 : ! --------------------------------------------------------------------------- !
4695 :
4696 0 : temps = tc
4697 0 : call qsat(temps, p, es, qs)
4698 0 : rvls = qs
4699 :
4700 0 : if( qs .ge. qt ) then
4701 0 : id_check = 0
4702 0 : qv = qt
4703 0 : qc = 0._r8
4704 0 : ql = 0._r8
4705 0 : qi = 0._r8
4706 0 : th = tc/exnf(p)
4707 : else
4708 0 : do iteration = 1, 10
4709 0 : temps = temps + ( (tc-temps)*cp/leff + qt - rvls )/( cp/leff + ep2*leff*rvls/r/temps/temps )
4710 0 : call qsat(temps, p, es, qs)
4711 0 : rvls = qs
4712 : end do
4713 0 : qc = max(qt - qs,0._r8)
4714 0 : qv = qt - qc
4715 0 : ql = qc*(1._r8 - nu)
4716 0 : qi = nu*qc
4717 0 : th = temps/exnf(p)
4718 0 : if( abs((temps-(leff/cp)*qc)-tc) .ge. 1._r8 ) then
4719 0 : id_check = 1
4720 : else
4721 0 : id_check = 0
4722 : end if
4723 : end if
4724 :
4725 0 : return
4726 : end subroutine conden
4727 :
4728 0 : subroutine roots(a,b,c,r1,r2,status)
4729 : ! --------------------------------------------------------- !
4730 : ! Subroutine to solve the second order polynomial equation. !
4731 : ! I should check this subroutine later. !
4732 : ! --------------------------------------------------------- !
4733 : real(r8), intent(in) :: a
4734 : real(r8), intent(in) :: b
4735 : real(r8), intent(in) :: c
4736 : real(r8), intent(out) :: r1
4737 : real(r8), intent(out) :: r2
4738 : integer , intent(out) :: status
4739 : real(r8) :: q
4740 :
4741 0 : status = 0
4742 :
4743 0 : if( a .eq. 0._r8 ) then ! Form b*x + c = 0
4744 0 : if( b .eq. 0._r8 ) then ! Failure: c = 0
4745 0 : status = 1
4746 : else ! b*x + c = 0
4747 0 : r1 = -c/b
4748 : endif
4749 0 : r2 = r1
4750 : else
4751 0 : if( b .eq. 0._r8 ) then ! Form a*x**2 + c = 0
4752 0 : if( a*c .gt. 0._r8 ) then ! Failure: x**2 = -c/a < 0
4753 0 : status = 2
4754 : else ! x**2 = -c/a
4755 0 : r1 = sqrt(-c/a)
4756 : endif
4757 0 : r2 = -r1
4758 : else ! Form a*x**2 + b*x + c = 0
4759 0 : if( (b**2 - 4._r8*a*c) .lt. 0._r8 ) then ! Failure, no real roots
4760 0 : status = 3
4761 : else
4762 0 : q = -0.5_r8*(b + sign(1.0_r8,b)*sqrt(b**2 - 4._r8*a*c))
4763 0 : r1 = q/a
4764 0 : r2 = c/q
4765 : endif
4766 : endif
4767 : endif
4768 :
4769 0 : return
4770 : end subroutine roots
4771 :
4772 0 : function slope(mkx,field,p0)
4773 : ! ------------------------------------------------------------------ !
4774 : ! Function performing profile reconstruction of conservative scalars !
4775 : ! in each layer. This is identical to profile reconstruction used in !
4776 : ! UW-PBL scheme but from bottom to top layer here. At the lowest !
4777 : ! layer near to surface, slope is defined using the two lowest layer !
4778 : ! mid-point values. I checked this subroutine and it is correct. !
4779 : ! ------------------------------------------------------------------ !
4780 : integer, intent(in) :: mkx
4781 : real(r8) :: slope(mkx)
4782 : real(r8), intent(in) :: field(mkx)
4783 : real(r8), intent(in) :: p0(mkx)
4784 :
4785 : real(r8) :: below
4786 : real(r8) :: above
4787 : integer :: k
4788 :
4789 0 : below = ( field(2) - field(1) ) / ( p0(2) - p0(1) )
4790 0 : do k = 2, mkx
4791 0 : above = ( field(k) - field(k-1) ) / ( p0(k) - p0(k-1) )
4792 0 : if( above .gt. 0._r8 ) then
4793 0 : slope(k-1) = max(0._r8,min(above,below))
4794 : else
4795 0 : slope(k-1) = min(0._r8,max(above,below))
4796 : end if
4797 0 : below = above
4798 : end do
4799 0 : slope(mkx) = slope(mkx-1)
4800 :
4801 0 : return
4802 : end function slope
4803 :
4804 0 : function qsinvert(qt,thl,psfc)
4805 : ! ----------------------------------------------------------------- !
4806 : ! Function calculating saturation pressure ps (or pLCL) from qt and !
4807 : ! thl ( liquid potential temperature, NOT liquid virtual potential !
4808 : ! temperature) by inverting Bolton formula. I should check later if !
4809 : ! current use of 'leff' instead of 'xlv' here is reasonable or not. !
4810 : ! ----------------------------------------------------------------- !
4811 : real(r8) :: qsinvert
4812 : real(r8) qt, thl, psfc
4813 : real(r8) ps, Pis, Ts, err, dlnqsdT, dTdPis
4814 : real(r8) dPisdps, dlnqsdps, derrdps, dps
4815 : real(r8) Ti, rhi, TLCL, PiLCL, psmin, dpsmax
4816 : integer i
4817 : real(r8) :: es ! saturation vapor pressure
4818 : real(r8) :: qs ! saturation spec. humidity
4819 : real(r8) :: gam ! (L/cp)*dqs/dT
4820 : real(r8) :: leff, nu
4821 :
4822 0 : psmin = 100._r8*100._r8 ! Default saturation pressure [Pa] if iteration does not converge
4823 0 : dpsmax = 1._r8 ! Tolerance [Pa] for convergence of iteration
4824 :
4825 : ! ------------------------------------ !
4826 : ! Calculate best initial guess of pLCL !
4827 : ! ------------------------------------ !
4828 :
4829 0 : Ti = thl*(psfc/p00)**rovcp
4830 0 : call qsat(Ti, psfc, es, qs)
4831 0 : rhi = qt/qs
4832 0 : if( rhi .le. 0.01_r8 ) then
4833 0 : write(iulog,*) 'Source air is too dry and pLCL is set to psmin in uwshcu.F90'
4834 0 : qsinvert = psmin
4835 0 : return
4836 : end if
4837 0 : TLCL = 55._r8 + 1._r8/(1._r8/(Ti-55._r8)-log(rhi)/2840._r8); ! Bolton's formula. MWR.1980.Eq.(22)
4838 0 : PiLCL = TLCL/thl
4839 0 : ps = p00*(PiLCL)**(1._r8/rovcp)
4840 :
4841 0 : do i = 1, 10
4842 0 : Pis = (ps/p00)**rovcp
4843 0 : Ts = thl*Pis
4844 0 : call qsat(Ts, ps, es, qs, gam=gam)
4845 0 : err = qt - qs
4846 0 : nu = max(min((268._r8 - Ts)/20._r8,1.0_r8),0.0_r8)
4847 0 : leff = (1._r8 - nu)*xlv + nu*xls
4848 0 : dlnqsdT = gam*(cp/leff)/qs
4849 0 : dTdPis = thl
4850 0 : dPisdps = rovcp*Pis/ps
4851 0 : dlnqsdps = -1._r8/(ps - (1._r8 - ep2)*es)
4852 0 : derrdps = -qs*(dlnqsdT * dTdPis * dPisdps + dlnqsdps)
4853 0 : dps = -err/derrdps
4854 0 : ps = ps + dps
4855 0 : if( ps .lt. 0._r8 ) then
4856 0 : write(iulog,*) 'pLCL iteration is negative and set to psmin in uwshcu.F90', qt, thl, psfc
4857 0 : qsinvert = psmin
4858 0 : return
4859 : end if
4860 0 : if( abs(dps) .le. dpsmax ) then
4861 0 : qsinvert = ps
4862 : return
4863 : end if
4864 : end do
4865 0 : write(iulog,*) 'pLCL does not converge and is set to psmin in uwshcu.F90', qt, thl, psfc
4866 0 : qsinvert = psmin
4867 0 : return
4868 : end function qsinvert
4869 :
4870 0 : real(r8) function compute_alpha(del_CIN,ke)
4871 : ! ------------------------------------------------ !
4872 : ! Subroutine to compute proportionality factor for !
4873 : ! implicit CIN calculation. !
4874 : ! ------------------------------------------------ !
4875 : real(r8) :: del_CIN, ke
4876 : real(r8) :: x0, x1
4877 :
4878 : integer :: iteration
4879 :
4880 0 : x0 = 0._r8
4881 0 : do iteration = 1, 10
4882 0 : x1 = x0 - (exp(-x0*ke*del_CIN) - x0)/(-ke*del_CIN*exp(-x0*ke*del_CIN) - 1._r8)
4883 0 : x0 = x1
4884 : end do
4885 0 : compute_alpha = x0
4886 :
4887 : return
4888 :
4889 : end function compute_alpha
4890 :
4891 0 : real(r8) function compute_mumin2(mulcl,rmaxfrac,mulow)
4892 : ! --------------------------------------------------------- !
4893 : ! Subroutine to compute critical 'mu' (normalized CIN) such !
4894 : ! that updraft fraction at the LCL is equal to 'rmaxfrac'. !
4895 : ! --------------------------------------------------------- !
4896 : real(r8) :: mulcl, rmaxfrac, mulow
4897 : real(r8) :: x0, x1, ex, ef, exf, f, fs
4898 : integer :: iteration
4899 :
4900 0 : x0 = mulow
4901 0 : do iteration = 1, 10
4902 0 : ex = exp(-x0**2)
4903 0 : ef = erfc(x0)
4904 : ! if(x0.ge.3._r8) then
4905 : ! compute_mumin2 = 3._r8
4906 : ! goto 20
4907 : ! endif
4908 0 : exf = ex/ef
4909 0 : f = 0.5_r8*exf**2 - 0.5_r8*(ex/2._r8/rmaxfrac)**2 - (mulcl*2.5066_r8/2._r8)**2
4910 0 : fs = (2._r8*exf**2)*(exf/sqrt(3.141592_r8)-x0) + (0.5_r8*x0*ex**2)/(rmaxfrac**2)
4911 0 : x1 = x0 - f/fs
4912 0 : x0 = x1
4913 : end do
4914 0 : compute_mumin2 = x0
4915 :
4916 : 20 return
4917 :
4918 : end function compute_mumin2
4919 :
4920 0 : real(r8) function compute_ppen(wtwb,D,bogbot,bogtop,rho0j,dpen)
4921 : ! ----------------------------------------------------------- !
4922 : ! Subroutine to compute critical 'ppen[Pa]<0' ( pressure dis. !
4923 : ! from 'ps0(kpen-1)' to the cumulus top where cumulus updraft !
4924 : ! vertical velocity is exactly zero ) by considering exact !
4925 : ! non-zero fer(kpen). !
4926 : ! ----------------------------------------------------------- !
4927 : real(r8) :: wtwb, D, bogbot, bogtop, rho0j, dpen
4928 : real(r8) :: x0, x1, f, fs, SB, s00
4929 : integer :: iteration
4930 :
4931 : ! Buoyancy slope
4932 0 : SB = ( bogtop - bogbot ) / dpen
4933 : ! Sign of slope, 'f' at x = 0
4934 : ! If 's00>0', 'w' increases with height.
4935 0 : s00 = bogbot / rho0j - D * wtwb
4936 :
4937 0 : if( D*dpen .lt. 1.e-8_r8 ) then
4938 0 : if( s00 .ge. 0._r8 ) then
4939 : x0 = dpen
4940 : else
4941 0 : x0 = max(0._r8,min(dpen,-0.5_r8*wtwb/s00))
4942 : endif
4943 : else
4944 0 : if( s00 .ge. 0._r8 ) then
4945 0 : x0 = dpen
4946 : else
4947 : x0 = 0._r8
4948 : endif
4949 0 : do iteration = 1, 5
4950 : f = exp(-2._r8*D*x0)*(wtwb-(bogbot-SB/(2._r8*D))/(D*rho0j)) + &
4951 0 : (SB*x0+bogbot-SB/(2._r8*D))/(D*rho0j)
4952 : fs = -2._r8*D*exp(-2._r8*D*x0)*(wtwb-(bogbot-SB/(2._r8*D))/(D*rho0j)) + &
4953 0 : (SB)/(D*rho0j)
4954 0 : if( fs .ge. 0._r8 ) then
4955 0 : fs = max(fs, 1.e-10_r8)
4956 : else
4957 0 : fs = min(fs,-1.e-10_r8)
4958 : endif
4959 0 : x1 = x0 - f/fs
4960 0 : x0 = x1
4961 : end do
4962 :
4963 : endif
4964 :
4965 0 : compute_ppen = -max(0._r8,min(dpen,x0))
4966 :
4967 0 : end function compute_ppen
4968 :
4969 0 : subroutine fluxbelowinv(cbmf,ps0,mkx,kinv,dt,xsrc,xmean,xtopin,xbotin,xflx)
4970 : ! ------------------------------------------------------------------------- !
4971 : ! Subroutine to calculate turbulent fluxes at and below 'kinv-1' interfaces.!
4972 : ! Check in the main program such that input 'cbmf' should not be zero. !
4973 : ! If the reconstructed inversion height does not go down below the 'kinv-1' !
4974 : ! interface, then turbulent flux at 'kinv-1' interface is simply a product !
4975 : ! of 'cmbf' and 'qtsrc-xbot' where 'xbot' is the value at the top interface !
4976 : ! of 'kinv-1' layer. This flux is linearly interpolated down to the surface !
4977 : ! assuming turbulent fluxes at surface are zero. If reconstructed inversion !
4978 : ! height goes down below the 'kinv-1' interface, subsidence warming &drying !
4979 : ! measured by 'xtop-xbot', where 'xtop' is the value at the base interface !
4980 : ! of 'kinv+1' layer, is added ONLY to the 'kinv-1' layer, using appropriate !
4981 : ! mass weighting ( rpinv and rcbmf, or rr = rpinv / rcbmf ) between current !
4982 : ! and next provisional time step. Also impose a limiter to enforce outliers !
4983 : ! of thermodynamic variables in 'kinv' layer to come back to normal values !
4984 : ! at the next step. !
4985 : ! ------------------------------------------------------------------------- !
4986 : integer, intent(in) :: mkx, kinv
4987 : real(r8), intent(in) :: cbmf, dt, xsrc, xmean, xtopin, xbotin
4988 : real(r8), intent(in), dimension(0:mkx) :: ps0
4989 : real(r8), intent(out), dimension(0:mkx) :: xflx
4990 : integer k
4991 : real(r8) rcbmf, rpeff, dp, rr, pinv_eff, xtop, xbot, pinv, xtop_ori, xbot_ori
4992 :
4993 0 : xflx(0:mkx) = 0._r8
4994 0 : dp = ps0(kinv-1) - ps0(kinv)
4995 0 : xbot = xbotin
4996 0 : xtop = xtopin
4997 :
4998 : ! -------------------------------------- !
4999 : ! Compute reconstructed inversion height !
5000 : ! -------------------------------------- !
5001 0 : xtop_ori = xtop
5002 0 : xbot_ori = xbot
5003 0 : rcbmf = ( cbmf * g * dt ) / dp ! Can be larger than 1 : 'OK'
5004 :
5005 0 : if( xbot .ge. xtop ) then
5006 0 : rpeff = ( xmean - xtop ) / max( 1.e-20_r8, xbot - xtop )
5007 : else
5008 0 : rpeff = ( xmean - xtop ) / min( -1.e-20_r8, xbot - xtop )
5009 : endif
5010 :
5011 0 : rpeff = min( max(0._r8,rpeff), 1._r8 ) ! As of this, 0<= rpeff <= 1
5012 0 : if( rpeff .eq. 0._r8 .or. rpeff .eq. 1._r8 ) then
5013 0 : xbot = xmean
5014 0 : xtop = xmean
5015 : endif
5016 : ! Below two commented-out lines are the old code replacing the above 'if' block.
5017 : ! if(rpeff.eq.1) xbot = xmean
5018 : ! if(rpeff.eq.0) xtop = xmean
5019 0 : rr = rpeff / rcbmf
5020 0 : pinv = ps0(kinv-1) - rpeff * dp ! "pinv" before detraining mass
5021 0 : pinv_eff = ps0(kinv-1) + ( rcbmf - rpeff ) * dp ! Effective "pinv" after detraining mass
5022 : ! ----------------------------------------------------------------------- !
5023 : ! Compute turbulent fluxes. !
5024 : ! Below two cases exactly converges at 'kinv-1' interface when rr = 1._r8 !
5025 : ! ----------------------------------------------------------------------- !
5026 0 : do k = 0, kinv - 1
5027 0 : xflx(k) = cbmf * ( xsrc - xbot ) * ( ps0(0) - ps0(k) ) / ( ps0(0) - pinv )
5028 : end do
5029 0 : if( rr .le. 1._r8 ) then
5030 0 : xflx(kinv-1) = xflx(kinv-1) - ( 1._r8 - rr ) * cbmf * ( xtop_ori - xbot_ori )
5031 : endif
5032 :
5033 0 : return
5034 : end subroutine fluxbelowinv
5035 :
5036 0 : subroutine positive_moisture_single( xlv, xls, mkx, dt, qvmin, qlmin, qimin, dp, qv, ql, qi, s, qvten, qlten, qiten, sten )
5037 : ! ------------------------------------------------------------------------------- !
5038 : ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, !
5039 : ! force them to be larger than minimum value by (1) condensating water vapor !
5040 : ! into liquid or ice, and (2) by transporting water vapor from the very lower !
5041 : ! layer. '2._r8' is multiplied to the minimum values for safety. !
5042 : ! Update final state variables and tendencies associated with this correction. !
5043 : ! If any condensation happens, update (s,t) too. !
5044 : ! Note that (qv,ql,qi,s) are final state variables after applying corresponding !
5045 : ! input tendencies and corrective tendencies !
5046 : ! ------------------------------------------------------------------------------- !
5047 : implicit none
5048 : integer, intent(in) :: mkx
5049 : real(r8), intent(in) :: xlv, xls
5050 : real(r8), intent(in) :: dt, qvmin, qlmin, qimin
5051 : real(r8), intent(in) :: dp(mkx)
5052 : real(r8), intent(inout) :: qv(mkx), ql(mkx), qi(mkx), s(mkx)
5053 : real(r8), intent(inout) :: qvten(mkx), qlten(mkx), qiten(mkx), sten(mkx)
5054 : integer k
5055 : real(r8) dql, dqi, dqv, sum, aa, dum
5056 :
5057 0 : do k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface
5058 0 : dql = max(0._r8,1._r8*qlmin-ql(k))
5059 0 : dqi = max(0._r8,1._r8*qimin-qi(k))
5060 0 : qlten(k) = qlten(k) + dql/dt
5061 0 : qiten(k) = qiten(k) + dqi/dt
5062 0 : qvten(k) = qvten(k) - (dql+dqi)/dt
5063 0 : sten(k) = sten(k) + xlv * (dql/dt) + xls * (dqi/dt)
5064 0 : ql(k) = ql(k) + dql
5065 0 : qi(k) = qi(k) + dqi
5066 0 : qv(k) = qv(k) - dql - dqi
5067 0 : s(k) = s(k) + xlv * dql + xls * dqi
5068 0 : dqv = max(0._r8,1._r8*qvmin-qv(k))
5069 0 : qvten(k) = qvten(k) + dqv/dt
5070 0 : qv(k) = qv(k) + dqv
5071 0 : if( k .ne. 1 ) then
5072 0 : qv(k-1) = qv(k-1) - dqv*dp(k)/dp(k-1)
5073 0 : qvten(k-1) = qvten(k-1) - dqv*dp(k)/dp(k-1)/dt
5074 : endif
5075 0 : qv(k) = max(qv(k),qvmin)
5076 0 : ql(k) = max(ql(k),qlmin)
5077 0 : qi(k) = max(qi(k),qimin)
5078 : end do
5079 : ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally
5080 : ! extracted from all the layers that has 'qv > 2*qvmin'. This fully
5081 : ! preserves column moisture.
5082 0 : if( dqv .gt. 1.e-20_r8 ) then
5083 : sum = 0._r8
5084 0 : do k = 1, mkx
5085 0 : if( qv(k) .gt. 2._r8*qvmin ) sum = sum + qv(k)*dp(k)
5086 : enddo
5087 0 : aa = dqv*dp(1)/max(1.e-20_r8,sum)
5088 0 : if( aa .lt. 0.5_r8 ) then
5089 0 : do k = 1, mkx
5090 0 : if( qv(k) .gt. 2._r8*qvmin ) then
5091 0 : dum = aa*qv(k)
5092 0 : qv(k) = qv(k) - dum
5093 0 : qvten(k) = qvten(k) - dum/dt
5094 : endif
5095 : enddo
5096 : else
5097 0 : write(iulog,*) 'Full positive_moisture is impossible in uwshcu'
5098 : endif
5099 : endif
5100 :
5101 0 : return
5102 : end subroutine positive_moisture_single
5103 :
5104 : ! ------------------------ !
5105 : ! !
5106 : ! End of subroutine blocks !
5107 : ! !
5108 : ! ------------------------ !
5109 :
5110 : end module uwshcu
5111 :
|
