Line data Source code
1 : module zm_conv_momtran
2 :
3 : use ccpp_kinds, only: kind_phys
4 :
5 : implicit none
6 :
7 : save
8 : private ! Make default type private to the module
9 : public zm_conv_momtran_run ! convective momentum transport
10 : integer, parameter, private :: num_winds=2 ! Number of wind directions (for historical purposes)
11 :
12 :
13 : contains
14 :
15 : !===============================================================================
16 : !> \section arg_table_zm_conv_momtran_run Argument Table
17 : !! \htmlinclude zm_conv_momtran_run.html
18 : !!
19 80640 : subroutine zm_conv_momtran_run(ncol, pver, pverp, &
20 80640 : domomtran,windu, windv, mu, md, &
21 : momcu, momcd, &
22 80640 : du, eu, ed, dp, dsubcld , &
23 80640 : jt, mx, ideep , il1g, il2g, &
24 80640 : nstep, windu_tend, windv_tend, pguallu, pguallv, pgdallu, pgdallv, &
25 241920 : icwuu, icwuv, icwdu, icwdv, dt, seten, scheme_name, errmsg, errflg)
26 : !-----------------------------------------------------------------------
27 : !
28 : ! Purpose:
29 : ! Convective transport of momentum
30 : !
31 : ! Mixing ratios may be with respect to either dry or moist air
32 : !
33 : ! Method:
34 : ! Based on the convtran subroutine by P. Rasch
35 : ! <Also include any applicable external references.>
36 : !
37 : ! Author: J. Richter and P. Rasch
38 : !
39 : !-----------------------------------------------------------------------
40 :
41 : implicit none
42 : !-----------------------------------------------------------------------
43 : !
44 : ! Input arguments
45 : !
46 : integer, intent(in) :: ncol ! number of atmospheric columns
47 : integer, intent(in) :: pver, pverp
48 : logical, intent(in) :: domomtran ! flag for doing convective transport
49 : real(kind_phys), intent(in) :: windu(:,:) ! U Wind array (ncol,pver)
50 : real(kind_phys), intent(in) :: windv(:,:) ! V Wind array (ncol,pver)
51 : real(kind_phys), intent(in) :: mu(:,:) ! Mass flux up (ncol,pver)
52 : real(kind_phys), intent(in) :: md(:,:) ! Mass flux down (ncol,pver)
53 : real(kind_phys), intent(in) :: momcu
54 : real(kind_phys), intent(in) :: momcd
55 : real(kind_phys), intent(in) :: du(:,:) ! Mass detraining from updraft (ncol,pver)
56 : real(kind_phys), intent(in) :: eu(:,:) ! Mass entraining from updraft (ncol,pver)
57 : real(kind_phys), intent(in) :: ed(:,:) ! Mass entraining from downdraft (ncol,pver)
58 : real(kind_phys), intent(in) :: dp(:,:) ! Delta pressure between interfaces (ncol,pver)
59 : real(kind_phys), intent(in) :: dsubcld(:) ! Delta pressure from cloud base to sfc (ncol)
60 : real(kind_phys), intent(in) :: dt ! time step in seconds
61 :
62 : integer, intent(in) :: jt(:) ! Index of cloud top for each column (ncol)
63 : integer, intent(in) :: mx(:) ! Index of cloud top for each column (ncol)
64 : integer, intent(in) :: ideep(:) ! Gathering array (ncol)
65 : integer, intent(in) :: il1g ! Gathered min lon indices over which to operate
66 : integer, intent(in) :: il2g ! Gathered max lon indices over which to operate
67 : integer, intent(in) :: nstep ! Time step index
68 :
69 :
70 :
71 : ! input/output
72 :
73 : real(kind_phys), intent(out) :: windu_tend(:,:) ! U wind tendency
74 : real(kind_phys), intent(out) :: windv_tend(:,:) ! V wind tendency
75 :
76 : character(len=512), intent(out) :: errmsg
77 : integer, intent(out) :: errflg
78 : character(len=40), intent(out) :: scheme_name
79 :
80 : !--------------------------Local Variables------------------------------
81 :
82 : integer i ! Work index
83 : integer k ! Work index
84 : integer kbm ! Highest altitude index of cloud base
85 : integer kk ! Work index
86 : integer kkp1 ! Work index
87 : integer kkm1 ! Work index
88 : integer km1 ! Work index
89 : integer kp1 ! Work index
90 : integer ktm ! Highest altitude index of cloud top
91 : integer m ! Work index
92 : integer ii ! Work index
93 :
94 : real(kind_phys) cabv ! Mix ratio of constituent above
95 : real(kind_phys) cbel ! Mix ratio of constituent below
96 : real(kind_phys) cdifr ! Normalized diff between cabv and cbel
97 161280 : real(kind_phys) chat(ncol,pver) ! Mix ratio in env at interfaces
98 161280 : real(kind_phys) cond(ncol,pver) ! Mix ratio in downdraft at interfaces
99 161280 : real(kind_phys) const(ncol,pver) ! Gathered wind array
100 161280 : real(kind_phys) conu(ncol,pver) ! Mix ratio in updraft at interfaces
101 161280 : real(kind_phys) dcondt(ncol,pver) ! Gathered tend array
102 : real(kind_phys) mbsth ! Threshold for mass fluxes
103 : real(kind_phys) mupdudp ! A work variable
104 : real(kind_phys) minc ! A work variable
105 : real(kind_phys) maxc ! A work variable
106 : real(kind_phys) fluxin ! A work variable
107 : real(kind_phys) fluxout ! A work variable
108 : real(kind_phys) netflux ! A work variable
109 :
110 :
111 : real(kind_phys) sum ! sum
112 : real(kind_phys) sum2 ! sum2
113 :
114 161280 : real(kind_phys) mududp(ncol,pver) ! working variable
115 161280 : real(kind_phys) mddudp(ncol,pver) ! working variable
116 :
117 161280 : real(kind_phys) pgu(ncol,pver) ! Pressure gradient term for updraft
118 161280 : real(kind_phys) pgd(ncol,pver) ! Pressure gradient term for downdraft
119 :
120 : real(kind_phys),intent(out) :: pguallu(:,:) ! Apparent force from updraft PG on U winds ! (ncol,pver)
121 : real(kind_phys),intent(out) :: pguallv(:,:) ! Apparent force from updraft PG on V winds ! (ncol,pver)
122 : real(kind_phys),intent(out) :: pgdallu(:,:) ! Apparent force from downdraft PG on U winds! (ncol,pver)
123 : real(kind_phys),intent(out) :: pgdallv(:,:) ! Apparent force from downdraft PG on V winds! (ncol,pver)
124 :
125 : real(kind_phys),intent(out) :: icwuu(:,:) ! In-cloud U winds in updraft ! (ncol,pver)
126 : real(kind_phys),intent(out) :: icwuv(:,:) ! In-cloud V winds in updraft ! (ncol,pver)
127 : real(kind_phys),intent(out) :: icwdu(:,:) ! In-cloud U winds in downdraft ! (ncol,pver)
128 : real(kind_phys),intent(out) :: icwdv(:,:) ! In-cloud V winds in downdraft ! (ncol,pver)
129 :
130 : real(kind_phys),intent(out) :: seten(:,:) ! Dry static energy tendency ! (ncol,pver)
131 161280 : real(kind_phys) gseten(ncol,pver) ! Gathered dry static energy tendency
132 :
133 161280 : real(kind_phys) :: winds(ncol,pver,num_winds) ! combined winds array
134 161280 : real(kind_phys) :: wind_tends(ncol,pver,num_winds) ! combined tendency array
135 161280 : real(kind_phys) :: pguall(ncol,pver,num_winds) ! Combined apparent force from updraft PG on U winds
136 161280 : real(kind_phys) :: pgdall(ncol,pver,num_winds) ! Combined apparent force from downdraft PG on U winds
137 161280 : real(kind_phys) :: icwu(ncol,pver,num_winds) ! Combined In-cloud winds in updraft
138 161280 : real(kind_phys) :: icwd(ncol,pver,num_winds) ! Combined In-cloud winds in downdraft
139 :
140 161280 : real(kind_phys) mflux(ncol,pverp,num_winds) ! Gathered momentum flux
141 :
142 161280 : real(kind_phys) wind0(ncol,pver,num_winds) ! gathered wind before time step
143 80640 : real(kind_phys) windf(ncol,pver,num_winds) ! gathered wind after time step
144 : real(kind_phys) fkeb, fket, ketend_cons, ketend, utop, ubot, vtop, vbot, gset2
145 :
146 :
147 : !-----------------------------------------------------------------------
148 80640 : scheme_name = "zm_conv_momtran_run"
149 80640 : errmsg = ''
150 80640 : errflg = 0
151 :
152 : ! Combine winds in single array
153 87091200 : winds(:,:,1) = windu(:,:)
154 87010560 : winds(:,:,2) = windv(:,:)
155 :
156 : ! Initialize outgoing fields
157 174101760 : pguall(:,:,:) = 0.0_kind_phys
158 174101760 : pgdall(:,:,:) = 0.0_kind_phys
159 : ! Initialize in-cloud winds to environmental wind
160 174101760 : icwu(:ncol,:,:) = winds(:ncol,:,:)
161 174101760 : icwd(:ncol,:,:) = winds(:ncol,:,:)
162 :
163 : ! Initialize momentum flux and final winds
164 176585472 : mflux(:,:,:) = 0.0_kind_phys
165 174101760 : wind0(:,:,:) = 0.0_kind_phys
166 174101760 : windf(:,:,:) = 0.0_kind_phys
167 :
168 : ! Initialize dry static energy
169 :
170 87010560 : seten(:,:) = 0.0_kind_phys
171 87010560 : gseten(:,:) = 0.0_kind_phys
172 :
173 : ! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s)
174 80640 : mbsth = 1.e-15_kind_phys
175 :
176 : ! Find the highest level top and bottom levels of convection
177 80640 : ktm = pver
178 80640 : kbm = pver
179 358405 : do i = il1g, il2g
180 277765 : ktm = min(ktm,jt(i))
181 358405 : kbm = min(kbm,mx(i))
182 : end do
183 :
184 : ! Loop ever each wind component
185 241920 : do m = 1, num_winds !start at m = 1 to transport momentum
186 241920 : if (domomtran) then
187 :
188 : ! Gather up the winds and set tend to zero
189 11450880 : do k = 1,pver
190 50337980 : do i =il1g,il2g
191 38887100 : const(i,k) = winds(ideep(i),k,m)
192 50176700 : wind0(i,k,m) = const(i,k)
193 : end do
194 : end do
195 :
196 :
197 : ! From now on work only with gathered data
198 :
199 : ! Interpolate winds to interfaces
200 :
201 11450880 : do k = 1,pver
202 11289600 : km1 = max(1,k-1)
203 50337980 : do i = il1g, il2g
204 :
205 : ! use arithmetic mean
206 38887100 : chat(i,k) = 0.5_kind_phys* (const(i,k)+const(i,km1))
207 :
208 : ! Provisional up and down draft values
209 38887100 : conu(i,k) = chat(i,k)
210 38887100 : cond(i,k) = chat(i,k)
211 :
212 : ! provisional tends
213 50176700 : dcondt(i,k) = 0._kind_phys
214 :
215 : end do
216 : end do
217 :
218 :
219 : !
220 : ! Pressure Perturbation Term
221 : !
222 :
223 : !Top boundary: assume mu is zero
224 :
225 161280 : k=1
226 878090 : pgu(:il2g,k) = 0.0_kind_phys
227 716810 : pgd(:il2g,k) = 0.0_kind_phys
228 :
229 11128320 : do k=2,pver-1
230 10967040 : km1 = max(1,k-1)
231 10967040 : kp1 = min(pver,k+1)
232 48904360 : do i = il1g,il2g
233 :
234 : !interior points
235 :
236 113328120 : mududp(i,k) = ( mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) &
237 151104160 : + mu(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k))
238 :
239 37776040 : pgu(i,k) = - momcu * 0.5_kind_phys * mududp(i,k)
240 :
241 :
242 37776040 : mddudp(i,k) = ( md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) &
243 37776040 : + md(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k))
244 :
245 48743080 : pgd(i,k) = - momcd * 0.5_kind_phys * mddudp(i,k)
246 :
247 :
248 : end do
249 : end do
250 :
251 : ! bottom boundary
252 161280 : k = pver
253 161280 : km1 = max(1,k-1)
254 716810 : do i=il1g,il2g
255 :
256 555530 : mududp(i,k) = mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1)
257 555530 : pgu(i,k) = - momcu * mududp(i,k)
258 :
259 555530 : mddudp(i,k) = md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1)
260 :
261 716810 : pgd(i,k) = - momcd * mddudp(i,k)
262 :
263 : end do
264 :
265 :
266 : !
267 : ! In-cloud velocity calculations
268 : !
269 :
270 : ! Do levels adjacent to top and bottom
271 716810 : k = 2
272 716810 : km1 = 1
273 716810 : kk = pver
274 716810 : kkm1 = max(1,kk-1)
275 716810 : do i = il1g,il2g
276 555530 : mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk)
277 555530 : if (mupdudp > mbsth) then
278 :
279 524818 : conu(i,kk) = (+eu(i,kk)*const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp
280 : endif
281 716810 : if (md(i,k) < -mbsth) then
282 0 : cond(i,k) = (-ed(i,km1)*const(i,km1)*dp(i,km1))-pgd(i,km1)*dp(i,km1)/md(i,k)
283 : endif
284 :
285 :
286 : end do
287 :
288 :
289 :
290 : ! Updraft from bottom to top
291 11289600 : do kk = pver-1,1,-1
292 11128320 : kkm1 = max(1,kk-1)
293 11128320 : kkp1 = min(pver,kk+1)
294 49621170 : do i = il1g,il2g
295 38331570 : mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk)
296 49459890 : if (mupdudp > mbsth) then
297 :
298 9862884 : conu(i,kk) = ( mu(i,kkp1)*conu(i,kkp1)+eu(i,kk)* &
299 9862884 : const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp
300 : endif
301 : end do
302 :
303 : end do
304 :
305 :
306 : ! Downdraft from top to bottom
307 11128320 : do k = 3,pver
308 10967040 : km1 = max(1,k-1)
309 48904360 : do i = il1g,il2g
310 48743080 : if (md(i,k) < -mbsth) then
311 :
312 8867388 : cond(i,k) = ( md(i,km1)*cond(i,km1)-ed(i,km1)*const(i,km1) &
313 8867388 : *dp(i,km1)-pgd(i,km1)*dp(i,km1) )/md(i,k)
314 :
315 : endif
316 : end do
317 : end do
318 :
319 :
320 : sum = 0._kind_phys
321 : sum2 = 0._kind_phys
322 :
323 :
324 2055522 : do k = ktm,pver
325 1894242 : km1 = max(1,k-1)
326 1894242 : kp1 = min(pver,k+1)
327 8792214 : do i = il1g,il2g
328 6736692 : ii = ideep(i)
329 :
330 : ! version 1 hard to check for roundoff errors
331 6736692 : dcondt(i,k) = &
332 6736692 : +(mu(i,kp1)* (conu(i,kp1)-chat(i,kp1)) &
333 6736692 : -mu(i,k)* (conu(i,k)-chat(i,k)) &
334 6736692 : +md(i,kp1)* (cond(i,kp1)-chat(i,kp1)) &
335 6736692 : -md(i,k)* (cond(i,k)-chat(i,k)) &
336 22104318 : )/dp(i,k)
337 :
338 : end do
339 : end do
340 :
341 : ! dcont for bottom layer
342 : !
343 361162 : do k = kbm,pver
344 923796 : km1 = max(1,k-1)
345 1085076 : do i = il1g,il2g
346 923796 : if (k == mx(i)) then
347 :
348 : ! version 1
349 555530 : dcondt(i,k) = (1._kind_phys/dp(i,k))* &
350 555530 : (-mu(i,k)*(conu(i,k)-chat(i,k)) &
351 555530 : -md(i,k)*(cond(i,k)-chat(i,k)) &
352 1111060 : )
353 : end if
354 : end do
355 : end do
356 :
357 : ! Initialize to zero everywhere, then scatter tendency back to full array
358 174021120 : wind_tends(:,:,m) = 0._kind_phys
359 :
360 11450880 : do k = 1,pver
361 50337980 : do i = il1g,il2g
362 38887100 : ii = ideep(i)
363 38887100 : wind_tends(ii,k,m) = dcondt(i,k)
364 : ! Output apparent force on the mean flow from pressure gradient
365 38887100 : pguall(ii,k,m) = -pgu(i,k)
366 38887100 : pgdall(ii,k,m) = -pgd(i,k)
367 38887100 : icwu(ii,k,m) = conu(i,k)
368 50176700 : icwd(ii,k,m) = cond(i,k)
369 : end do
370 : end do
371 :
372 : ! Calculate momentum flux in units of mb*m/s2
373 :
374 2055522 : do k = ktm,pver
375 8792214 : do i = il1g,il2g
376 6736692 : ii = ideep(i)
377 6736692 : mflux(i,k,m) = &
378 6736692 : -mu(i,k)* (conu(i,k)-chat(i,k)) &
379 15367626 : -md(i,k)* (cond(i,k)-chat(i,k))
380 : end do
381 : end do
382 :
383 :
384 : ! Calculate winds at the end of the time step
385 :
386 2055522 : do k = ktm,pver
387 8792214 : do i = il1g,il2g
388 6736692 : ii = ideep(i)
389 6736692 : km1 = max(1,k-1)
390 6736692 : kp1 = k+1
391 8630934 : windf(i,k,m) = const(i,k) - (mflux(i,kp1,m) - mflux(i,k,m)) * dt /dp(i,k)
392 :
393 : end do
394 : end do
395 :
396 : end if ! for domomtran
397 : end do
398 :
399 : ! Need to add an energy fix to account for the dissipation of kinetic energy
400 : ! Formulation follows from Boville and Bretherton (2003)
401 : ! formulation by PJR
402 :
403 1027761 : do k = ktm,pver
404 947121 : km1 = max(1,k-1)
405 947121 : kp1 = min(pver,k+1)
406 4396107 : do i = il1g,il2g
407 :
408 3368346 : ii = ideep(i)
409 :
410 : ! calculate the KE fluxes at top and bot of layer
411 : ! based on a discrete approximation to b&b eq(35) F_KE = u*F_u + v*F_v at interface
412 3368346 : utop = (wind0(i,k,1)+wind0(i,km1,1))/2._kind_phys
413 3368346 : vtop = (wind0(i,k,2)+wind0(i,km1,2))/2._kind_phys
414 3368346 : ubot = (wind0(i,kp1,1)+wind0(i,k,1))/2._kind_phys
415 3368346 : vbot = (wind0(i,kp1,2)+wind0(i,k,2))/2._kind_phys
416 3368346 : fket = utop*mflux(i,k,1) + vtop*mflux(i,k,2) ! top of layer
417 3368346 : fkeb = ubot*mflux(i,k+1,1) + vbot*mflux(i,k+1,2) ! bot of layer
418 :
419 : ! divergence of these fluxes should give a conservative redistribution of KE
420 3368346 : ketend_cons = (fket-fkeb)/dp(i,k)
421 :
422 : ! tendency in kinetic energy resulting from the momentum transport
423 3368346 : ketend = ((windf(i,k,1)**2 + windf(i,k,2)**2) - (wind0(i,k,1)**2 + wind0(i,k,2)**2))/dt
424 :
425 : ! the difference should be the dissipation
426 3368346 : gset2 = ketend_cons - ketend
427 4315467 : gseten(i,k) = gset2
428 :
429 : end do
430 :
431 : end do
432 :
433 : ! Scatter dry static energy to full array
434 5725440 : do k = 1,pver
435 25168990 : do i = il1g,il2g
436 19443550 : ii = ideep(i)
437 25088350 : seten(ii,k) = gseten(i,k)
438 :
439 : end do
440 : end do
441 :
442 : ! Split out the wind tendencies
443 87091200 : windu_tend(:,:) = wind_tends(:,:,1)
444 87091200 : windv_tend(:,:) = wind_tends(:,:,2)
445 :
446 87091200 : pguallu(:,:) = pguall(:,:,1)
447 87091200 : pguallv(:,:) = pguall(:,:,2)
448 87091200 : pgdallu(:,:) = pgdall(:,:,1)
449 87091200 : pgdallv(:,:) = pgdall(:,:,2)
450 87091200 : icwuu(:ncol,:) = icwu(:,:,1)
451 87091200 : icwuv(:ncol,:) = icwu(:,:,2)
452 87091200 : icwdu(:ncol,:) = icwd(:,:,1)
453 87091200 : icwdv(:ncol,:) = icwd(:,:,2)
454 :
455 80640 : return
456 : end subroutine zm_conv_momtran_run
457 :
458 :
459 : end module zm_conv_momtran
|