| blob | 403532e0941120e097a7101bcd917da06d37e820 |
1 #define NEED_B4B_DURING_CCPP_TESTING 1
2 !=================================================================================================================
3 module module_bl_ysu
4 use ccpp_kind_types,only: kind_phys
5 use bl_ysu
8 implicit none
9 private
10 public:: ysu
13 contains
16 !=================================================================================================================
17 subroutine ysu(u3d,v3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, &
18 rublten,rvblten,rthblten, &
19 rqvblten,rqcblten,rqiblten,flag_qc,flag_qi, &
20 cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, &
21 dz8w,psfc, &
22 znt,ust,hpbl,psim,psih, &
23 xland,hfx,qfx,wspd,br, &
24 dt,kpbl2d, &
25 exch_h,exch_m, &
26 wstar,delta, &
27 u10,v10, &
28 uoce,voce, &
29 rthraten,ysu_topdown_pblmix, &
30 ctopo,ctopo2, &
31 idiff,flag_bep,frc_urb2d, &
32 a_u_bep,a_v_bep,a_t_bep, &
33 a_q_bep, &
34 a_e_bep,b_u_bep,b_v_bep, &
35 b_t_bep,b_q_bep, &
36 b_e_bep,dlg_bep, &
37 dl_u_bep,sf_bep,vl_bep, &
38 ids,ide, jds,jde, kds,kde, &
39 ims,ime, jms,jme, kms,kme, &
40 its,ite, jts,jte, kts,kte, &
41 errmsg,errflg &
42 )
43 !-------------------------------------------------------------------------------
44 implicit none
45 !-------------------------------------------------------------------------------
46 !-- u3d 3d u-velocity interpolated to theta points (m/s)
47 !-- v3d 3d v-velocity interpolated to theta points (m/s)
48 !-- th3d 3d potential temperature (k)
49 !-- t3d temperature (k)
50 !-- qv3d 3d water vapor mixing ratio (kg/kg)
51 !-- qc3d 3d cloud mixing ratio (kg/kg)
52 !-- qi3d 3d ice mixing ratio (kg/kg)
53 ! (note: if P_QI<PARAM_FIRST_SCALAR this should be zero filled)
54 !-- p3d 3d pressure (pa)
55 !-- p3di 3d pressure (pa) at interface level
56 !-- pi3d 3d exner function (dimensionless)
57 !-- rr3d 3d dry air density (kg/m^3)
58 !-- rublten u tendency due to
59 ! pbl parameterization (m/s/s)
60 !-- rvblten v tendency due to
61 ! pbl parameterization (m/s/s)
62 !-- rthblten theta tendency due to
63 ! pbl parameterization (K/s)
64 !-- rqvblten qv tendency due to
65 ! pbl parameterization (kg/kg/s)
66 !-- rqcblten qc tendency due to
67 ! pbl parameterization (kg/kg/s)
68 !-- rqiblten qi tendency due to
69 ! pbl parameterization (kg/kg/s)
70 !-- cp heat capacity at constant pressure for dry air (j/kg/k)
71 !-- g acceleration due to gravity (m/s^2)
72 !-- rovcp r/cp
73 !-- rd gas constant for dry air (j/kg/k)
74 !-- rovg r/g
75 !-- dz8w dz between full levels (m)
76 !-- xlv latent heat of vaporization (j/kg)
77 !-- rv gas constant for water vapor (j/kg/k)
78 !-- psfc pressure at the surface (pa)
79 !-- znt roughness length (m)
80 !-- ust u* in similarity theory (m/s)
81 !-- hpbl pbl height (m)
82 !-- psim similarity stability function for momentum
83 !-- psih similarity stability function for heat
84 !-- xland land mask (1 for land, 2 for water)
85 !-- hfx upward heat flux at the surface (w/m^2)
86 !-- qfx upward moisture flux at the surface (kg/m^2/s)
87 !-- wspd wind speed at lowest model level (m/s)
88 !-- u10 u-wind speed at 10 m (m/s)
89 !-- v10 v-wind speed at 10 m (m/s)
90 !-- uoce sea surface zonal currents (m s-1)
91 !-- voce sea surface meridional currents (m s-1)
92 !-- br bulk richardson number in surface layer
93 !-- dt time step (s)
94 !-- rvovrd r_v divided by r_d (dimensionless)
95 !-- ep1 constant for virtual temperature (r_v/r_d - 1)
96 !-- ep2 constant for specific humidity calculation
97 !-- karman von karman constant
98 !-- idiff diff3d BEP/BEM+BEM diffusion flag
99 !-- flag_bep flag to use BEP/BEP+BEM
100 !-- frc_urb2d urban fraction
101 !-- a_u_bep BEP/BEP+BEM implicit component u-mom
102 !-- a_v_bep BEP/BEP+BEM implicit component v-mom
103 !-- a_t_bep BEP/BEP+BEM implicit component pot. temp.
104 !-- a_q_bep BEP/BEP+BEM implicit component vapor mixing ratio
105 !-- a_e_bep BEP/BEP+BEM implicit component TKE
106 !-- b_u_bep BEP/BEP+BEM explicit component u-mom
107 !-- b_v_bep BEP/BEP+BEM explicit component v-mom
108 !-- b_t_bep BEP/BEP+BEM explicit component pot.temp.
109 !-- b_q_bep BEP/BEP+BEM explicit component vapor mixing ratio
110 !-- b_e_bep BEP/BEP+BEM explicit component TKE
111 !-- dlg_bep Height above ground Martilli et al. (2002) Eq. 24
112 !-- dl_u_bep modified length scale Martilli et al. (2002) Eq. 22
113 !-- sf_bep fraction of vertical surface not occupied by buildings
114 !-- vl_bep volume fraction of grid cell not occupied by buildings
115 !-- ids start index for i in domain
116 !-- ide end index for i in domain
117 !-- jds start index for j in domain
118 !-- jde end index for j in domain
119 !-- kds start index for k in domain
120 !-- kde end index for k in domain
121 !-- ims start index for i in memory
122 !-- ime end index for i in memory
123 !-- jms start index for j in memory
124 !-- jme end index for j in memory
125 !-- kms start index for k in memory
126 !-- kme end index for k in memory
127 !-- its start index for i in tile
128 !-- ite end index for i in tile
129 !-- jts start index for j in tile
130 !-- jte end index for j in tile
131 !-- kts start index for k in tile
132 !-- kte end index for k in tile
133 !-------------------------------------------------------------------------------
134 !
135 !
136 integer, intent(in ) :: ids,ide, jds,jde, kds,kde, &
137 ims,ime, jms,jme, kms,kme, &
138 its,ite, jts,jte, kts,kte
140 integer, intent(in) :: ysu_topdown_pblmix
141 !
142 real(kind=kind_phys), intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv
143 !
144 real(kind=kind_phys), intent(in ) :: ep1,ep2,karman
145 !
146 real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , &
147 intent(in ) :: qv3d, &
148 qc3d, &
149 qi3d, &
150 p3d, &
151 pi3d, &
152 t3d, &
153 dz8w, &
154 rthraten
155 real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , &
156 intent(in ) :: p3di
157 !
158 real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , &
159 intent(out ) :: rublten, &
160 rvblten, &
161 rthblten, &
162 rqvblten, &
163 rqcblten, &
164 rqiblten
165 !
166 real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , &
167 intent(out ) :: exch_h, &
168 exch_m
169 real(kind=kind_phys), dimension( ims:ime, jms:jme ) , &
170 intent(out ) :: wstar
171 real(kind=kind_phys), dimension( ims:ime, jms:jme ) , &
172 intent(out ) :: delta
173 real(kind=kind_phys), dimension( ims:ime, jms:jme ) , &
174 intent(inout) :: u10, &
175 v10
176 real(kind=kind_phys), dimension( ims:ime, jms:jme ) , &
177 intent(in ) :: uoce, &
178 voce
179 !
180 real(kind=kind_phys), dimension( ims:ime, jms:jme ) , &
181 intent(in ) :: xland, &
182 hfx, &
183 qfx, &
184 br, &
185 psfc
186 real(kind=kind_phys), dimension( ims:ime, jms:jme ) , &
187 intent(in ) :: &
188 psim, &
189 psih
190 real(kind=kind_phys), dimension( ims:ime, jms:jme ) , &
191 intent(in ) :: znt, &
192 ust, &
193 wspd
194 real(kind=kind_phys), dimension( ims:ime, jms:jme ) , &
195 intent(out ) :: hpbl
196 !
197 real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , &
198 intent(in ) :: u3d, &
199 v3d
200 !
201 integer, dimension( ims:ime, jms:jme ) , &
202 intent(out ) :: kpbl2d
203 !
204 logical, intent(in) :: flag_qc, &
205 flag_qi
206 !
207 integer, intent(in) :: idiff
208 logical, intent(in) :: flag_bep
209 real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , &
210 optional , &
211 intent(in) :: a_u_bep, &
212 a_v_bep,a_t_bep, &
213 a_e_bep,b_u_bep, &
214 a_q_bep,b_q_bep, &
215 b_v_bep,b_t_bep, &
216 b_e_bep,dlg_bep, &
217 dl_u_bep, &
218 vl_bep,sf_bep
219 real(kind=kind_phys), dimension(ims:ime,jms:jme) , &
220 optional , &
221 intent(in) :: frc_urb2d
222 !
223 real(kind=kind_phys), dimension( ims:ime, jms:jme ) , &
224 optional , &
225 intent(in ) :: ctopo, &
226 ctopo2
227 !
228 character(len=*), intent(out) :: errmsg
229 integer, intent(out) :: errflg
230 !local
231 integer :: i,j,k
233 !temporary allocation of local chemical species and/or passive tracers that are vertically-
234 !mixed in subroutine bl_ysu_run:
235 logical:: l_topdown_pblmix
237 integer, parameter :: nmix = 0
238 integer :: n
240 real(kind=kind_phys), dimension(ims:ime,kms:kme,jms:jme,nmix):: qmix
241 real(kind=kind_phys), dimension(ims:ime,kms:kme,jms:jme,nmix):: rqmixblten
243 ! Local tile-sized arrays for contiguous data for bl_ysu_run call.
245 real(kind=kind_phys), dimension(its:ite,kts:kte,nmix) :: &
246 qmix_hv , &
247 rqmixblten_hv
249 real(kind=kind_phys), dimension(its:ite,kts:kte) :: &
250 u3d_hv , &
251 v3d_hv , &
252 t3d_hv , &
253 qv3d_hv , &
254 qc3d_hv , &
255 qi3d_hv , &
256 p3d_hv , &
257 pi3d_hv , &
258 rublten_hv , &
259 rvblten_hv , &
260 rthblten_hv , &
261 rqvblten_hv , &
262 rqcblten_hv , &
263 rqiblten_hv , &
264 dz8w_hv , &
265 exch_h_hv , &
266 exch_m_hv , &
267 rthraten_hv
269 real(kind=kind_phys), dimension(its:ite,kts:kte) :: &
270 a_u_hv , &
271 a_v_hv , &
272 a_t_hv , &
273 a_e_hv , &
274 b_u_hv , &
275 a_q_hv , &
276 b_q_hv , &
277 b_v_hv , &
278 b_t_hv , &
279 b_e_hv , &
280 dlg_hv , &
281 dl_u_hv , &
282 vlk_hv , &
283 sfk_hv
284 real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: &
285 p3di_hv
287 real(kind=kind_phys), dimension(its:ite) :: &
288 psfc_hv , &
289 znt_hv , &
290 ust_hv , &
291 hpbl_hv , &
292 psim_hv , &
293 psih_hv , &
294 xland_hv , &
295 hfx_hv , &
296 qfx_hv , &
297 wspd_hv , &
298 br_hv , &
299 wstar_hv , &
300 delta_hv , &
301 u10_hv , &
302 v10_hv , &
303 uoce_hv , &
304 voce_hv , &
305 ctopo_hv , &
306 ctopo2_hv
308 integer, dimension(its:ite) :: &
309 kpbl2d_hv
310 real, dimension(its:ite) :: &
311 frcurb_hv
313 !-----------------------------------------------------------------------------------------------------------------
315 l_topdown_pblmix = .false.
316 if(ysu_topdown_pblmix .eq. 1) l_topdown_pblmix = .true.
318 do j = jts,jte
319 !
320 ! Assign input data to local tile-sized arrays.
322 do n = 1, nmix
323 do k = kts, kte
324 do i = its, ite
325 qmix_hv(i,k,n) = qmix(i,k,j,n)
326 end do
327 end do
328 end do
330 do k = kts, kte+1
331 do i = its, ite
332 p3di_hv(i,k) = p3di(i,k,j)
333 end do
334 end do
336 do k = kts, kte
337 do i = its, ite
338 u3d_hv(i,k) = u3d(i,k,j)
339 v3d_hv(i,k) = v3d(i,k,j)
340 t3d_hv(i,k) = t3d(i,k,j)
341 qv3d_hv(i,k) = qv3d(i,k,j)
342 qc3d_hv(i,k) = qc3d(i,k,j)
343 qi3d_hv(i,k) = qi3d(i,k,j)
344 p3d_hv(i,k) = p3d(i,k,j)
345 pi3d_hv(i,k) = pi3d(i,k,j)
346 dz8w_hv(i,k) = dz8w(i,k,j)
347 rthraten_hv(i,k) = rthraten(i,k,j)
348 end do
349 end do
351 if(present(a_u_bep) .and. present(a_v_bep) .and. present(a_t_bep) .and. &
352 present(a_q_bep) .and. present(a_e_bep) .and. present(b_u_bep) .and. &
353 present(b_v_bep) .and. present(b_t_bep) .and. present(b_q_bep) .and. &
354 present(b_e_bep) .and. present(dlg_bep) .and. present(dl_u_bep) .and. &
355 present(sf_bep) .and. present(vl_bep) .and. present(frc_urb2d)) then
356 do k = kts, kte
357 do i = its,ite
358 a_u_hv(i,k) = a_u_bep(i,k,j)
359 a_v_hv(i,k) = a_v_bep(i,k,j)
360 a_t_hv(i,k) = a_t_bep(i,k,j)
361 a_q_hv(i,k) = a_q_bep(i,k,j)
362 a_e_hv(i,k) = a_e_bep(i,k,j)
363 b_u_hv(i,k) = b_u_bep(i,k,j)
364 b_v_hv(i,k) = b_v_bep(i,k,j)
365 b_t_hv(i,k) = b_t_bep(i,k,j)
366 b_q_hv(i,k) = b_q_bep(i,k,j)
367 b_e_hv(i,k) = b_e_bep(i,k,j)
368 dlg_hv(i,k) = dlg_bep(i,k,j)
369 dl_u_hv(i,k) = dl_u_bep(i,k,j)
370 vlk_hv(i,k) = vl_bep(i,k,j)
371 sfk_hv(i,k) = sf_bep(i,k,j)
372 enddo
373 enddo
374 do i = its, ite
375 frcurb_hv(i) = frc_urb2d(i,j)
376 enddo
377 endif
379 do i = its, ite
380 psfc_hv(i) = psfc(i,j)
381 znt_hv(i) = znt(i,j)
382 ust_hv(i) = ust(i,j)
383 wspd_hv(i) = wspd(i,j)
384 psim_hv(i) = psim(i,j)
385 psih_hv(i) = psih(i,j)
386 xland_hv(i) = xland(i,j)
387 hfx_hv(i) = hfx(i,j)
388 qfx_hv(i) = qfx(i,j)
389 br_hv(i) = br(i,j)
390 u10_hv(i) = u10(i,j)
391 v10_hv(i) = v10(i,j)
392 uoce_hv(i) = uoce(i,j)
393 voce_hv(i) = voce(i,j)
394 ctopo_hv(i) = ctopo(i,j)
395 ctopo2_hv(i) = ctopo2(i,j)
396 end do
397 !
398 call bl_ysu_run(ux=u3d_hv,vx=v3d_hv &
399 ,tx=t3d_hv &
400 ,qvx=qv3d_hv,qcx=qc3d_hv,qix=qi3d_hv &
401 ,f_qc=flag_qc,f_qi=flag_qi &
402 ,nmix=nmix,qmix=qmix_hv &
403 ,p2d=p3d_hv,p2di=p3di_hv &
404 ,pi2d=pi3d_hv &
405 ,utnp=rublten_hv,vtnp=rvblten_hv &
406 ,ttnp=rthblten_hv,qvtnp=rqvblten_hv &
407 ,qctnp=rqcblten_hv,qitnp=rqiblten_hv &
408 ,qmixtnp=rqmixblten_hv &
409 ,cp=cp,g=g,rovcp=rovcp,rd=rd,rovg=rovg &
410 ,xlv=xlv,rv=rv &
411 ,ep1=ep1,ep2=ep2,karman=karman &
412 ,dz8w2d=dz8w_hv &
413 ,psfcpa=psfc_hv,znt=znt_hv,ust=ust_hv &
414 ,hpbl=hpbl_hv &
415 ,psim=psim_hv &
416 ,psih=psih_hv,xland=xland_hv &
417 ,hfx=hfx_hv,qfx=qfx_hv &
418 ,wspd=wspd_hv,br=br_hv &
419 ,dt=dt,kpbl1d=kpbl2d_hv &
420 ,exch_hx=exch_h_hv &
421 ,exch_mx=exch_m_hv &
422 ,wstar=wstar_hv &
423 ,delta=delta_hv &
424 ,u10=u10_hv,v10=v10_hv &
425 ,uox=uoce_hv,vox=voce_hv &
426 ,rthraten=rthraten_hv &
427 ,ysu_topdown_pblmix=l_topdown_pblmix &
428 ,ctopo=ctopo_hv,ctopo2=ctopo2_hv &
429 ,a_u=a_u_hv,a_v=a_v_hv,a_t=a_t_hv,a_q=a_q_hv,a_e=a_e_hv &
430 ,b_u=b_u_hv,b_v=b_v_hv,b_t=b_t_hv,b_q=b_q_hv,b_e=b_e_hv &
431 ,sfk=sfk_hv,vlk=vlk_hv,dlu=dl_u_hv,dlg=dlg_hv,frcurb=frcurb_hv &
432 ,flag_bep=flag_bep &
433 ,its=its,ite=ite,kte=kte,kme=kme &
434 ,errmsg=errmsg,errflg=errflg )
435 !
436 ! Assign local data back to full-sized arrays.
437 ! Only required for the INTENT(OUT) or INTENT(INOUT) arrays.
439 do n = 1, nmix
440 do k = kts, kte
441 do i = its, ite
442 rqmixblten(i,k,j,n) = rqmixblten_hv(i,k,n)
443 end do
444 end do
445 end do
447 do k = kts, kte
448 do i = its, ite
449 rublten(i,k,j) = rublten_hv(i,k)
450 rvblten(i,k,j) = rvblten_hv(i,k)
451 #if (NEED_B4B_DURING_CCPP_TESTING == 1)
452 rthblten(i,k,j) = rthblten_hv(i,k)/pi3d_hv(i,k)
453 #elif (NEED_B4B_DURING_CCPP_TESTING != 1)
454 rthblten(i,k,j) = rthblten_hv(i,k)
455 #endif
456 rqvblten(i,k,j) = rqvblten_hv(i,k)
457 rqcblten(i,k,j) = rqcblten_hv(i,k)
458 rqiblten(i,k,j) = rqiblten_hv(i,k)
459 exch_h(i,k,j) = exch_h_hv(i,k)
460 exch_m(i,k,j) = exch_m_hv(i,k)
461 end do
462 end do
464 do i = its, ite
465 u10(i,j) = u10_hv(i)
466 v10(i,j) = v10_hv(i)
467 hpbl(i,j) = hpbl_hv(i)
468 kpbl2d(i,j) = kpbl2d_hv(i)
469 wstar(i,j) = wstar_hv(i)
470 delta(i,j) = delta_hv(i)
471 end do
472 enddo
474 end subroutine ysu
476 !=================================================================================================================
477 end module module_bl_ysu
478 !=================================================================================================================