CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
cires_ugwp.F90
1
3
16
17 use machine, only: kind_phys
18
19 use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize
21 use gwdps, only: gwdps_run
23
24 implicit none
25
26 private
27
28 public cires_ugwp_init, cires_ugwp_run, cires_ugwp_finalize
29
30 logical :: is_initialized = .false.
31
32contains
33
34! ------------------------------------------------------------------------
35! CCPP entry points for CIRES Unified Gravity Wave Physics (UGWP) scheme v0
36! ------------------------------------------------------------------------
41 subroutine cires_ugwp_init (me, master, nlunit, input_nml_file, logunit, &
42 fn_nml2, lonr, latr, levs, ak, bk, dtp, cdmbgwd, cgwf, &
43 pa_rf_in, tau_rf_in, con_p0, gwd_opt,do_ugwp, errmsg, errflg)
44
45!---- initialization of cires_ugwp
46 implicit none
47
48 integer, intent (in) :: me
49 integer, intent (in) :: master
50 integer, intent (in) :: nlunit
51 character(len=*), intent (in) :: input_nml_file(:)
52 integer, intent (in) :: logunit
53 integer, intent (in) :: lonr
54 integer, intent (in) :: levs
55 integer, intent (in) :: latr
56 real(kind=kind_phys), intent (in) :: ak(:), bk(:)
57 real(kind=kind_phys), intent (in) :: dtp
58 real(kind=kind_phys), intent (in) :: cdmbgwd(:), cgwf(:) ! "scaling" controls for "old" GFS-GW schemes
59 real(kind=kind_phys), intent (in) :: pa_rf_in, tau_rf_in
60 real(kind=kind_phys), intent (in) :: con_p0
61 integer, intent(in) :: gwd_opt
62 logical, intent (in) :: do_ugwp
63
64 character(len=*), intent (in) :: fn_nml2
65 !character(len=*), parameter :: fn_nml='input.nml'
66
67 integer :: ios
68 logical :: exists
69 real :: dxsg
70 integer :: k
71
72 character(len=*), intent(out) :: errmsg
73 integer, intent(out) :: errflg
74
75 ! Initialize CCPP error handling variables
76 errmsg = ''
77 errflg = 0
78
79 if (is_initialized) return
80
81 ! Consistency checks
82 if (gwd_opt/=1) then
83 write(errmsg,'(*(a))') "Logic error: namelist choice of gravity wave &
84 & drag is different from cires_ugwp scheme"
85 errflg = 1
86 return
87 end if
88
89 if (do_ugwp .or. cdmbgwd(3) > 0.0) then
90 call cires_ugwpv0_mod_init (me, master, nlunit, input_nml_file, logunit, &
91 fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, &
92 cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in)
93 else
94 write(errmsg,'(*(a))') "Logic error: cires_ugwp_init called but do_ugwp is false and cdmbgwd(3) <= 0"
95 errflg = 1
96 return
97 end if
98
99 if (.not.knob_ugwp_version==0) then
100 write(errmsg,'(*(a))') 'Logic error: CCPP only supports version zero of UGWP'
101 errflg = 1
102 return
103 end if
104
105 is_initialized = .true.
106
107 end subroutine cires_ugwp_init
108
109
110! -----------------------------------------------------------------------
111! finalize of cires_ugwp (_finalize)
112! -----------------------------------------------------------------------
113
115#if 0
116
119#endif
120 subroutine cires_ugwp_finalize(errmsg, errflg)
121
122 implicit none
123!
124 character(len=*), intent(out) :: errmsg
125 integer, intent(out) :: errflg
126
127! Initialize CCPP error handling variables
128 errmsg = ''
129 errflg = 0
130
131 if (.not.is_initialized) return
132
133 call cires_ugwpv0_mod_finalize()
134
135 is_initialized = .false.
136
137 end subroutine cires_ugwp_finalize
138
139
140! -----------------------------------------------------------------------
141! originally from ugwp_driver_v0.f
142! driver of cires_ugwp (_driver)
143! -----------------------------------------------------------------------
144! driver is called after pbl & before chem-parameterizations
145! -----------------------------------------------------------------------
146! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re
147! -----------------------------------------------------------------------
194! \section det_cires_ugwp CIRES UGWP V0 Scheme Detailed Algorithm
195 subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr, &
196 oro, oro_uf, hprime, nmtvr, oc, theta, sigma, gamma, elvmax, clx, oa4, &
197 do_tofd, ldiag_ugwp, cdmbgwd, xlat, xlat_d, sinlat, coslat, &
198 area, ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, phii, phil, &
199 del, kpbl, dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, &
200 tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, &
201 dusfc_ms, dvsfc_ms, dusfc_bl, dvsfc_bl, &
202 dudt_ogw, dtauy2d_ms, dtaux2d_bl, dtauy2d_bl, &
203 dudt_mtb, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, &
204 dudt, dvdt, dtdt, rdxzb, con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, &
205 con_omega, rain, ntke, q_tke, dqdt_tke, lprnt, ipr, &
206 dtend, dtidx, index_of_x_wind, index_of_y_wind, index_of_temperature, &
207 index_of_process_orographic_gwd, index_of_process_nonorographic_gwd, &
208 ldiag3d, lssav, flag_for_gwd_generic_tend, errmsg, errflg)
209
210 implicit none
211
212 ! interface variables
213 integer, intent(in) :: me, master, im, levs, ntrac, kdt, lonr, nmtvr
214 integer, intent(in), dimension(:) :: kpbl
215 real(kind=kind_phys), intent(in), dimension(:) :: oro, oro_uf, hprime, oc, theta, sigma, gamma
216 logical, intent(in) :: flag_for_gwd_generic_tend
217 ! elvmax is intent(in) for CIRES UGWP, but intent(inout) for GFS GWDPS
218 real(kind=kind_phys), intent(inout), dimension(:) :: elvmax
219 real(kind=kind_phys), intent(in), dimension(:, :) :: clx, oa4
220 real(kind=kind_phys), intent(in), dimension(:) :: xlat, xlat_d, sinlat, coslat, area
221 real(kind=kind_phys), intent(in), dimension(:, :) :: del, ugrs, vgrs, tgrs, prsl, prslk, phil
222 real(kind=kind_phys), intent(in), dimension(:, :) :: prsi, phii
223 real(kind=kind_phys), intent(in), dimension(:,:,:):: qgrs
224 real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(:)
225 logical, intent(in) :: do_ugwp, do_tofd, ldiag_ugwp
226
227 real(kind=kind_phys), intent(out), dimension(:) :: dusfcg, dvsfcg
228 real(kind=kind_phys), intent(out), dimension(:) :: zmtb, zlwb, zogw, rdxzb
229 real(kind=kind_phys), intent(out), dimension(:) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw
230 real(kind=kind_phys), intent(out), dimension(:, :):: gw_dudt, gw_dvdt, gw_dtdt, gw_kdis
231 real(kind=kind_phys), intent(out), dimension(:, :):: dudt_mtb, dudt_tms
232 real(kind=kind_phys), intent(out), dimension(:, :), optional :: dudt_ogw
233 real(kind=kind_phys), intent(out), dimension(:), optional :: dusfc_ms, dvsfc_ms, dusfc_bl, dvsfc_bl
234 real(kind=kind_phys), intent(out), dimension(:, :), optional :: dtauy2d_ms
235 real(kind=kind_phys), intent(out), dimension(:, :), optional :: dtaux2d_bl, dtauy2d_bl
236
237 ! dtend is only allocated if ldiag=.true.
238 real(kind=kind_phys), optional, intent(inout) :: dtend(:,:,:)
239 integer, intent(in) :: dtidx(:,:), &
240 index_of_x_wind, index_of_y_wind, index_of_temperature, &
241 index_of_process_orographic_gwd, index_of_process_nonorographic_gwd
242
243 logical, intent(in) :: ldiag3d, lssav
244
245 ! These arrays only allocated if ldiag_ugwp = .true.
246 real(kind=kind_phys), intent(inout), dimension(:,:), optional :: du3dt_mtb, du3dt_ogw, du3dt_tms
247
248 real(kind=kind_phys), intent(inout), dimension(:, :):: dudt, dvdt, dtdt
249
250 real(kind=kind_phys), intent(in) :: con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, con_omega
251
252 real(kind=kind_phys), intent(in), dimension(:) :: rain
253
254 integer, intent(in) :: ntke
255 real(kind=kind_phys), intent(in), dimension(:,:) :: q_tke, dqdt_tke
256
257 logical, intent(in) :: lprnt
258 integer, intent(in) :: ipr
259
260 character(len=*), intent(out) :: errmsg
261 integer, intent(out) :: errflg
262
263 ! local variables
264 integer :: i, k, idtend
265 real(kind=kind_phys), dimension(im) :: sgh30
266 real(kind=kind_phys), dimension(im, levs) :: pdvdt, pdudt
267 real(kind=kind_phys), dimension(im, levs) :: pdtdt, pkdis
268 real(kind=kind_phys), dimension(im, levs) :: ed_dudt, ed_dvdt, ed_dtdt
269 ! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init
270 real(kind=kind_phys), parameter :: tamp_mpa=30.e-3
271 ! switches that activate impact of OGWs and NGWs (WL* how to deal with them? *WL)
272 real(kind=kind_phys), parameter :: pogw=1., pngw=1., pked=1.
273
274 real(kind=kind_phys), dimension(:,:), allocatable :: tke
275 real(kind=kind_phys), dimension(:), allocatable :: turb_fac, tem
276 real(kind=kind_phys) :: rfac, tx1
277
278 ! Initialize CCPP error handling variables
279 errmsg = ''
280 errflg = 0
281
282 ! 1) ORO stationary GWs
283 ! ------------------
284 ! wrap everything in a do_ugwp 'if test' in order not to break the namelist functionality
285 if (do_ugwp) then ! calling revised old GFS gravity wave drag
286
287 ! topo paras
288 ! w/ orographic effects
289 if(nmtvr == 14)then
290 ! calculate sgh30 for TOFD
291 sgh30 = abs(oro - oro_uf)
292 ! w/o orographic effects
293 else
294 sgh30 = 0.
295 endif
296
297 zlwb(:) = 0.
298
299 call gwdps_v0(im, levs, lonr, do_tofd, pdvdt, pdudt, pdtdt, pkdis, &
300 ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, &
301 dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, &
302 dusfcg, dvsfcg, xlat_d, sinlat, coslat, area, cdmbgwd(1:2), &
303 me, master, rdxzb, con_g, con_omega, zmtb, zogw, tau_mtb, tau_ogw, &
304 tau_tofd, dudt_mtb, dudt_ogw, dudt_tms)
305
306 else ! calling old GFS gravity wave drag as is
307
308 do k=1,levs
309 do i=1,im
310 pdvdt(i,k) = 0.0
311 pdudt(i,k) = 0.0
312 pdtdt(i,k) = 0.0
313 pkdis(i,k) = 0.0
314 enddo
315 enddo
316
317 if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then
318 call gwdps_run(im, levs, pdvdt, pdudt, pdtdt, &
319 ugrs, vgrs, tgrs, qgrs(:,:,1), &
320 kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, &
321 hprime, oc, oa4, clx, theta, sigma, gamma, &
322 elvmax, dusfcg, dvsfcg, dudt_ogw, dtauy2d_ms, &
323 dtaux2d_bl, dtauy2d_bl, dusfc_ms, dvsfc_ms, &
324 dusfc_bl, dvsfc_bl, &
325 con_g, con_cp, con_rd, con_rv, lonr, &
326 nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, ldiag_ugwp, &
327 errmsg, errflg)
328 if (errflg/=0) return
329 endif
330
331 tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0
332 if (ldiag_ugwp) then
333 du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0
334 endif
335
336 endif ! do_ugwp
337
338
339 if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then
340 idtend = dtidx(index_of_x_wind,index_of_process_orographic_gwd)
341 if(idtend>=1) then
342 dtend(:,:,idtend) = dtend(:,:,idtend) + pdudt*dtp
343 endif
344 idtend = dtidx(index_of_y_wind,index_of_process_orographic_gwd)
345 if(idtend>=1) then
346 dtend(:,:,idtend) = dtend(:,:,idtend) + pdvdt*dtp
347 endif
348 idtend = dtidx(index_of_temperature,index_of_process_orographic_gwd)
349 if(idtend>=1) then
350 dtend(:,:,idtend) = dtend(:,:,idtend) + pdtdt*dtp
351 endif
352 endif
353
354
355 if (cdmbgwd(3) > 0.0) then
356
357 ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing
358 call slat_geos5_tamp_v0(im, tamp_mpa, xlat_d, tau_ngw)
359
360 if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then
361 if (cdmbgwd(4) > 0.0) then
362 allocate(turb_fac(im))
363 do i=1,im
364 turb_fac(i) = 0.0
365 enddo
366 if (ntke > 0) then
367 allocate(tke(im,levs))
368 allocate(tem(im))
369 tke(:,:) = q_tke(:,:) + dqdt_tke(:,:) * dtp
370 tem(:) = 0.0
371 do k=1,(levs+levs)/3
372 do i=1,im
373 turb_fac(i) = turb_fac(i) + del(i,k) * tke(i,k)
374 tem(i) = tem(i) + del(i,k)
375 enddo
376 enddo
377 do i=1,im
378 turb_fac(i) = turb_fac(i) / tem(i)
379 enddo
380 deallocate(tke)
381 deallocate(tem)
382 endif
383 rfac = 86400000 / dtp
384 do i=1,im
385 tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac))
386 tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1))
387 enddo
388 deallocate(turb_fac)
389 endif
390 do i=1,im
391 tau_ngw(i) = tau_ngw(i) * cdmbgwd(3)
392 enddo
393 endif
394
395 call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs,qgrs(:,:,1), &
396 prsl, prsi, phil, xlat_d, sinlat, coslat, &
397 gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, tau_ngw, &
398 me, master, kdt)
399
400 do k=1,levs
401 do i=1,im
402 gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*pdtdt(i,k)
403 gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*pdudt(i,k)
404 gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*pdvdt(i,k)
405 gw_kdis(i,k) = pngw*gw_kdis(i,k) + pogw*pkdis(i,k)
406 ! accumulation of tendencies for CCPP to replicate EMC-physics updates (!! removed in latest code commit to VLAB)
407 !dudt(i,k) = dudt(i,k) + gw_dudt(i,k)
408 !dvdt(i,k) = dvdt(i,k) + gw_dvdt(i,k)
409 !dtdt(i,k) = dtdt(i,k) + gw_dtdt(i,k)
410 enddo
411 enddo
412
413 else
414
415 do k=1,levs
416 do i=1,im
417 gw_dtdt(i,k) = pdtdt(i,k)
418 gw_dudt(i,k) = pdudt(i,k)
419 gw_dvdt(i,k) = pdvdt(i,k)
420 gw_kdis(i,k) = pkdis(i,k)
421 enddo
422 enddo
423
424 endif
425
426 if (pogw == 0.0) then
427 tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0.
428 dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0.
429 endif
430
431 if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then
432 idtend = dtidx(index_of_x_wind,index_of_process_nonorographic_gwd)
433 if(idtend>=1) then
434 dtend(:,:,idtend) = dtend(:,:,idtend) + (gw_dudt - pdudt)*dtp
435 endif
436 idtend = dtidx(index_of_y_wind,index_of_process_nonorographic_gwd)
437 if(idtend>=1) then
438 dtend(:,:,idtend) = dtend(:,:,idtend) + (gw_dvdt - pdvdt)*dtp
439 endif
440 idtend = dtidx(index_of_temperature,index_of_process_nonorographic_gwd)
441 if(idtend>=1) then
442 dtend(:,:,idtend) = dtend(:,:,idtend) + (gw_dtdt - pdtdt)*dtp
443 endif
444 endif
445
446 end subroutine cires_ugwp_run
447end module cires_ugwp
subroutine gwdps_run(im, km, a, b, c, u1, v1, t1, q1, kpbl, prsi, del, prsl, prslk, phii, phil, deltim, kdt, hprime, oc, oa4, clx4, theta, sigma, gamma, elvmax, dusfc, dvsfc, dtaux2d_ms, dtauy2d_ms, dtaux2d_bl, dtauy2d_bl, dusfc_ms, dvsfc_ms, dusfc_bl, dvsfc_bl, g, cp, rd, rv, imx, nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, ldiag_ugwp, errmsg, errflg)
Definition gwdps.f:203
This module contains the UGWP v0 scheme by Valery Yudin (University of Colorado, CIRES)
This module contains the UGWPv0 driver.
This module contains the CCPP-compliant orographic gravity wave dray scheme. This version of gwdps is...
Definition gwdps.f:7