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 39900672 : winds(:,:,1) = windu(:,:)
154 39820032 : winds(:,:,2) = windv(:,:)
155 :
156 : ! Initialize outgoing fields
157 79720704 : pguall(:,:,:) = 0.0_kind_phys
158 79720704 : pgdall(:,:,:) = 0.0_kind_phys
159 : ! Initialize in-cloud winds to environmental wind
160 79720704 : icwu(:ncol,:,:) = winds(:ncol,:,:)
161 79720704 : icwd(:ncol,:,:) = winds(:ncol,:,:)
162 :
163 : ! Initialize momentum flux and final winds
164 82204416 : mflux(:,:,:) = 0.0_kind_phys
165 79720704 : wind0(:,:,:) = 0.0_kind_phys
166 79720704 : windf(:,:,:) = 0.0_kind_phys
167 :
168 : ! Initialize dry static energy
169 :
170 39820032 : seten(:,:) = 0.0_kind_phys
171 39820032 : 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 318683 : do i = il1g, il2g
180 238043 : ktm = min(ktm,jt(i))
181 318683 : 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 5322240 : do k = 1,pver
190 20556992 : do i =il1g,il2g
191 15234752 : const(i,k) = winds(ideep(i),k,m)
192 20395712 : 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 5322240 : do k = 1,pver
202 5160960 : km1 = max(1,k-1)
203 20556992 : do i = il1g, il2g
204 :
205 : ! use arithmetic mean
206 15234752 : chat(i,k) = 0.5_kind_phys* (const(i,k)+const(i,km1))
207 :
208 : ! Provisional up and down draft values
209 15234752 : conu(i,k) = chat(i,k)
210 15234752 : cond(i,k) = chat(i,k)
211 :
212 : ! provisional tends
213 20395712 : 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 798646 : pgu(:il2g,k) = 0.0_kind_phys
227 637366 : pgd(:il2g,k) = 0.0_kind_phys
228 :
229 4999680 : do k=2,pver-1
230 4838400 : km1 = max(1,k-1)
231 4838400 : kp1 = min(pver,k+1)
232 19282260 : do i = il1g,il2g
233 :
234 : !interior points
235 :
236 42847740 : mududp(i,k) = ( mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) &
237 57130320 : + mu(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k))
238 :
239 14282580 : pgu(i,k) = - momcu * 0.5_kind_phys * mududp(i,k)
240 :
241 :
242 14282580 : mddudp(i,k) = ( md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) &
243 14282580 : + md(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k))
244 :
245 19120980 : 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 637366 : do i=il1g,il2g
255 :
256 476086 : mududp(i,k) = mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1)
257 476086 : pgu(i,k) = - momcu * mududp(i,k)
258 :
259 476086 : mddudp(i,k) = md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1)
260 :
261 637366 : 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 637366 : k = 2
272 637366 : km1 = 1
273 637366 : kk = pver
274 637366 : kkm1 = max(1,kk-1)
275 637366 : do i = il1g,il2g
276 476086 : mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk)
277 476086 : if (mupdudp > mbsth) then
278 :
279 452462 : conu(i,kk) = (+eu(i,kk)*const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp
280 : endif
281 637366 : 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 5160960 : do kk = pver-1,1,-1
292 4999680 : kkm1 = max(1,kk-1)
293 4999680 : kkp1 = min(pver,kk+1)
294 19919626 : do i = il1g,il2g
295 14758666 : mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk)
296 19758346 : if (mupdudp > mbsth) then
297 :
298 8437276 : conu(i,kk) = ( mu(i,kkp1)*conu(i,kkp1)+eu(i,kk)* &
299 8437276 : 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 4999680 : do k = 3,pver
308 4838400 : km1 = max(1,k-1)
309 19282260 : do i = il1g,il2g
310 19120980 : if (md(i,k) < -mbsth) then
311 :
312 7575892 : cond(i,k) = ( md(i,km1)*cond(i,km1)-ed(i,km1)*const(i,km1) &
313 7575892 : *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 1985242 : do k = ktm,pver
325 1823962 : km1 = max(1,k-1)
326 1823962 : kp1 = min(pver,k+1)
327 7565232 : do i = il1g,il2g
328 5579990 : ii = ideep(i)
329 :
330 : ! version 1 hard to check for roundoff errors
331 5579990 : dcondt(i,k) = &
332 5579990 : +(mu(i,kp1)* (conu(i,kp1)-chat(i,kp1)) &
333 5579990 : -mu(i,k)* (conu(i,k)-chat(i,k)) &
334 5579990 : +md(i,kp1)* (cond(i,kp1)-chat(i,kp1)) &
335 5579990 : -md(i,k)* (cond(i,k)-chat(i,k)) &
336 18563932 : )/dp(i,k)
337 :
338 : end do
339 : end do
340 :
341 : ! dcont for bottom layer
342 : !
343 353390 : do k = kbm,pver
344 787398 : km1 = max(1,k-1)
345 948678 : do i = il1g,il2g
346 787398 : if (k == mx(i)) then
347 :
348 : ! version 1
349 476086 : dcondt(i,k) = (1._kind_phys/dp(i,k))* &
350 476086 : (-mu(i,k)*(conu(i,k)-chat(i,k)) &
351 476086 : -md(i,k)*(cond(i,k)-chat(i,k)) &
352 952172 : )
353 : end if
354 : end do
355 : end do
356 :
357 : ! Initialize to zero everywhere, then scatter tendency back to full array
358 79640064 : wind_tends(:,:,m) = 0._kind_phys
359 :
360 5322240 : do k = 1,pver
361 20556992 : do i = il1g,il2g
362 15234752 : ii = ideep(i)
363 15234752 : wind_tends(ii,k,m) = dcondt(i,k)
364 : ! Output apparent force on the mean flow from pressure gradient
365 15234752 : pguall(ii,k,m) = -pgu(i,k)
366 15234752 : pgdall(ii,k,m) = -pgd(i,k)
367 15234752 : icwu(ii,k,m) = conu(i,k)
368 20395712 : 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 1985242 : do k = ktm,pver
375 7565232 : do i = il1g,il2g
376 5579990 : ii = ideep(i)
377 5579990 : mflux(i,k,m) = &
378 5579990 : -mu(i,k)* (conu(i,k)-chat(i,k)) &
379 12983942 : -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 1985242 : do k = ktm,pver
387 7565232 : do i = il1g,il2g
388 5579990 : ii = ideep(i)
389 5579990 : km1 = max(1,k-1)
390 5579990 : kp1 = k+1
391 7403952 : 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 992621 : do k = ktm,pver
404 911981 : km1 = max(1,k-1)
405 911981 : kp1 = min(pver,k+1)
406 3782616 : do i = il1g,il2g
407 :
408 2789995 : 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 2789995 : utop = (wind0(i,k,1)+wind0(i,km1,1))/2._kind_phys
413 2789995 : vtop = (wind0(i,k,2)+wind0(i,km1,2))/2._kind_phys
414 2789995 : ubot = (wind0(i,kp1,1)+wind0(i,k,1))/2._kind_phys
415 2789995 : vbot = (wind0(i,kp1,2)+wind0(i,k,2))/2._kind_phys
416 2789995 : fket = utop*mflux(i,k,1) + vtop*mflux(i,k,2) ! top of layer
417 2789995 : 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 2789995 : ketend_cons = (fket-fkeb)/dp(i,k)
421 :
422 : ! tendency in kinetic energy resulting from the momentum transport
423 2789995 : 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 2789995 : gset2 = ketend_cons - ketend
427 3701976 : gseten(i,k) = gset2
428 :
429 : end do
430 :
431 : end do
432 :
433 : ! Scatter dry static energy to full array
434 2661120 : do k = 1,pver
435 10278496 : do i = il1g,il2g
436 7617376 : ii = ideep(i)
437 10197856 : seten(ii,k) = gseten(i,k)
438 :
439 : end do
440 : end do
441 :
442 : ! Split out the wind tendencies
443 39900672 : windu_tend(:,:) = wind_tends(:,:,1)
444 39900672 : windv_tend(:,:) = wind_tends(:,:,2)
445 :
446 39900672 : pguallu(:,:) = pguall(:,:,1)
447 39900672 : pguallv(:,:) = pguall(:,:,2)
448 39900672 : pgdallu(:,:) = pgdall(:,:,1)
449 39900672 : pgdallv(:,:) = pgdall(:,:,2)
450 39900672 : icwuu(:ncol,:) = icwu(:,:,1)
451 39900672 : icwuv(:ncol,:) = icwu(:,:,2)
452 39900672 : icwdu(:ncol,:) = icwd(:,:,1)
453 39900672 : icwdv(:ncol,:) = icwd(:,:,2)
454 :
455 80640 : return
456 : end subroutine zm_conv_momtran_run
457 :
458 :
459 : end module zm_conv_momtran
|