| blob | 3001a384900a7deba145e6862502a66c1ab2f0a9 |
1 ! Generated by TAPENADE (INRIA, Tropics team)
2 ! Tapenade 3.7 (r4786) - 21 Feb 2013 15:53
3 !
4 ! Differentiation of pbl_driver in reverse (adjoint) mode (with options r8):
5 ! gradient of useful results: v_phy rublten dusfcg z dvsfcg
6 ! pi_phy rqvblten dtauy3d rvblten qv_curr t_phy
7 ! rqcblten rthblten u_phy rqiblten dtaux3d p8w mut
8 ! with respect to varying inputs: v_phy rublten dusfcg z dvsfcg
9 ! pi_phy rqvblten dtauy3d rvblten qv_curr t_phy
10 ! rqcblten rthblten u_phy rqiblten dtaux3d p8w mut
11 ! RW status of diff variables: v_phy:incr rublten:in-out dusfcg:in-out
12 ! z:incr dvsfcg:in-out pi_phy:incr rqvblten:in-out
13 ! dtauy3d:in-out rvblten:in-out qv_curr:incr t_phy:incr
14 ! rqcblten:in-out rthblten:in-out u_phy:incr rqiblten:in-out
15 ! dtaux3d:in-out p8w:incr mut:incr
16 !WRF:MEDIATION_LAYER:PHYSICS
17 !
18 MODULE a_module_pbl_driver
19 CONTAINS
20 !------------------------------------------------------------------
21 ! paj
22 ! OPTIONAL for TEMF scheme
23 ! MYNN
24 !ACF for QKE advection
25 !ACF-end
26 ! Optional
27 ! Optional gravity-wave drag
28 ! Optional moisture tracers
29 ! Optional moisture tracer flags
30 ! variables added for BEP
31 ! variables for GBM PBL
32 ! Wind Turbine Parameterizations
33 ! variables required for camuwpbl scheme
34 ! variables required for camuwpbl scheme (optional)
35 ! for grims shallow convection with ysupbl
36 SUBROUTINE A_PBL_DRIVER(itimestep, dt, u_frame, v_frame, bldt, curr_secs&
37 & , adapt_step_flag, bldtacttime, rublten, rubltenb, rvblten, rvbltenb, &
38 & rthblten, rthbltenb, tsk, xland, znt, ht, ust, pblh, hfx, qfx, grdflx&
39 & , u_phy, u_phyb, v_phy, v_phyb, th_phy, rho, p_phy, pi_phy, pi_phyb, &
40 & p8w, p8wb, t_phy, t_phyb, dz8w, z, zb, exch_h, exch_m, akhs, akms, &
41 & thz0, qz0, uz0, vz0, qsfc, f, lowlyr, u10, v10, t2, psim, psih, fm, &
42 & fhh, gz1oz0, wspd, br, chklowq, bl_pbl_physics, ra_lw_physics, dx, &
43 & stepbl, warm_rain, kpbl, mixht, ct, lh, snow, xice, znu, znw, mut, &
44 & mutb, p_top, ctopo, ctopo2, te_temf, km_temf, kh_temf, shf_temf, &
45 & qf_temf, uw_temf, vw_temf, hd_temf, lcl_temf, hct_temf, wupd_temf, &
46 & mf_temf, thup_temf, qtup_temf, qlup_temf, exch_temf, cf3d_temf, &
47 & cfm_temf, flhc, flqc, qke, qke_adv, bl_mynn_tkeadvect, tsq, qsq, cov, &
48 & rmol, ch, qcg, grav_settling, el_mynn, dqke, qwt, qshear, qbuoy, qdiss&
49 & , tke_budget, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme&
50 & , kms, kme, i_start, i_end, j_start, j_end, kts, kte, num_tiles, hol, &
51 & mol, regime, gwd_opt, dtaux3d, dtaux3db, dtauy3d, dtauy3db, dusfcg, &
52 & dusfcgb, dvsfcg, dvsfcgb, var2d, oc12d, oa1, oa2, oa3, oa4, ol1, ol2, &
53 & ol3, ol4, sina,cosa, qv_curr, qv_currb, qc_curr, qr_curr, qi_curr, qs_curr, &
54 & qg_curr, rqvblten, rqvbltenb, rqcblten, rqcbltenb, rqiblten, rqibltenb&
55 & , rqrblten, rqsblten, rqgblten, f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
56 & frc_urb2d, a_u_bep, a_v_bep, a_t_bep, a_q_bep, b_u_bep, b_v_bep, &
57 & b_t_bep, b_q_bep, sf_bep, vl_bep, sf_sfclay_physics, sf_urban_physics&
58 & , tke_pbl, el_pbl, wu_tur, wv_tur, wt_tur, wq_tur, exch_tke&
59 & , a_e_bep, b_e_bep, dlg_bep, dl_u_bep, mfshconv, massflux_edkf, &
60 & entr_edkf, detr_edkf, thl_up, thv_up, rt_up, rv_up, rc_up, u_up, v_up&
61 & , frac_up, rc_mf, phb, xlat_u, xlong_u, xlat_v, xlong_v, id, z_at_w, &
62 & cldfra_old_mp, cldfra, rthratenlw, tauresx2d, tauresy2d, tpert2d, &
63 & qpert2d, wpert2d, wsedl3d, turbtype3d, smaw3d, fnm, fnp, qnc_curr, &
64 & f_qnc, qni_curr, f_qni, rqniblten, wstar, delta)
66 USE module_state_description, ONLY : &
67 YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME,ACMPBLSCHEME,&
68 QNSEPBLSCHEME,MYNNPBLSCHEME,BOULACSCHEME,&
69 CAMUWPBLSCHEME,BEPSCHEME,BEP_BEMSCHEME,MYJSFCSCHEME, &
70 SURFDRAGSCHEME, TEMFPBLSCHEME, &
71 p_qi,param_first_scalar
73 USE module_model_constants
74 !------------------------------------------------------------------
78 ! *** add new modules of schemes here
80 USE module_bl_gwdo
81 USE module_bl_surface_drag
82 USE a_module_bl_gwdo
83 USE a_module_bl_surface_drag
85 IMPLICIT NONE
87 !======================================================================
88 ! Grid structure in physics part of WRF
89 !----------------------------------------------------------------------
90 ! The horizontal velocities used in the physics are unstaggered
91 ! relative to temperature/moisture variables. All predicted
92 ! variables are carried at half levels except w, which is at full
93 ! levels. Some arrays with names (*8w) are at w (full) levels.
94 !
95 !----------------------------------------------------------------------
96 ! In WRF, kms (smallest number) is the bottom level and kme (largest
97 ! number) is the top level. In your scheme, if 1 is at the top level,
98 ! then you have to reverse the order in the k direction.
99 !
100 ! kme - half level (no data at this level)
101 ! kme ----- full level
102 ! kme-1 - half level
103 ! kme-1 ----- full level
104 ! .
105 ! .
106 ! .
107 ! kms+2 - half level
108 ! kms+2 ----- full level
109 ! kms+1 - half level
110 ! kms+1 ----- full level
111 ! kms - half level
112 ! kms ----- full level
113 !
114 !======================================================================
115 ! Definitions
116 !-----------
117 ! Rho_d dry density (kg/m^3)
118 ! Theta_m moist potential temperature (K)
119 ! Qv water vapor mixing ratio (kg/kg)
120 ! Qc cloud water mixing ratio (kg/kg)
121 ! Qr rain water mixing ratio (kg/kg)
122 ! Qi cloud ice mixing ratio (kg/kg)
123 ! Qs snow mixing ratio (kg/kg)
124 ! QNC cloud Liq number concentration (#/kg) !For CAMUWPBL scheme
125 ! QNI cloud ice number concentration (#/kg) !For CAMUWPBL scheme
126 !-----------------------------------------------------------------
127 !-- RUBLTEN U tendency due to
128 ! PBL parameterization (m/s^2)
129 !-- RVBLTEN V tendency due to
130 ! PBL parameterization (m/s^2)
131 !-- RTHBLTEN Theta tendency due to
132 ! PBL parameterization (K/s)
133 !-- RQVBLTEN Qv tendency due to
134 ! PBL parameterization (kg/kg/s)
135 !-- RQCBLTEN Qc tendency due to
136 ! PBL parameterization (kg/kg/s)
137 !-- RQIBLTEN Qi tendency due to
138 ! PBL parameterization (kg/kg/s)
139 !-- RQNIBLTEN Qni tendency due to
140 ! PBL parameterization (#/kg/s) !For CAMUWPBL scheme
141 !-- id WRF grid id (optional, only needed by turbine drag schemes)
142 !-- itimestep number of time steps
143 !-- GLW downward long wave flux at ground surface (W/m^2)
144 !-- GSW downward short wave flux at ground surface (W/m^2)
145 !-- EMISS surface emissivity (between 0 and 1)
146 !-- TSK surface temperature (K)
147 !-- TMN soil temperature at lower boundary (K)
148 !-- XLAND land mask (1 for land, 2 for water)
149 !-- ZNT roughness length (m)
150 !-- MAVAIL surface moisture availability (between 0 and 1)
151 !-- UST u* in similarity theory (m/s)
152 !-- MOL T* (similarity theory) (K)
153 !-- HOL PBL height over Monin-Obukhov length
154 !-- PBLH PBL height (m)
155 !-- CAPG heat capacity for soil (J/K/m^3)
156 !-- THC thermal inertia (Cal/cm/K/s^0.5)
157 !-- SNOWC flag indicating snow coverage (1 for snow cover)
158 !-- HFX upward heat flux at the surface (W/m^2)
159 !-- QFX upward moisture flux at the surface (kg/m^2/s)
160 !-- REGIME flag indicating PBL regime (stable, unstable, etc.)
161 !-- exch_m exchange coefficient for momentum, m^2/s
162 !-- exch_h exchange coefficient for heat, K m/s
163 !-- exch_tke exchange coeff. for TKE [enhanced], m^2/s (gbmpbl scheme)
164 !-- rthraten tendency from radiation, used in GBM PBL scheme
165 !-- akhs sfc exchange coefficient of heat/moisture from MYJ
166 !-- akms sfc exchange coefficient of momentum from MYJ
167 !-- tke_pbl turbulence kinetic energy from PBL schemes (m^2/s^2)
168 !-- el_pbl length scale from PBL schemes (m)
169 !-- wu_tur turbulent flux of momentum (x) (m^2/s^2)
170 !-- wv_tur turbulent flux of momentum (y) (m^2/s^2)
171 !-- wt_tur turbulent flux of potential temperature (K m/s)
172 !-- wq_tur turbulent flux of water vapor (- m/s)
173 !-- te_temf Total energy from TEMF BL scheme
174 !-- km_temf Exchange coefficient for momentum from TEMF BL scheme
175 !-- kh_temf Exchange coefficient for heat from TEMF BL scheme
176 !-- shf_temf Sensible heat flux from TEMF BL scheme
177 !-- qf_temf Water vapor flux from TEMF BL scheme
178 !-- uw_temf Momentum flux in U direction from TEMF BL scheme
179 !-- vw_temf Momentum flux in V direction from TEMF BL scheme
180 !-- wupd_temf Updraft velocity from TEMF BL scheme
181 !-- mf_temf Mass flux from TEMF BL scheme
182 !-- thup_temf Updraft thetal from TEMF BL scheme
183 !-- qtup_temf Updraft qt from TEMF BL scheme
184 !-- qlup_temf Updraft ql from TEMF BL scheme
185 !-- cf3d_temf 3D cloud fraction from TEMF PBL
186 !-- cfm_temf Column cloud fraction from TEMF PBL
187 !-- exch_temf Surface exchange coefficient (as for moisture) from TEMF surface layer scheme
188 !-- flhc Surface exchange coefficient for heat (for TEMF)
189 !-- flqc Surface exchange coefficient for moisture (for TEMF)
190 !-- thz0 potential temperature at roughness length (K)
191 !-- uz0 u wind component at roughness length (m/s)
192 !-- vz0 v wind component at roughness length (m/s)
193 !-- qsfc specific humidity at lower boundary (kg/kg)
194 !-- th2 diagnostic 2-m theta from surface layer and lsm
195 !-- t2 diagnostic 2-m temperature from surface layer and lsm
196 !-- q2 diagnostic 2-m mixing ratio from surface layer and lsm
197 !-- lowlyr index of lowest model layer above ground
198 !-- rr dry air density (kg/m^3)
199 !-- u_phy u-velocity interpolated to theta points (m/s)
200 !-- v_phy v-velocity interpolated to theta points (m/s)
201 !-- th_phy potential temperature (K)
202 !-- p_phy pressure (Pa)
203 !-- pi_phy exner function (dimensionless)
204 !-- p8w pressure at full levels (Pa)
205 !-- t_phy temperature (K)
206 !-- dz8w dz between full levels (m)
207 !-- z height above sea level (m)
208 !-- DX horizontal space interval (m)
209 !-- DT time step (second)
210 !-- n_moist number of moisture species
211 !-- PSFC pressure at the surface (Pa)
212 !-- TSLB
213 !-- ZS
214 !-- DZS
215 !-- num_soil_layers number of soil layer
216 !-- IFSNOW ifsnow=1 for snow-cover effects
217 !-- z_at_w Height above sea level at layer interfaces (m)
218 !-- cldfra Cloud fraction [unitless]
219 !-- cldfra_old_mp Cloud fraction [unitless]
220 !-- rthratenlw Tendency for LW ( K/s)
221 !-- tauresx2d X-COMP OF RESIDUAL STRESS(m^2/s^2)
222 !-- tauresy2d Y-COMP OF RESIDUAL STRESS(m^2/s^2)
223 !-- tpert2d Convective temperature excess (K)
224 !-- qpert2d Convective humidity excess (kg/kg)
225 !-- wpert2d Turbulent velocity excess (m/s)
226 !-- wsedl3d Sedimentation velocity of stratiform liquid cloud droplet (m/s)
227 !-- turbtype3d Turbulent interface types [ no unit ]
228 !-- smaw3d Normalized Galperin instability function for momentum ( 0<= <=4.964 and 1 at neutral ) [no units]
229 !
230 !-- P_QV species index for water vapor
231 !-- P_QC species index for cloud water
232 !-- P_QR species index for rain water
233 !-- P_QI species index for cloud ice
234 !-- P_QNC species index for cloud liq number concentration !For CAMUWPBL scheme
235 !-- P_QNI species index for cloud ice number concentration !For CAMUWPBL scheme
236 !-- P_QS species index for snow
237 !-- P_QG species index for graupel
238 !-- ids start index for i in domain
239 !-- ide end index for i in domain
240 !-- jds start index for j in domain
241 !-- jde end index for j in domain
242 !-- kds start index for k in domain
243 !-- kde end index for k in domain
244 !-- ims start index for i in memory
245 !-- ime end index for i in memory
246 !-- jms start index for j in memory
247 !-- jme end index for j in memory
248 !-- kms start index for k in memory
249 !-- kme end index for k in memory
250 !-- jts start index for j in tile
251 !-- jte end index for j in tile
252 !-- kts start index for k in tile
253 !-- kte end index for k in tile
254 !
255 !******************************************************************
256 !------------------------------------------------------------------
257 !
258 INTEGER, INTENT(IN) :: bl_pbl_physics, ra_lw_physics, &
259 & sf_sfclay_physics, sf_urban_physics
260 INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
261 & jme, kms, kme, kts, kte, num_tiles
262 INTEGER, DIMENSION(num_tiles), INTENT(IN) :: i_start, i_end, j_start, &
263 & j_end
264 INTEGER, INTENT(IN) :: itimestep, stepbl
265 INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: lowlyr
266 !
267 LOGICAL, INTENT(IN) :: warm_rain
268 !BSINGH:01/31/2013: Added for CAMUWPBL
269 REAL, DIMENSION(kms:kme), OPTIONAL, INTENT(IN) :: znu, znw
270 !
271 REAL, INTENT(IN) :: dt, dx
272 REAL, INTENT(IN), OPTIONAL :: bldt
273 REAL, INTENT(IN), OPTIONAL :: curr_secs
274 LOGICAL, INTENT(IN), OPTIONAL :: adapt_step_flag
275 REAL, INTENT(INOUT), OPTIONAL :: bldtacttime
276 ! Optional for Wind Turbine Parameterizations
277 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN), OPTIONAL :: &
278 & phb
279 REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN), OPTIONAL :: xlat_u, &
280 & xlong_u, xlat_v, xlong_v
281 !
282 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: p_phy, &
283 & pi_phy, p8w, rho, t_phy, u_phy, v_phy, dz8w, z, th_phy
284 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: pi_phyb, p8wb, t_phyb, &
285 & u_phyb, v_phyb, zb
286 !1D variables required for CAMUWPBL scheme
287 REAL, DIMENSION(kms:kme), INTENT(IN), OPTIONAL :: fnm, fnp
288 !3D Variables for camuwpbl scheme
289 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN), OPTIONAL :: &
290 & z_at_w, cldfra_old_mp, cldfra, rthratenlw, wsedl3d
291 !2D Variables required by camuwpbl scheme
292 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT), OPTIONAL :: &
293 & tauresx2d, tauresy2d, tpert2d, qpert2d, wpert2d
294 !3D Variables for camuwpbl scheme - out
295 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT), OPTIONAL :: &
296 & turbtype3d, smaw3d
297 !
298 ! for grims shallow convection with ysupbl
299 !
300 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT), OPTIONAL :: wstar
301 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT), OPTIONAL :: delta
302 !
303 REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: xland, ht, psim, psih&
304 & , fm, fhh, gz1oz0, br, f, chklowq
305 !
306 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: tsk, ust, pblh, &
307 & hfx, qfx, znt, qsfc, akhs, akms, mixht, qz0, thz0, uz0, vz0, ct, &
308 & grdflx, u10, v10, t2, wspd
309 !
310 ! for GBM PBL scheme
311 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rublten, &
312 & rvblten, rthblten, exch_h, exch_m, tke_pbl
313 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rubltenb
314 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: wu_tur, &
315 & wv_tur, wt_tur, wq_tur
316 !
317 !MYNN
318 !,k_m,k_h,k_q &
319 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
320 & tsq, qsq, cov, qke, el_mynn, dqke, qwt, qshear, qbuoy, qdiss
321 INTEGER, OPTIONAL, INTENT(IN) :: tke_budget, grav_settling
322 !ACF-QKE advection start
323 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
324 & qke_adv
325 LOGICAL, OPTIONAL, INTENT(IN) :: bl_mynn_tkeadvect
326 !ACF-QKE advection end
327 ! for GBM PBL scheme
328 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
329 & exch_tke
330 INTEGER, OPTIONAL :: id
331 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN) :: qcg, rmol, &
332 & ch
333 !
334 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: el_pbl
335 REAL, INTENT(IN) :: u_frame, v_frame
336 !
337 INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: kpbl
338 REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: xice, snow, lh
339 ! Bep changes: variable added for urban
340 ! URBAN Landuse fraction
341 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT) :: &
342 & frc_urb2d
343 ! Implicit component for the momemtum in X-direction
344 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
345 & a_u_bep
346 ! Implicit component for the momemtum in Y-direction
347 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
348 & a_v_bep
349 ! Implicit component for the Pot. Temp.
350 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
351 & a_t_bep
352 ! Implicit component for Moisture
353 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
354 & a_q_bep
355 ! Implicit component for the TKE
356 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
357 & a_e_bep
358 ! Explicit component for the momemtum in X-direction
359 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
360 & b_u_bep
361 ! Explicit component for the momemtum in Y-direction
362 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
363 & b_v_bep
364 ! Explicit component for the Pot. Temp.
365 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
366 & b_t_bep
367 ! Explicit component for Moisture
368 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
369 & b_q_bep
370 ! Explicit component for the TKE
371 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
372 & b_e_bep
373 ! Height above ground (L_ground in formula (24) of the BLM paper).
374 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
375 & dlg_bep
376 ! Length scale (lb in formula (22) ofthe BLM paper).
377 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
378 & dl_u_bep
379 ! urban surface and volumes
380 ! surfaces
381 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
382 & sf_bep
383 ! volumes
384 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
385 & vl_bep
386 ! Bep changes end
387 ! New variables for TEMF scheme
388 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
389 & te_temf
390 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(OUT) :: &
391 & km_temf, kh_temf, shf_temf, qf_temf, uw_temf, vw_temf, wupd_temf, &
392 & mf_temf, thup_temf, qtup_temf, qlup_temf, cf3d_temf
393 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT) :: flhc, &
394 & flqc
395 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(OUT) :: hd_temf, &
396 & lcl_temf, hct_temf, cfm_temf
397 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT) :: &
398 & exch_temf
399 !
400 !
401 ! Optional
402 !
403 !
404 ! Flags relating to the optional tendency arrays declared above
405 ! Models that carry the optional tendencies will provdide the
406 ! optional arguments at compile time; these flags all the model
407 ! to determine at run-time whether a particular tracer is in
408 ! use or not.
409 !
410 !used in CAMUWPBL
411 !used in CAMUWPBL
412 LOGICAL, INTENT(IN), OPTIONAL :: f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
413 & f_qnc, f_qni
414 ! optional moisture tracers
415 ! 2 time levels; if only one then use CURR
416 !used in CAMUWPBL
417 !rqniblten used in CAMUWPBL
418 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
419 & qv_curr, qc_curr, qr_curr, qi_curr, qs_curr, qg_curr, qnc_curr, &
420 & qni_curr, rqvblten, rqcblten, rqrblten, rqiblten, rqsblten, rqgblten, &
421 & rqniblten
422 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL :: qv_currb, &
423 & rqvbltenb, rqcbltenb, rqibltenb
424 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT) :: hol, mol&
425 & , regime
426 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN) :: mut
427 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL :: mutb
428 !
429 INTEGER, OPTIONAL, INTENT(IN) :: gwd_opt
430 REAL, OPTIONAL, INTENT(IN) :: p_top
431 !
432 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::&
433 & dtaux3d, dtauy3d
434 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL :: dtaux3db, &
435 & dtauy3db
436 !
437 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT) :: dusfcg, &
438 & dvsfcg
439 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL :: dusfcgb, dvsfcgb
440 !
441 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN) :: var2d, &
442 & oc12d, oa1, oa2, oa3, oa4, ol1, ol2, ol3, ol4, sina, cosa
443 ! paj
444 !mchen
445 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN) :: ctopo, &
446 & ctopo2
447 ! Variables and Diagnostic for QNSE and EDKF JP
448 INTEGER, INTENT(IN) :: mfshconv
449 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(OUT) :: &
450 & massflux_edkf, entr_edkf, detr_edkf, thl_up, thv_up, rt_up, rv_up, &
451 & rc_up, u_up, v_up, frac_up, rc_mf
452 ! LOCAL VAR
453 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: v_phytmp
454 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: v_phytmpb
455 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: u_phytmp
456 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: u_phytmpb
457 REAL, DIMENSION(ims:ime, jms:jme) :: tskold, ustold, zntold, zol, psfc
458 ! make these allocatable depending on the setting of idiff
459 ! Typically, we try to avoide allocating and deallocating local storage like this
460 ! so as not to fragment the stack. But at this point, the idiff = 1 case is disabled
461 ! (set to 0 for all cases) and has to be set manually by users who want to work with
462 ! it. When it becomes a more standard option, this should be redone, either defining
463 ! these as state with package clauses to turn them on and off and passing them in,
464 ! or pass in an integer flag that can be used to dimension the arrays to 1:1:1 as
465 ! local variables. JM 20100316
466 ! Implicit component for the momemtum in X-direction
467 REAL, DIMENSION(:, :, :), ALLOCATABLE :: a_u
468 ! Implicit component for the momemtum in Y-direction
469 REAL, DIMENSION(:, :, :), ALLOCATABLE :: a_v
470 ! Implicit component for the Pot. Temp.
471 REAL, DIMENSION(:, :, :), ALLOCATABLE :: a_t
472 ! Implicit component for the water vapor
473 REAL, DIMENSION(:, :, :), ALLOCATABLE :: a_q
474 ! Explicit component for the momemtum in X-direction
475 REAL, DIMENSION(:, :, :), ALLOCATABLE :: b_u
476 ! Explicit component for the momemtum in Y-direction
477 REAL, DIMENSION(:, :, :), ALLOCATABLE :: b_v
478 ! Explicit component for the Pot. Temp.
479 REAL, DIMENSION(:, :, :), ALLOCATABLE :: b_t
480 ! Explicit component for the water vapor
481 REAL, DIMENSION(:, :, :), ALLOCATABLE :: b_q
482 ! surfaces
483 REAL, DIMENSION(:, :, :), ALLOCATABLE :: sf
484 ! volumes
485 REAL, DIMENSION(:, :, :), ALLOCATABLE :: vl
486 REAL :: dtmin, dtbl
487 !
488 INTEGER :: initflag
489 !
490 INTEGER :: i, j, k, nk, jj, ij, its, ite, jts, jte
491 LOGICAL :: radiation
492 LOGICAL :: flag_bep
493 LOGICAL :: flag_myjsfc
494 !flag_qnc,flag_qnc are used in camuwpbl scheme
495 LOGICAL :: flag_qv, flag_qc, flag_qr, flag_qi, flag_qs, flag_qg, &
496 & flag_qnc, flag_qni
497 CHARACTER(len=256) :: message
498 REAL :: next_bl_time
499 LOGICAL :: run_param, doing_adapt_dt, decided
500 LOGICAL :: do_adapt
501 INTEGER :: iu_bep, iurb, idiff
502 REAL :: seamask, thsk, zzz, unew, vnew, tnew, qnew, umom, vmom
503 REAL :: z0, z1, z2, w1, w2
504 !------------------------------------------------------------------
505 ! For shared physics
506 REAL, DIMENSION(ims:ime, jms:jme) :: dx2dtmp
507 character*256 :: errmsg
508 integer :: errflg
509 !
510 !!!!!!!if using BEP set flag_bep to true
511 INTEGER :: branch
512 INTEGER :: ad_to
513 INTEGER :: ad_to0
514 INTEGER :: ad_from
515 INTEGER :: ad_to1
516 INTEGER :: ad_from0
517 INTEGER :: ad_to2
518 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rvbltenb
519 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthbltenb
520 INTEGER :: min3
521 INTEGER :: min2
522 INTEGER :: min1
523 flag_qi = .false.
524 IF (PRESENT(f_qi)) flag_qi = f_qi
525 IF (bl_pbl_physics .NE. 0) THEN
526 ! RAINBL in mm (Accumulation between PBL calls)
527 !
528 doing_adapt_dt = .false.
529 IF (PRESENT(adapt_step_flag)) THEN
530 IF (adapt_step_flag) THEN
531 doing_adapt_dt = .true.
532 IF (bldtacttime .EQ. 0.) bldtacttime = curr_secs + bldt*60.
533 END IF
534 END IF
535 ! Do we run through this scheme or not?
536 ! Test 1: If this is the initial model time, then yes.
537 ! ITIMESTEP=1
538 ! Test 2: If the user asked for the pbl to be run every time step, then yes.
539 ! BLDT=0 or STEPBL=1
540 ! Test 3: If not adaptive dt, and this is on the requested pbl frequency, then yes.
541 ! MOD(ITIMESTEP,STEPBL)=0
542 ! Test 4: If using adaptive dt and the current time is past the last requested activate pbl time, then yes.
543 ! CURR_SECS >= BLDTACTTIME
544 ! If we do run through the scheme, we set the flag run_param to TRUE and we set the decided flag
545 ! to TRUE. The decided flag says that one of these tests was able to say "yes", run the scheme.
546 ! We only proceed to other tests if the previous tests all have left decided as FALSE.
547 ! If we set run_param to TRUE and this is adaptive time stepping, we set the time to the next
548 ! pbl run.
549 run_param = .false.
550 decided = .false.
551 IF (.NOT.decided .AND. itimestep .EQ. 1) THEN
552 run_param = .true.
553 decided = .true.
554 END IF
555 IF (PRESENT(bldt)) THEN
556 IF (.NOT.decided .AND. (bldt .EQ. 0. .OR. stepbl .EQ. 1)) THEN
557 run_param = .true.
558 decided = .true.
559 END IF
560 ELSE IF (.NOT.decided .AND. stepbl .EQ. 1) THEN
561 run_param = .true.
562 decided = .true.
563 END IF
564 IF (.NOT.decided .AND. (.NOT.doing_adapt_dt) .AND. MOD(itimestep, &
565 & stepbl) .EQ. 0) THEN
566 run_param = .true.
567 decided = .true.
568 END IF
569 IF (.NOT.decided .AND. doing_adapt_dt .AND. curr_secs .GE. &
570 & bldtacttime) run_param = .true.
571 IF (run_param) THEN
572 !----
573 ! CALCULATE CONSTANT
574 ! PBL schemes need PBL time step for updates
575 IF (PRESENT(adapt_step_flag)) THEN
576 IF (adapt_step_flag) THEN
577 do_adapt = .true.
578 ELSE
579 do_adapt = .false.
580 END IF
581 ELSE
582 do_adapt = .false.
583 END IF
584 IF (PRESENT(bldt)) THEN
585 IF (bldt .EQ. 0) THEN
586 dtbl = dt
587 ELSE IF (do_adapt) THEN
588 dtbl = bldt*60
589 ELSE
590 dtbl = dt*stepbl
591 END IF
592 ELSE
593 dtbl = dt*stepbl
594 END IF
595 ! SAVE OLD VALUES
596 !$OMP PARALLEL DO &
597 !$OMP PRIVATE ( ij,i,j,k )
598 DO ij=1,num_tiles
599 ad_from0 = j_start(ij)
600 DO j=ad_from0,j_end(ij)
601 ad_from = i_start(ij)
602 DO i=ad_from,i_end(ij)
603 ! REVERSE ORDER IN THE VERTICAL DIRECTION
604 ! testing change later
605 DO k=kts,kte
606 v_phytmp(i, k, j) = v_phy(i, k, j) + v_frame
607 u_phytmp(i, k, j) = u_phy(i, k, j) + u_frame
608 END DO
609 ! PSFC : in Pa
610 IF (kte + 1 .GT. kde) THEN
611 min1 = kde
612 ELSE
613 min1 = kte + 1
614 END IF
615 DO k=kts,min1
616 rublten(i, k, j) = 0.
617 rvblten(i, k, j) = 0.
618 IF (PRESENT(rqcblten)) THEN
619 CALL PUSHCONTROL1B(0)
620 ELSE
621 CALL PUSHCONTROL1B(1)
622 END IF
623 IF (PRESENT(rqvblten)) THEN
624 CALL PUSHCONTROL1B(0)
625 ELSE
626 CALL PUSHCONTROL1B(1)
627 END IF
628 END DO
629 CALL PUSHINTEGER4(k - 1)
630 IF (flag_qi .AND. PRESENT(rqiblten)) THEN
631 IF (kte + 1 .GT. kde) THEN
632 min2 = kde
633 ELSE
634 min2 = kte + 1
635 END IF
636 k = min2 + 1
637 CALL PUSHINTEGER4(k - 1)
638 CALL PUSHCONTROL1B(0)
639 ELSE
640 CALL PUSHCONTROL1B(1)
641 END IF
642 dx2dtmp(i,j)=dx
643 END DO
644 CALL PUSHINTEGER4(i - 1)
645 CALL PUSHINTEGER4(ad_from)
646 END DO
647 CALL PUSHINTEGER4(j - 1)
648 CALL PUSHINTEGER4(ad_from0)
649 END DO
650 !$OMP END PARALLEL DO
651 !
652 !$OMP PARALLEL DO &
653 !$OMP PRIVATE ( ij, i,j,k, its, ite, jts, jte, z0, z1, z2, w1, w2, message, initflag )
654 DO ij=1,num_tiles
655 CALL PUSHINTEGER4(its)
656 its = i_start(ij)
657 CALL PUSHINTEGER4(ite)
658 ite = i_end(ij)
659 CALL PUSHINTEGER4(jts)
660 jts = j_start(ij)
661 CALL PUSHINTEGER4(jte)
662 jte = j_end(ij)
663 SELECT CASE (bl_pbl_physics)
664 CASE (surfdragscheme)
665 CALL PUSHINTEGER4ARRAY(kpbl, (ime-ims+1)*(jme-jms+1))
666 CALL SURFACE_DRAG(rublten=rublten, rvblten=rvblten, u_phy=&
667 & u_phy, v_phy=v_phy, z=z, xland=xland, ht=ht, &
668 & kpbl2d=kpbl, ids=ids, ide=ide, jds=jds, jde=jde, &
669 & kds=kds, kde=kde, ims=ims, ime=ime, jms=jms, jme=&
670 & jme, kms=kms, kme=kme, its=its, ite=ite, jts=jts, &
671 & jte=jte, kts=kts, kte=kte)
672 CALL PUSHCONTROL1B(0)
673 CASE DEFAULT
674 CALL PUSHCONTROL1B(1)
675 END SELECT
676 IF (PRESENT(dtaux3d)) THEN
677 IF (gwd_opt .EQ. 1) THEN
678 CALL GWDO(u3d=u_phytmp, v3d=v_phytmp, t3d=t_phy, qv3d=&
679 & qv_curr, p3d=p_phy, p3di=p8w, pi3d=pi_phy, z=z, rublten=&
680 & rublten, rvblten=rvblten, dtaux3d=dtaux3d, dtauy3d=&
681 & dtauy3d, dusfcg=dusfcg, dvsfcg=dvsfcg, var2d=var2d, &
682 & oc12d=oc12d, oa2d1=oa1, oa2d2=oa2, oa2d3=oa3, oa2d4=oa4&
683 & , ol2d1=ol1, ol2d2=ol2, ol2d3=ol3, ol2d4=ol4, &
684 & SINA=sina,COSA=cosa, znu=znu, &
685 & errmsg= errmsg, errflg=errflg, &
686 & znw=znw, p_top=p_top, cp=cp, g=g, rd=r_d, rv=&
687 & r_v, ep1=ep_1, pi=3.141592653, dt=dtbl, dx=dx2dtmp, kpbl2d=&
688 & kpbl, itimestep=itimestep, ids=ids, ide=ide, jds=jds, &
689 & jde=jde, kds=kds, kde=kde, ims=ims, ime=ime, jms=jms, &
690 & jme=jme, kms=kms, kme=kme, its=its, ite=ite, jts=jts, &
691 & jte=jte, kts=kts, kte=kte)
692 CALL PUSHCONTROL2B(2)
693 ELSE
694 CALL PUSHCONTROL2B(1)
695 END IF
696 ELSE
697 CALL PUSHCONTROL2B(0)
698 END IF
699 END DO
700 u_phytmpb = 0.0_8
701 v_phytmpb = 0.0_8
702 DO ij=num_tiles,1,-1
703 CALL POPCONTROL2B(branch)
704 IF (branch .NE. 0) THEN
705 IF (branch .NE. 1) THEN
706 ite = i_end(ij)
707 its = i_start(ij)
708 jte = j_end(ij)
709 jts = j_start(ij)
710 CALL GWDO_B(u3d=u_phytmp, u3db=u_phytmpb, v3d=v_phytmp, v3db&
711 & =v_phytmpb, t3d=t_phy, t3db=t_phyb, qv3d=qv_curr, &
712 & qv3db=qv_currb, p3d=p_phy, p3di=p8w, p3dib=p8wb, pi3d=&
713 & pi_phy, pi3db=pi_phyb, z=z, zb=zb, rublten=rublten, &
714 & rubltenb=rubltenb, rvblten=rvblten, rvbltenb=rvbltenb&
715 & , dtaux3d=dtaux3d, dtaux3db=dtaux3db, dtauy3d=dtauy3d&
716 & , dtauy3db=dtauy3db, dusfcg=dusfcg, dusfcgb=dusfcgb, &
717 & dvsfcg=dvsfcg, dvsfcgb=dvsfcgb, var2d=var2d, oc12d=&
718 & oc12d, oa2d1=oa1, oa2d2=oa2, oa2d3=oa3, oa2d4=oa4, &
719 & ol2d1=ol1, ol2d2=ol2, ol2d3=ol3, ol2d4=ol4, znu=znu, &
720 & znw=znw, p_top=p_top, cp=cp, g=g, &
721 & rd=r_d, rv=r_v, ep1=ep_1, pi=3.141592653, dt=dtbl, dx=&
722 & dx, kpbl2d=kpbl, itimestep=itimestep, ids=ids, ide=ide&
723 & , jds=jds, jde=jde, kds=kds, kde=kde, ims=ims, ime=ime&
724 & , jms=jms, jme=jme, kms=kms, kme=kme, its=its, ite=ite&
725 & , jts=jts, jte=jte, kts=kts, kte=kte)
726 END IF
727 END IF
728 CALL POPCONTROL1B(branch)
729 IF (branch .EQ. 0) THEN
730 CALL POPINTEGER4ARRAY(kpbl, (ime-ims+1)*(jme-jms+1))
731 CALL SURFACE_DRAG_B(rublten=rublten, rubltenb=rubltenb, &
732 & rvblten=rvblten, rvbltenb=rvbltenb, u_phy=u_phy&
733 & , u_phyb=u_phyb, v_phy=v_phy, v_phyb=v_phyb, &
734 & xland=xland, z=z, zb=zb, ht=ht, kpbl2d=kpbl, ids&
735 & =ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=&
736 & kde, ims=ims, ime=ime, jms=jms, jme=jme, kms=kms&
737 & , kme=kme, its=its, ite=ite, jts=jts, jte=jte, &
738 & kts=kts, kte=kte)
739 END IF
740 CALL POPINTEGER4(jte)
741 CALL POPINTEGER4(jts)
742 CALL POPINTEGER4(ite)
743 CALL POPINTEGER4(its)
744 END DO
745 DO ij=num_tiles,1,-1
746 CALL POPINTEGER4(ad_from0)
747 CALL POPINTEGER4(ad_to2)
748 DO j=ad_to2,ad_from0,-1
749 CALL POPINTEGER4(ad_from)
750 CALL POPINTEGER4(ad_to1)
751 DO i=ad_to1,ad_from,-1
752 CALL POPCONTROL1B(branch)
753 IF (branch .EQ. 0) THEN
754 CALL POPINTEGER4(ad_to0)
755 DO k=ad_to0,kts,-1
756 rqibltenb(i, k, j) = 0.0_8
757 END DO
758 END IF
759 CALL POPINTEGER4(ad_to)
760 DO k=ad_to,kts,-1
761 CALL POPCONTROL1B(branch)
762 IF (branch .EQ. 0) rqvbltenb(i, k, j) = 0.0_8
763 CALL POPCONTROL1B(branch)
764 IF (branch .EQ. 0) rqcbltenb(i, k, j) = 0.0_8
765 rvbltenb(i, k, j) = 0.0_8
766 rubltenb(i, k, j) = 0.0_8
767 rthbltenb(i, k, j) = 0.0_8
768 END DO
769 DO k=kte,kts,-1
770 u_phyb(i, k, j) = u_phyb(i, k, j) + u_phytmpb(i, k, j)
771 u_phytmpb(i, k, j) = 0.0_8
772 v_phyb(i, k, j) = v_phyb(i, k, j) + v_phytmpb(i, k, j)
773 v_phytmpb(i, k, j) = 0.0_8
774 END DO
775 END DO
776 END DO
777 END DO
778 END IF
779 END IF
780 END SUBROUTINE A_PBL_DRIVER
782 END MODULE a_module_pbl_driver