CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
mfscuq.f
1
4 module mfscuq_mod
5 contains
6
12 subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
13 & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,
14 & thlx,thvx,thlvx,gdx,thetae,
15 & krad,mrad,radmin,buo,wush,tkemean,vez0fun,xmfd,
16 & tcdo,qcdo,ucdo,vcdo,xlamdeq,a1)
17!
18 use machine , only : kind_phys
19 use funcphys , only : fpvs
20 use physcons, grav => con_g, cp => con_cp
21 &, rv => con_rv, hvap => con_hvap
22 &, fv => con_fvirt
23 &, eps => con_eps, epsm1 => con_epsm1
24!
25 implicit none
26!
27 integer im, ix, km, kmscu, ntcw, ntrac1
28! &, me
29 integer krad(im), mrad(im)
30!
31 logical cnvflg(im)
32 real(kind=kind_phys) delt
33 real(kind=kind_phys) q1(ix,km,ntrac1),t1(ix,km),
34 & u1(ix,km), v1(ix,km),
35 & plyr(im,km), pix(im,km),
36 & thlx(im,km),
37 & thvx(im,km), thlvx(im,km),
38 & gdx(im),
39 & zl(im,km), zm(im,km),
40 & thetae(im,km), radmin(im),
41 & buo(im,km), wush(im,km),
42 & tkemean(im),vez0fun(im),xmfd(im,km),
43 & tcdo(im,km),qcdo(im,km,ntrac1),
44 & ucdo(im,km),vcdo(im,km),
45 & xlamdeq(im,km-1)
46!
47! local variables and arrays
48!
49!
50 integer i,j,indx, k, n, kk, ndc
51 integer krad1(im)
52!
53 real(kind=kind_phys) dt2, dz, ce0,
54 & cm, cq,
55 & tkcrt, cmxfac,
56 & gocp, factor, g, tau,
57 & b1, f1, bb1, bb2,
58 & a1, a2,
59 & cteit, pgcon,
60 & qmin, qlmin,
61 & xmmx, tem, tem1, tem2,
62 & ptem, ptem1, ptem2
63!
64 real(kind=kind_phys) elocp, el2orc, qs, es,
65 & tld, gamma, qld, thdn,
66 & thvd, dq
67!
68 real(kind=kind_phys) wd2(im,km), thld(im,km),
69 & qtx(im,km), qtd(im,km),
70 & thlvd(im), hrad(im), xlamde(im,km-1),
71 & xlamdem(im,km-1), ra1(im)
72 real(kind=kind_phys) delz(im), xlamax(im), ce0t(im)
73!
74 real(kind=kind_phys) xlamavg(im), sigma(im),
75 & scaldfunc(im), sumx(im)
76!
77 logical totflg, flg(im)
78!
79 real(kind=kind_phys) actei, cldtime
80!
81c physical parameters
82 parameter(g=grav)
83 parameter(gocp=g/cp)
84 parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp))
85 parameter(ce0=0.4,cm=1.0,cq=1.0,pgcon=0.55)
86 parameter(tkcrt=2.,cmxfac=5.)
87 parameter(qmin=1.e-8,qlmin=1.e-12)
88 parameter(b1=0.45,f1=0.15)
89 parameter(a2=0.5)
90 parameter(cldtime=500.)
91 parameter(actei = 0.7)
92! parameter(actei = 0.23)
93!
94!************************************************************************
95!!
96 totflg = .true.
97 do i=1,im
98 totflg = totflg .and. (.not. cnvflg(i))
99 enddo
100 if(totflg) return
101!!
102 dt2 = delt
103!
104 do k = 1, km
105 do i=1,im
106 if(cnvflg(i)) then
107 buo(i,k) = 0.
108 wd2(i,k) = 0.
109 qtx(i,k) = q1(i,k,1) + q1(i,k,ntcw)
110 endif
111 enddo
112 enddo
113!
114 do i = 1, im
115 if(cnvflg(i)) then
116 hrad(i) = zm(i,krad(i))
117 krad1(i) = krad(i)-1
118 endif
119 enddo
120!
121 do i = 1, im
122 if(cnvflg(i)) then
123 k = krad(i)
124 tem = zm(i,k+1)-zm(i,k)
125 tem1 = cldtime*radmin(i)/tem
126 tem1 = max(tem1, -3.0)
127 thld(i,k)= thlx(i,k) + tem1
128 qtd(i,k) = qtx(i,k)
129 thlvd(i) = thlvx(i,k) + tem1
130 buo(i,k) = - g * tem1 / thvx(i,k)
131 endif
132 enddo
133!
135!
136 do i=1,im
137 if(cnvflg(i)) then
138 ra1(i) = a1
139 endif
140 enddo
141!
144!
145 do i = 1, im
146 if(cnvflg(i)) then
147 k = krad(i)
148 tem = thetae(i,k) - thetae(i,k+1)
149 tem1 = qtx(i,k) - qtx(i,k+1)
150 if (tem > 0. .and. tem1 > 0.) then
151 cteit= cp*tem/(hvap*tem1)
152 if(cteit > actei) then
153 ra1(i) = a2
154 endif
155 endif
156 endif
157 enddo
158!
160!
161 do i = 1, im
162 flg(i) = cnvflg(i)
163 mrad(i) = krad(i)
164 enddo
165 do k = kmscu,1,-1
166 do i = 1, im
167 if(flg(i) .and. k < krad(i)) then
168 if(thlvd(i) <= thlvx(i,k)) then
169 mrad(i) = k
170 else
171 flg(i)=.false.
172 endif
173 endif
174 enddo
175 enddo
176 do i=1,im
177 if (cnvflg(i)) then
178 kk = krad(i)-mrad(i)
179 if(kk < 1) cnvflg(i)=.false.
180 endif
181 enddo
182!!
183 totflg = .true.
184 do i=1,im
185 totflg = totflg .and. (.not. cnvflg(i))
186 enddo
187 if(totflg) return
188!!
189!
191!
192! if tkemean>tkcrt, ce0t=sqrt(tkemean/tkcrt)*ce0
193!
194 do i=1,im
195 if(cnvflg(i)) then
196 ce0t(i) = ce0 * vez0fun(i)
197 if(tkemean(i) > tkcrt) then
198 tem = sqrt(tkemean(i)/tkcrt)
199 tem1 = min(tem, cmxfac)
200 tem2 = tem1 * ce0
201 ce0t(i) = max(ce0t(i), tem2)
202 endif
203 endif
204 enddo
205!
206 do i=1,im
207 if(cnvflg(i)) then
208 k = mrad(i) + (krad(i)-mrad(i)) / 2
209 k = max(k, mrad(i))
210 delz(i) = zl(i,k+1) - zl(i,k)
211 xlamax(i) = ce0t(i) / delz(i)
212 endif
213 enddo
214!
215 do k = 1, kmscu
216 do i=1,im
217 if(cnvflg(i)) then
218 if(k >= mrad(i) .and. k < krad(i)) then
219 if(mrad(i) == 1) then
220 ptem = 1./(zm(i,k)+delz(i))
221 else
222 ptem = 1./(zm(i,k)-zm(i,mrad(i)-1)+delz(i))
223 endif
224 tem = max((hrad(i)-zm(i,k)+delz(i)) ,delz(i))
225 ptem1 = 1./tem
226 xlamde(i,k) = ce0t(i) * (ptem+ptem1)
227 else
228 xlamde(i,k) = xlamax(i)
229 endif
230!
231 xlamdeq(i,k) = cq * xlamde(i,k)
232 xlamdem(i,k) = cm * xlamde(i,k)
233 endif
234 enddo
235 enddo
236!
238!
239 do k = kmscu,1,-1
240 do i=1,im
241 if(cnvflg(i) .and. k < krad(i)) then
242 dz = zl(i,k+1) - zl(i,k)
243 tem = 0.5 * xlamde(i,k) * dz
244 factor = 1. + tem
245!
246 thld(i,k) = ((1.-tem)*thld(i,k+1)+tem*
247 & (thlx(i,k)+thlx(i,k+1)))/factor
248!
249 tem = 0.5 * xlamdeq(i,k) * dz
250 factor = 1. + tem
251 qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem*
252 & (qtx(i,k)+qtx(i,k+1)))/factor
253!
254 tld = thld(i,k) / pix(i,k)
255 es = 0.01 * fpvs(tld) ! fpvs in pa
256 qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es))
257 dq = qtd(i,k) - qs
258!
259 if (dq > 0.) then
260 gamma = el2orc * qs / (tld**2)
261 qld = dq / (1. + gamma)
262 qtd(i,k) = qs + qld
263 tem1 = 1. + fv * qs - qld
264 thdn = thld(i,k) + pix(i,k) * elocp * qld
265 thvd = thdn * tem1
266 else
267 tem1 = 1. + fv * qtd(i,k)
268 thvd = thld(i,k) * tem1
269 endif
270 buo(i,k) = g * (1. - thvd / thvx(i,k))
271!
272 endif
273 enddo
274 enddo
275!
277!
278! tem = 1.-2.*f1
279! bb1 = 2. * b1 / tem
280! bb2 = 2. / tem
281! from Soares et al. (2004,QJRMS)
282! bb1 = 2.
283! bb2 = 4.
284!
285! from Bretherton et al. (2004, MWR)
286! bb1 = 4.
287! bb2 = 2.
288!
289! from our tuning
290 bb1 = 2.0
291 bb2 = 4.0
292!
293 do i = 1, im
294 if(cnvflg(i)) then
295 k = krad1(i)
296 dz = zm(i,k+1) - zm(i,k)
297! tem = 0.25*bb1*(xlamde(i,k)+xlamde(i,k+1))*dz
298 tem = 0.5*bb1*xlamde(i,k)*dz
299 tem1 = bb2 * buo(i,k+1) * dz
300 ptem1 = 1. + tem
301 wd2(i,k) = tem1 / ptem1
302 endif
303 enddo
304 do k = kmscu,1,-1
305 do i = 1, im
306 if(cnvflg(i) .and. k < krad1(i)) then
307 dz = zm(i,k+1) - zm(i,k)
308 tem = 0.25*bb1*(xlamde(i,k)+xlamde(i,k+1))*dz
309 tem1 = max(wd2(i,k+1), 0.)
310 tem1 = bb2*buo(i,k+1) - wush(i,k+1)*sqrt(tem1)
311 tem2 = tem1 * dz
312 ptem = (1. - tem) * wd2(i,k+1)
313 ptem1 = 1. + tem
314 wd2(i,k) = (ptem + tem2) / ptem1
315 endif
316 enddo
317 enddo
318c
319 do i = 1, im
320 flg(i) = cnvflg(i)
321 if(flg(i)) mrad(i) = krad(i)
322 enddo
323 do k = kmscu,1,-1
324 do i = 1, im
325 if(flg(i) .and. k < krad(i)) then
326 if(wd2(i,k) > 0.) then
327 mrad(i) = k
328 else
329 flg(i)=.false.
330 endif
331 endif
332 enddo
333 enddo
334!
335 do i=1,im
336 if (cnvflg(i)) then
337 kk = krad(i)-mrad(i)
338 if(kk < 1) cnvflg(i)=.false.
339 endif
340 enddo
341!!
342 totflg = .true.
343 do i=1,im
344 totflg = totflg .and. (.not. cnvflg(i))
345 enddo
346 if(totflg) return
347!!
348!
350!
351 do i=1,im
352 if(cnvflg(i)) then
353 k = mrad(i) + (krad(i)-mrad(i)) / 2
354 k = max(k, mrad(i))
355 delz(i) = zl(i,k+1) - zl(i,k)
356 xlamax(i) = ce0t(i) / delz(i)
357 endif
358 enddo
359!
360 do k = 1, kmscu
361 do i=1,im
362 if(cnvflg(i)) then
363 if(k >= mrad(i) .and. k < krad(i)) then
364 if(mrad(i) == 1) then
365 ptem = 1./(zm(i,k)+delz(i))
366 else
367 ptem = 1./(zm(i,k)-zm(i,mrad(i)-1)+delz(i))
368 endif
369 tem = max((hrad(i)-zm(i,k)+delz(i)) ,delz(i))
370 ptem1 = 1./tem
371 xlamde(i,k) = ce0t(i) * (ptem+ptem1)
372 else
373 xlamde(i,k) = xlamax(i)
374 endif
375!
376 xlamdeq(i,k) = cq * xlamde(i,k)
377 xlamdem(i,k) = cm * xlamde(i,k)
378 endif
379 enddo
380 enddo
381!
383!
384 do i = 1, im
385 xlamavg(i) = 0.
386 sumx(i) = 0.
387 enddo
388 do k = kmscu, 1, -1
389 do i = 1, im
390 if(cnvflg(i) .and.
391 & (k >= mrad(i) .and. k < krad(i))) then
392 dz = zl(i,k+1) - zl(i,k)
393 xlamavg(i) = xlamavg(i) + xlamde(i,k) * dz
394 sumx(i) = sumx(i) + dz
395 endif
396 enddo
397 enddo
398 do i = 1, im
399 if(cnvflg(i)) then
400 xlamavg(i) = xlamavg(i) / sumx(i)
401 endif
402 enddo
403!
405!
406 do k = kmscu, 1, -1
407 do i = 1, im
408 if(cnvflg(i) .and.
409 & (k >= mrad(i) .and. k < krad(i))) then
410 xmfd(i,k) = ra1(i) * sqrt(wd2(i,k))
411 endif
412 enddo
413 enddo
414!
417!
418 do i = 1, im
419 if(cnvflg(i)) then
420 tem = 0.2 / xlamavg(i)
421 tem1 = 3.14 * tem * tem
422 sigma(i) = tem1 / (gdx(i) * gdx(i))
423 sigma(i) = max(sigma(i), 0.001)
424 sigma(i) = min(sigma(i), 0.999)
425 endif
426 enddo
427!
430!
431 do i = 1, im
432 if(cnvflg(i)) then
433 if (sigma(i) > ra1(i)) then
434 scaldfunc(i) = (1.-sigma(i)) * (1.-sigma(i))
435 scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.)
436 else
437 scaldfunc(i) = 1.0
438 endif
439 endif
440 enddo
441!
443!
444 do k = kmscu, 1, -1
445 do i = 1, im
446 if(cnvflg(i) .and.
447 & (k >= mrad(i) .and. k < krad(i))) then
448 xmfd(i,k) = scaldfunc(i) * xmfd(i,k)
449 dz = zl(i,k+1) - zl(i,k)
450 xmmx = dz / dt2
451 xmfd(i,k) = min(xmfd(i,k),xmmx)
452 endif
453 enddo
454 enddo
455!
456!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
458!
459 do i = 1, im
460 if(cnvflg(i)) then
461 k = krad(i)
462 thld(i,k)= thlx(i,k)
463 endif
464 enddo
465!
466! do i = 1, im
467! if(cnvflg(i)) then
468! k = krad(i)
469! ptem1 = max(qcdo(i,k,ntcw), 0.)
470! tld = thld(i,k) / pix(i,k)
471! tcdo(i,k) = tld + elocp * ptem1
472! qcdo(i,k,1) = qcdo(i,k,1)+0.2*qcdo(i,k,1)
473! qcdo(i,k,ntcw) = qcdo(i,k,ntcw)+0.2*qcdo(i,k,ntcw)
474! endif
475! enddo
476!
477 do k = kmscu,1,-1
478 do i=1,im
479 if(cnvflg(i) .and.
480 & (k >= mrad(i) .and. k < krad(i))) then
481 dz = zl(i,k+1) - zl(i,k)
482 tem = 0.5 * xlamde(i,k) * dz
483 factor = 1. + tem
484!
485 thld(i,k) = ((1.-tem)*thld(i,k+1)+tem*
486 & (thlx(i,k)+thlx(i,k+1)))/factor
487!
488 tem = 0.5 * xlamdeq(i,k) * dz
489 factor = 1. + tem
490 qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem*
491 & (qtx(i,k)+qtx(i,k+1)))/factor
492!
493 tld = thld(i,k) / pix(i,k)
494 es = 0.01 * fpvs(tld) ! fpvs in pa
495 qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es))
496 dq = qtd(i,k) - qs
497!
498 if (dq > 0.) then
499 gamma = el2orc * qs / (tld**2)
500 qld = dq / (1. + gamma)
501 qtd(i,k) = qs + qld
502 qcdo(i,k,1) = qs
503 qcdo(i,k,ntcw) = qld
504 tcdo(i,k) = tld + elocp * qld
505 else
506 qcdo(i,k,1) = qtd(i,k)
507 qcdo(i,k,ntcw) = 0.
508 tcdo(i,k) = tld
509 endif
510!
511 endif
512 enddo
513 enddo
514!
515 do k = kmscu, 1, -1
516 do i = 1, im
517 if (cnvflg(i) .and. k < krad(i)) then
518 if(k >= mrad(i)) then
519 dz = zl(i,k+1) - zl(i,k)
520 tem = 0.5 * xlamdem(i,k) * dz
521 factor = 1. + tem
522 ptem = tem - pgcon
523 ptem1= tem + pgcon
524!
525 ucdo(i,k) = ((1.-tem)*ucdo(i,k+1)+ptem*u1(i,k+1)
526 & +ptem1*u1(i,k))/factor
527 vcdo(i,k) = ((1.-tem)*vcdo(i,k+1)+ptem*v1(i,k+1)
528 & +ptem1*v1(i,k))/factor
529 endif
530 endif
531 enddo
532 enddo
533!
534 if(ntcw > 2) then
535!
536 do n = 2, ntcw-1
537 do k = kmscu, 1, -1
538 do i = 1, im
539 if (cnvflg(i) .and. k < krad(i)) then
540 if(k >= mrad(i)) then
541 dz = zl(i,k+1) - zl(i,k)
542 tem = 0.5 * xlamdeq(i,k) * dz
543 factor = 1. + tem
544!
545 qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem*
546 & (q1(i,k,n)+q1(i,k+1,n)))/factor
547 endif
548 endif
549 enddo
550 enddo
551 enddo
552!
553 endif
554!
555 ndc = ntrac1 - ntcw
556!
557 if(ndc > 0) then
558!
559 do n = ntcw+1, ntrac1
560 do k = kmscu, 1, -1
561 do i = 1, im
562 if (cnvflg(i) .and. k < krad(i)) then
563 if(k >= mrad(i)) then
564 dz = zl(i,k+1) - zl(i,k)
565 tem = 0.5 * xlamdeq(i,k) * dz
566 factor = 1. + tem
567!
568 qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem*
569 & (q1(i,k,n)+q1(i,k+1,n)))/factor
570 endif
571 endif
572 enddo
573 enddo
574 enddo
575!
576 endif
577!
578 return
579 end
580
581 end module mfscuq_mod
subroutine mfscuq(im, ix, km, kmscu, ntcw, ntrac1, delt,
This subroutine computes mass flux and downdraft parcel properties for stratocumulus-top-driven turbu...
Definition mfscuq.f:13