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