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 24192 : subroutine zm_conv_momtran_run(ncol, pver, pverp, &
20 24192 : domomtran,windu, windv, mu, md, &
21 : momcu, momcd, &
22 24192 : du, eu, ed, dp, dsubcld , &
23 24192 : jt, mx, ideep , il1g, il2g, &
24 24192 : nstep, windu_tend, windv_tend, pguallu, pguallv, pgdallu, pgdallv, &
25 72576 : 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 48384 : real(kind_phys) chat(ncol,pver) ! Mix ratio in env at interfaces
98 48384 : real(kind_phys) cond(ncol,pver) ! Mix ratio in downdraft at interfaces
99 48384 : real(kind_phys) const(ncol,pver) ! Gathered wind array
100 48384 : real(kind_phys) conu(ncol,pver) ! Mix ratio in updraft at interfaces
101 48384 : 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 48384 : real(kind_phys) mududp(ncol,pver) ! working variable
115 48384 : real(kind_phys) mddudp(ncol,pver) ! working variable
116 :
117 48384 : real(kind_phys) pgu(ncol,pver) ! Pressure gradient term for updraft
118 48384 : 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 48384 : real(kind_phys) gseten(ncol,pver) ! Gathered dry static energy tendency
132 :
133 48384 : real(kind_phys) :: winds(ncol,pver,num_winds) ! combined winds array
134 48384 : real(kind_phys) :: wind_tends(ncol,pver,num_winds) ! combined tendency array
135 48384 : real(kind_phys) :: pguall(ncol,pver,num_winds) ! Combined apparent force from updraft PG on U winds
136 48384 : real(kind_phys) :: pgdall(ncol,pver,num_winds) ! Combined apparent force from downdraft PG on U winds
137 48384 : real(kind_phys) :: icwu(ncol,pver,num_winds) ! Combined In-cloud winds in updraft
138 48384 : real(kind_phys) :: icwd(ncol,pver,num_winds) ! Combined In-cloud winds in downdraft
139 :
140 48384 : real(kind_phys) mflux(ncol,pverp,num_winds) ! Gathered momentum flux
141 :
142 48384 : real(kind_phys) wind0(ncol,pver,num_winds) ! gathered wind before time step
143 24192 : 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 24192 : scheme_name = "zm_conv_momtran_run"
149 24192 : errmsg = ''
150 24192 : errflg = 0
151 :
152 : ! Combine winds in single array
153 40932864 : winds(:,:,1) = windu(:,:)
154 40908672 : winds(:,:,2) = windv(:,:)
155 :
156 : ! Initialize outgoing fields
157 81841536 : pguall(:,:,:) = 0.0_kind_phys
158 81841536 : pgdall(:,:,:) = 0.0_kind_phys
159 : ! Initialize in-cloud winds to environmental wind
160 81841536 : icwu(:ncol,:,:) = winds(:ncol,:,:)
161 81841536 : icwd(:ncol,:,:) = winds(:ncol,:,:)
162 :
163 : ! Initialize momentum flux and final winds
164 82470528 : mflux(:,:,:) = 0.0_kind_phys
165 81841536 : wind0(:,:,:) = 0.0_kind_phys
166 81841536 : windf(:,:,:) = 0.0_kind_phys
167 :
168 : ! Initialize dry static energy
169 :
170 40908672 : seten(:,:) = 0.0_kind_phys
171 40908672 : gseten(:,:) = 0.0_kind_phys
172 :
173 : ! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s)
174 24192 : mbsth = 1.e-15_kind_phys
175 :
176 : ! Find the highest level top and bottom levels of convection
177 24192 : ktm = pver
178 24192 : kbm = pver
179 109369 : do i = il1g, il2g
180 85177 : ktm = min(ktm,jt(i))
181 109369 : kbm = min(kbm,mx(i))
182 : end do
183 :
184 : ! Loop ever each wind component
185 72576 : do m = 1, num_winds !start at m = 1 to transport momentum
186 72576 : if (domomtran) then
187 :
188 : ! Gather up the winds and set tend to zero
189 6338304 : do k = 1,pver
190 28484324 : do i =il1g,il2g
191 22146020 : const(i,k) = winds(ideep(i),k,m)
192 28435940 : 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 6338304 : do k = 1,pver
202 6289920 : km1 = max(1,k-1)
203 28484324 : do i = il1g, il2g
204 :
205 : ! use arithmetic mean
206 22146020 : chat(i,k) = 0.5_kind_phys* (const(i,k)+const(i,km1))
207 :
208 : ! Provisional up and down draft values
209 22146020 : conu(i,k) = chat(i,k)
210 22146020 : cond(i,k) = chat(i,k)
211 :
212 : ! provisional tends
213 28435940 : 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 48384 : k=1
226 267122 : pgu(:il2g,k) = 0.0_kind_phys
227 218738 : pgd(:il2g,k) = 0.0_kind_phys
228 :
229 6241536 : do k=2,pver-1
230 6193152 : km1 = max(1,k-1)
231 6193152 : kp1 = min(pver,k+1)
232 28046848 : do i = il1g,il2g
233 :
234 : !interior points
235 :
236 65415936 : mududp(i,k) = ( mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) &
237 87221248 : + mu(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k))
238 :
239 21805312 : pgu(i,k) = - momcu * 0.5_kind_phys * mududp(i,k)
240 :
241 :
242 21805312 : mddudp(i,k) = ( md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) &
243 21805312 : + md(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k))
244 :
245 27998464 : pgd(i,k) = - momcd * 0.5_kind_phys * mddudp(i,k)
246 :
247 :
248 : end do
249 : end do
250 :
251 : ! bottom boundary
252 48384 : k = pver
253 48384 : km1 = max(1,k-1)
254 218738 : do i=il1g,il2g
255 :
256 170354 : mududp(i,k) = mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1)
257 170354 : pgu(i,k) = - momcu * mududp(i,k)
258 :
259 170354 : mddudp(i,k) = md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1)
260 :
261 218738 : 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 218738 : k = 2
272 218738 : km1 = 1
273 218738 : kk = pver
274 218738 : kkm1 = max(1,kk-1)
275 218738 : do i = il1g,il2g
276 170354 : mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk)
277 170354 : if (mupdudp > mbsth) then
278 :
279 157224 : conu(i,kk) = (+eu(i,kk)*const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp
280 : endif
281 218738 : 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 6289920 : do kk = pver-1,1,-1
292 6241536 : kkm1 = max(1,kk-1)
293 6241536 : kkp1 = min(pver,kk+1)
294 28265586 : do i = il1g,il2g
295 21975666 : mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk)
296 28217202 : if (mupdudp > mbsth) then
297 :
298 3049996 : conu(i,kk) = ( mu(i,kkp1)*conu(i,kkp1)+eu(i,kk)* &
299 3049996 : 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 6241536 : do k = 3,pver
308 6193152 : km1 = max(1,k-1)
309 28046848 : do i = il1g,il2g
310 27998464 : if (md(i,k) < -mbsth) then
311 :
312 2717352 : cond(i,k) = ( md(i,km1)*cond(i,km1)-ed(i,km1)*const(i,km1) &
313 2717352 : *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 621510 : do k = ktm,pver
325 573126 : km1 = max(1,k-1)
326 573126 : kp1 = min(pver,k+1)
327 2694962 : do i = il1g,il2g
328 2073452 : ii = ideep(i)
329 :
330 : ! version 1 hard to check for roundoff errors
331 2073452 : dcondt(i,k) = &
332 2073452 : +(mu(i,kp1)* (conu(i,kp1)-chat(i,kp1)) &
333 2073452 : -mu(i,k)* (conu(i,k)-chat(i,k)) &
334 2073452 : +md(i,kp1)* (cond(i,kp1)-chat(i,kp1)) &
335 2073452 : -md(i,k)* (cond(i,k)-chat(i,k)) &
336 6793482 : )/dp(i,k)
337 :
338 : end do
339 : end do
340 :
341 : ! dcont for bottom layer
342 : !
343 113030 : do k = kbm,pver
344 301716 : km1 = max(1,k-1)
345 350100 : do i = il1g,il2g
346 301716 : if (k == mx(i)) then
347 :
348 : ! version 1
349 170354 : dcondt(i,k) = (1._kind_phys/dp(i,k))* &
350 170354 : (-mu(i,k)*(conu(i,k)-chat(i,k)) &
351 170354 : -md(i,k)*(cond(i,k)-chat(i,k)) &
352 340708 : )
353 : end if
354 : end do
355 : end do
356 :
357 : ! Initialize to zero everywhere, then scatter tendency back to full array
358 81817344 : wind_tends(:,:,m) = 0._kind_phys
359 :
360 6338304 : do k = 1,pver
361 28484324 : do i = il1g,il2g
362 22146020 : ii = ideep(i)
363 22146020 : wind_tends(ii,k,m) = dcondt(i,k)
364 : ! Output apparent force on the mean flow from pressure gradient
365 22146020 : pguall(ii,k,m) = -pgu(i,k)
366 22146020 : pgdall(ii,k,m) = -pgd(i,k)
367 22146020 : icwu(ii,k,m) = conu(i,k)
368 28435940 : 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 621510 : do k = ktm,pver
375 2694962 : do i = il1g,il2g
376 2073452 : ii = ideep(i)
377 2073452 : mflux(i,k,m) = &
378 2073452 : -mu(i,k)* (conu(i,k)-chat(i,k)) &
379 4720030 : -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 621510 : do k = ktm,pver
387 2694962 : do i = il1g,il2g
388 2073452 : ii = ideep(i)
389 2073452 : km1 = max(1,k-1)
390 2073452 : kp1 = k+1
391 2646578 : 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 310755 : do k = ktm,pver
404 286563 : km1 = max(1,k-1)
405 286563 : kp1 = min(pver,k+1)
406 1347481 : do i = il1g,il2g
407 :
408 1036726 : 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 1036726 : utop = (wind0(i,k,1)+wind0(i,km1,1))/2._kind_phys
413 1036726 : vtop = (wind0(i,k,2)+wind0(i,km1,2))/2._kind_phys
414 1036726 : ubot = (wind0(i,kp1,1)+wind0(i,k,1))/2._kind_phys
415 1036726 : vbot = (wind0(i,kp1,2)+wind0(i,k,2))/2._kind_phys
416 1036726 : fket = utop*mflux(i,k,1) + vtop*mflux(i,k,2) ! top of layer
417 1036726 : 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 1036726 : ketend_cons = (fket-fkeb)/dp(i,k)
421 :
422 : ! tendency in kinetic energy resulting from the momentum transport
423 1036726 : 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 1036726 : gset2 = ketend_cons - ketend
427 1323289 : gseten(i,k) = gset2
428 :
429 : end do
430 :
431 : end do
432 :
433 : ! Scatter dry static energy to full array
434 3169152 : do k = 1,pver
435 14242162 : do i = il1g,il2g
436 11073010 : ii = ideep(i)
437 14217970 : seten(ii,k) = gseten(i,k)
438 :
439 : end do
440 : end do
441 :
442 : ! Split out the wind tendencies
443 40932864 : windu_tend(:,:) = wind_tends(:,:,1)
444 40932864 : windv_tend(:,:) = wind_tends(:,:,2)
445 :
446 40932864 : pguallu(:,:) = pguall(:,:,1)
447 40932864 : pguallv(:,:) = pguall(:,:,2)
448 40932864 : pgdallu(:,:) = pgdall(:,:,1)
449 40932864 : pgdallv(:,:) = pgdall(:,:,2)
450 40932864 : icwuu(:ncol,:) = icwu(:,:,1)
451 40932864 : icwuv(:ncol,:) = icwu(:,:,2)
452 40932864 : icwdu(:ncol,:) = icwd(:,:,1)
453 40932864 : icwdv(:ncol,:) = icwd(:,:,2)
454 :
455 24192 : return
456 : end subroutine zm_conv_momtran_run
457 :
458 :
459 : end module zm_conv_momtran
|