CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
mfpblt.f
1
5
9 module mfpblt_mod
10 contains
16 subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, &
17 & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, &
18 & gdx,hpbl,kpbl,vpert,buo,xmf, &
19 & tcko,qcko,ucko,vcko,xlamue)
20!
21 use machine , only : kind_phys
22 use funcphys , only : fpvs
23 use physcons, grav => con_g, cp => con_cp &
24 &, rv => con_rv, hvap => con_hvap &
25 &, fv => con_fvirt &
26 &, eps => con_eps, epsm1 => con_epsm1
27!
28 implicit none
29!
30 integer im, ix, km, kmpbl, ntcw, ntrac1
31! &, me
32 integer kpbl(im)
33 logical cnvflg(im)
34 real(kind=kind_phys) delt
35 real(kind=kind_phys) q1(ix,km,ntrac1), &
36 & t1(ix,km), u1(ix,km), v1(ix,km), &
37 & plyr(im,km),pix(im,km),thlx(im,km), &
38 & thvx(im,km),zl(im,km), zm(im,km), &
39 & gdx(im), &
40 & hpbl(im), vpert(im), &
41 & buo(im,km), xmf(im,km), &
42 & tcko(im,km),qcko(im,km,ntrac1), &
43 & ucko(im,km),vcko(im,km), &
44 & xlamue(im,km-1)
45!
46c local variables and arrays
47!
48 integer i, j, k, n, ndc
49 integer kpblx(im), kpbly(im)
50!
51 real(kind=kind_phys) dt2, dz, ce0, cm,
52 & factor, gocp,
53 & g, b1, f1,
54 & bb1, bb2,
55 & alp, a1, pgcon,
56 & qmin, qlmin, xmmx, rbint,
57 & tem, tem1, tem2,
58 & ptem, ptem1, ptem2
59!
60 real(kind=kind_phys) elocp, el2orc, qs, es,
61 & tlu, gamma, qlu,
62 & thup, thvu, dq
63!
64 real(kind=kind_phys) rbdn(im), rbup(im), hpblx(im),
65 & xlamuem(im,km-1)
66!
67 real(kind=kind_phys) wu2(im,km), thlu(im,km),
68 & qtx(im,km), qtu(im,km)
69!
70 real(kind=kind_phys) xlamavg(im), sigma(im),
71 & scaldfunc(im), sumx(im)
72!
73 logical totflg, flg(im)
74!
75! physical parameters
76 parameter(g=grav)
77 parameter(gocp=g/cp)
78 parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp))
79 parameter(ce0=0.4,cm=1.0)
80 parameter(qmin=1.e-8,qlmin=1.e-12)
81 parameter(alp=1.0,pgcon=0.55)
82 parameter(a1=0.13,b1=0.5,f1=0.15)
83!
84!************************************************************************
85!!
86 totflg = .true.
87 do i=1,im
88 totflg = totflg .and. (.not. cnvflg(i))
89 enddo
90 if(totflg) return
91!
92 dt2 = delt
93!!
94 do k = 1, km
95 do i=1,im
96 if (cnvflg(i)) then
97 buo(i,k) = 0.
98 wu2(i,k) = 0.
99 qtx(i,k) = q1(i,k,1) + q1(i,k,ntcw)
100 endif
101 enddo
102 enddo
103!
105!
106 do i=1,im
107 if(cnvflg(i)) then
108 ptem = alp * vpert(i)
109 ptem = min(ptem, 3.0)
110 thlu(i,1)= thlx(i,1) + ptem
111 qtu(i,1) = qtx(i,1)
112 buo(i,1) = g * ptem / thvx(i,1)
113 endif
114 enddo
115!
117!
118 do k = 1, kmpbl
119 do i=1,im
120 if(cnvflg(i)) then
121 dz = zl(i,k+1) - zl(i,k)
122 if(k < kpbl(i)) then
123 ptem = 1./(zm(i,k)+dz)
124 tem = max((hpbl(i)-zm(i,k)+dz) ,dz)
125 ptem1 = 1./tem
126 xlamue(i,k) = ce0 * (ptem+ptem1)
127 else
128 xlamue(i,k) = ce0 / dz
129 endif
130 xlamuem(i,k) = cm * xlamue(i,k)
131 endif
132 enddo
133 enddo
134!
136!
137 do k = 2, kmpbl
138 do i=1,im
139 if(cnvflg(i)) then
140 dz = zl(i,k) - zl(i,k-1)
141 tem = 0.5 * xlamue(i,k-1) * dz
142 factor = 1. + tem
143!
144 thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem*
145 & (thlx(i,k-1)+thlx(i,k)))/factor
146 qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem*
147 & (qtx(i,k-1)+qtx(i,k)))/factor
148!
149 tlu = thlu(i,k) / pix(i,k)
150 es = 0.01 * fpvs(tlu) ! fpvs in pa
151 qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es))
152 dq = qtu(i,k) - qs
153!
154 if (dq > 0.) then
155 gamma = el2orc * qs / (tlu**2)
156 qlu = dq / (1. + gamma)
157 qtu(i,k) = qs + qlu
158 tem1 = 1. + fv * qs - qlu
159 thup = thlu(i,k) + pix(i,k) * elocp * qlu
160 thvu = thup * tem1
161 else
162 tem1 = 1. + fv * qtu(i,k)
163 thvu = thlu(i,k) * tem1
164 endif
165 buo(i,k) = g * (thvu / thvx(i,k) - 1.)
166!
167 endif
168 enddo
169 enddo
170!
173!
174! tem = 1.-2.*f1
175! bb1 = 2. * b1 / tem
176! bb2 = 2. / tem
177! from Soares et al. (2004,QJRMS)
178! bb1 = 2.
179! bb2 = 4.
180!
181! from Bretherton et al. (2004, MWR)
182! bb1 = 4.
183! bb2 = 2.
184!
185! from our tuning
186 bb1 = 2.0
187 bb2 = 4.0
188!
189 do i = 1, im
190 if(cnvflg(i)) then
191 dz = zm(i,1)
192 tem = 0.5*bb1*xlamue(i,1)*dz
193 tem1 = bb2 * buo(i,1) * dz
194 ptem1 = 1. + tem
195 wu2(i,1) = tem1 / ptem1
196 endif
197 enddo
198 do k = 2, kmpbl
199 do i = 1, im
200 if(cnvflg(i)) then
201 dz = zm(i,k) - zm(i,k-1)
202 tem = 0.25*bb1*(xlamue(i,k)+xlamue(i,k-1))*dz
203 tem1 = bb2 * buo(i,k) * dz
204 ptem = (1. - tem) * wu2(i,k-1)
205 ptem1 = 1. + tem
206 wu2(i,k) = (ptem + tem1) / ptem1
207 endif
208 enddo
209 enddo
210!
212!
213 do i=1,im
214 flg(i) = .true.
215 kpbly(i) = kpbl(i)
216 if(cnvflg(i)) then
217 flg(i) = .false.
218 rbup(i) = wu2(i,1)
219 endif
220 enddo
221 do k = 2, kmpbl
222 do i = 1, im
223 if(.not.flg(i)) then
224 rbdn(i) = rbup(i)
225 rbup(i) = wu2(i,k)
226 kpblx(i)= k
227 flg(i) = rbup(i).le.0.
228 endif
229 enddo
230 enddo
231 do i = 1,im
232 if(cnvflg(i)) then
233 k = kpblx(i)
234 if(rbdn(i) <= 0.) then
235 rbint = 0.
236 elseif(rbup(i) >= 0.) then
237 rbint = 1.
238 else
239 rbint = rbdn(i)/(rbdn(i)-rbup(i))
240 endif
241 hpblx(i) = zm(i,k-1) + rbint*(zm(i,k)-zm(i,k-1))
242 endif
243 enddo
244!
245 do i = 1,im
246 if(cnvflg(i)) then
247 if(kpbl(i) > kpblx(i)) then
248 kpbl(i) = kpblx(i)
249 hpbl(i) = hpblx(i)
250 endif
251 endif
252 enddo
253!
255!
256 do k = 1, kmpbl
257 do i=1,im
258 if(cnvflg(i) .and. kpbly(i) > kpblx(i)) then
259 dz = zl(i,k+1) - zl(i,k)
260 if(k < kpbl(i)) then
261 ptem = 1./(zm(i,k)+dz)
262 tem = max((hpbl(i)-zm(i,k)+dz) ,dz)
263 ptem1 = 1./tem
264 xlamue(i,k) = ce0 * (ptem+ptem1)
265 else
266 xlamue(i,k) = ce0 / dz
267 endif
268 xlamuem(i,k) = cm * xlamue(i,k)
269 endif
270 enddo
271 enddo
272!
274!
275 do i = 1, im
276 xlamavg(i) = 0.
277 sumx(i) = 0.
278 enddo
279 do k = 1, kmpbl
280 do i = 1, im
281 if (cnvflg(i) .and. k < kpbl(i)) then
282 dz = zl(i,k+1) - zl(i,k)
283 xlamavg(i) = xlamavg(i) + xlamue(i,k) * dz
284 sumx(i) = sumx(i) + dz
285 endif
286 enddo
287 enddo
288 do i = 1, im
289 if(cnvflg(i)) then
290 xlamavg(i) = xlamavg(i) / sumx(i)
291 endif
292 enddo
293!
296!
297 do k = 1, kmpbl
298 do i = 1, im
299 if (cnvflg(i) .and. k < kpbl(i)) then
300 if(wu2(i,k) > 0.) then
301 tem = sqrt(wu2(i,k))
302 else
303 tem = 0.
304 endif
305 xmf(i,k) = a1 * tem
306 endif
307 enddo
308 enddo
309!
312!
313 do i = 1, im
314 if(cnvflg(i)) then
315 tem = 0.2 / xlamavg(i)
316 tem1 = 3.14 * tem * tem
317 sigma(i) = tem1 / (gdx(i) * gdx(i))
318 sigma(i) = max(sigma(i), 0.001)
319 sigma(i) = min(sigma(i), 0.999)
320 endif
321 enddo
322!
325!
326 do i = 1, im
327 if(cnvflg(i)) then
328 if (sigma(i) > a1) then
329 scaldfunc(i) = (1.-sigma(i)) * (1.-sigma(i))
330 scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.)
331 else
332 scaldfunc(i) = 1.0
333 endif
334 endif
335 enddo
336!
338!
339 do k = 1, kmpbl
340 do i = 1, im
341 if (cnvflg(i) .and. k < kpbl(i)) then
342 xmf(i,k) = scaldfunc(i) * xmf(i,k)
343 dz = zl(i,k+1) - zl(i,k)
344 xmmx = dz / dt2
345 xmf(i,k) = min(xmf(i,k),xmmx)
346 endif
347 enddo
348 enddo
349!
350!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
352!
353 do i=1,im
354 if(cnvflg(i)) then
355 thlu(i,1)= thlx(i,1)
356 endif
357 enddo
358!
359! do i=1,im
360! if(cnvflg(i)) then
361! ptem1 = max(qcko(i,1,ntcw), 0.)
362! tlu = thlu(i,1) / pix(i,1)
363! tcko(i,1) = tlu + elocp * ptem1
364! endif
365! enddo
366!
367 do k = 2, kmpbl
368 do i=1,im
369 if(cnvflg(i) .and. k <= kpbl(i)) then
370 dz = zl(i,k) - zl(i,k-1)
371 tem = 0.5 * xlamue(i,k-1) * dz
372 factor = 1. + tem
373!
374 thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem*
375 & (thlx(i,k-1)+thlx(i,k)))/factor
376 qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem*
377 & (qtx(i,k-1)+qtx(i,k)))/factor
378!
379 tlu = thlu(i,k) / pix(i,k)
380 es = 0.01 * fpvs(tlu) ! fpvs in pa
381 qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es))
382 dq = qtu(i,k) - qs
383!
384 if (dq > 0.) then
385 gamma = el2orc * qs / (tlu**2)
386 qlu = dq / (1. + gamma)
387 qtu(i,k) = qs + qlu
388 qcko(i,k,1) = qs
389 qcko(i,k,ntcw) = qlu
390 tcko(i,k) = tlu + elocp * qlu
391 else
392 qcko(i,k,1) = qtu(i,k)
393 qcko(i,k,ntcw) = 0.
394 tcko(i,k) = tlu
395 endif
396!
397 endif
398 enddo
399 enddo
400!
401 do k = 2, kmpbl
402 do i = 1, im
403 if (cnvflg(i) .and. k <= kpbl(i)) then
404 dz = zl(i,k) - zl(i,k-1)
405 tem = 0.5 * xlamuem(i,k-1) * dz
406 factor = 1. + tem
407 ptem = tem + pgcon
408 ptem1= tem - pgcon
409 ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*u1(i,k)
410 & +ptem1*u1(i,k-1))/factor
411 vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*v1(i,k)
412 & +ptem1*v1(i,k-1))/factor
413 endif
414 enddo
415 enddo
416!
417 if(ntcw > 2) then
418!
419 do n = 2, ntcw-1
420 do k = 2, kmpbl
421 do i = 1, im
422 if (cnvflg(i) .and. k <= kpbl(i)) then
423 dz = zl(i,k) - zl(i,k-1)
424 tem = 0.5 * xlamue(i,k-1) * dz
425 factor = 1. + tem
426!
427 qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem*
428 & (q1(i,k,n)+q1(i,k-1,n)))/factor
429 endif
430 enddo
431 enddo
432 enddo
433!
434 endif
435!
436 ndc = ntrac1 - ntcw
437!
438 if(ndc > 0) then
439!
440 do n = ntcw+1, ntrac1
441 do k = 2, kmpbl
442 do i = 1, im
443 if (cnvflg(i) .and. k <= kpbl(i)) then
444 dz = zl(i,k) - zl(i,k-1)
445 tem = 0.5 * xlamue(i,k-1) * dz
446 factor = 1. + tem
447!
448 qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem*
449 & (q1(i,k,n)+q1(i,k-1,n)))/factor
450 endif
451 enddo
452 enddo
453 enddo
454!
455 endif
456!
457 return
458 end
459
460 end module mfpblt_mod
subroutine mfpblt(im, ix, km, kmpbl, ntcw, ntrac1, delt, cnvflg, zl, zm, q1, t1, u1, v1, plyr, pix, thlx, thvx, gdx, hpbl, kpbl, vpert, buo, xmf, tcko, qcko, ucko, vcko, xlamue)
This subroutine computes mass flux and updraft parcel properties for thermals driven by surface heati...
Definition mfpblt.f:20
This module contains the subroutine that calculates mass flux and updraft parcel properties for therm...
Definition mfpblt.f:9