! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 3.7 (r4786) - 21 Feb 2013 15:53 ! ! Differentiation of pbl_driver in reverse (adjoint) mode (with options r8): ! gradient of useful results: v_phy rublten dusfcg z dvsfcg ! pi_phy rqvblten dtauy3d rvblten qv_curr t_phy ! rqcblten rthblten u_phy rqiblten dtaux3d p8w mut ! with respect to varying inputs: v_phy rublten dusfcg z dvsfcg ! pi_phy rqvblten dtauy3d rvblten qv_curr t_phy ! rqcblten rthblten u_phy rqiblten dtaux3d p8w mut ! RW status of diff variables: v_phy:incr rublten:in-out dusfcg:in-out ! z:incr dvsfcg:in-out pi_phy:incr rqvblten:in-out ! dtauy3d:in-out rvblten:in-out qv_curr:incr t_phy:incr ! rqcblten:in-out rthblten:in-out u_phy:incr rqiblten:in-out ! dtaux3d:in-out p8w:incr mut:incr !WRF:MEDIATION_LAYER:PHYSICS ! MODULE a_module_pbl_driver CONTAINS !------------------------------------------------------------------ ! paj ! OPTIONAL for TEMF scheme ! MYNN !ACF for QKE advection !ACF-end ! Optional ! Optional gravity-wave drag ! Optional moisture tracers ! Optional moisture tracer flags ! variables added for BEP ! variables for GBM PBL ! Wind Turbine Parameterizations ! variables required for camuwpbl scheme ! variables required for camuwpbl scheme (optional) ! for grims shallow convection with ysupbl SUBROUTINE A_PBL_DRIVER(itimestep, dt, u_frame, v_frame, bldt, curr_secs& & , adapt_step_flag, bldtacttime, rublten, rubltenb, rvblten, rvbltenb, & & rthblten, rthbltenb, tsk, xland, znt, ht, ust, pblh, hfx, qfx, grdflx& & , u_phy, u_phyb, v_phy, v_phyb, th_phy, rho, p_phy, pi_phy, pi_phyb, & & p8w, p8wb, t_phy, t_phyb, dz8w, z, zb, exch_h, exch_m, akhs, akms, & & thz0, qz0, uz0, vz0, qsfc, f, lowlyr, u10, v10, t2, psim, psih, fm, & & fhh, gz1oz0, wspd, br, chklowq, bl_pbl_physics, ra_lw_physics, dx, & & stepbl, warm_rain, kpbl, mixht, ct, lh, snow, xice, znu, znw, mut, & & mutb, p_top, ctopo, ctopo2, te_temf, km_temf, kh_temf, shf_temf, & & qf_temf, uw_temf, vw_temf, hd_temf, lcl_temf, hct_temf, wupd_temf, & & mf_temf, thup_temf, qtup_temf, qlup_temf, exch_temf, cf3d_temf, & & cfm_temf, flhc, flqc, qke, qke_adv, bl_mynn_tkeadvect, tsq, qsq, cov, & & rmol, ch, qcg, grav_settling, el_mynn, dqke, qwt, qshear, qbuoy, qdiss& & , tke_budget, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme& & , kms, kme, i_start, i_end, j_start, j_end, kts, kte, num_tiles, hol, & & mol, regime, gwd_opt, dtaux3d, dtaux3db, dtauy3d, dtauy3db, dusfcg, & & dusfcgb, dvsfcg, dvsfcgb, var2d, oc12d, oa1, oa2, oa3, oa4, ol1, ol2, & & ol3, ol4, sina,cosa, qv_curr, qv_currb, qc_curr, qr_curr, qi_curr, qs_curr, & & qg_curr, rqvblten, rqvbltenb, rqcblten, rqcbltenb, rqiblten, rqibltenb& & , rqrblten, rqsblten, rqgblten, f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, & & frc_urb2d, a_u_bep, a_v_bep, a_t_bep, a_q_bep, b_u_bep, b_v_bep, & & b_t_bep, b_q_bep, sf_bep, vl_bep, sf_sfclay_physics, sf_urban_physics& & , tke_pbl, el_pbl, wu_tur, wv_tur, wt_tur, wq_tur, exch_tke& & , a_e_bep, b_e_bep, dlg_bep, dl_u_bep, mfshconv, massflux_edkf, & & entr_edkf, detr_edkf, thl_up, thv_up, rt_up, rv_up, rc_up, u_up, v_up& & , frac_up, rc_mf, phb, xlat_u, xlong_u, xlat_v, xlong_v, id, z_at_w, & & cldfra_old_mp, cldfra, rthratenlw, tauresx2d, tauresy2d, tpert2d, & & qpert2d, wpert2d, wsedl3d, turbtype3d, smaw3d, fnm, fnp, qnc_curr, & & f_qnc, qni_curr, f_qni, rqniblten, wstar, delta) USE module_state_description, ONLY : & YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME,ACMPBLSCHEME,& QNSEPBLSCHEME,MYNNPBLSCHEME,BOULACSCHEME,& CAMUWPBLSCHEME,BEPSCHEME,BEP_BEMSCHEME,MYJSFCSCHEME, & SURFDRAGSCHEME, TEMFPBLSCHEME, & p_qi,param_first_scalar USE module_model_constants !------------------------------------------------------------------ ! *** add new modules of schemes here USE module_bl_gwdo USE module_bl_surface_drag USE a_module_bl_gwdo USE a_module_bl_surface_drag IMPLICIT NONE !====================================================================== ! Grid structure in physics part of WRF !---------------------------------------------------------------------- ! The horizontal velocities used in the physics are unstaggered ! relative to temperature/moisture variables. All predicted ! variables are carried at half levels except w, which is at full ! levels. Some arrays with names (*8w) are at w (full) levels. ! !---------------------------------------------------------------------- ! In WRF, kms (smallest number) is the bottom level and kme (largest ! number) is the top level. In your scheme, if 1 is at the top level, ! then you have to reverse the order in the k direction. ! ! kme - half level (no data at this level) ! kme ----- full level ! kme-1 - half level ! kme-1 ----- full level ! . ! . ! . ! kms+2 - half level ! kms+2 ----- full level ! kms+1 - half level ! kms+1 ----- full level ! kms - half level ! kms ----- full level ! !====================================================================== ! Definitions !----------- ! Rho_d dry density (kg/m^3) ! Theta_m moist potential temperature (K) ! Qv water vapor mixing ratio (kg/kg) ! Qc cloud water mixing ratio (kg/kg) ! Qr rain water mixing ratio (kg/kg) ! Qi cloud ice mixing ratio (kg/kg) ! Qs snow mixing ratio (kg/kg) ! QNC cloud Liq number concentration (#/kg) !For CAMUWPBL scheme ! QNI cloud ice number concentration (#/kg) !For CAMUWPBL scheme !----------------------------------------------------------------- !-- RUBLTEN U tendency due to ! PBL parameterization (m/s^2) !-- RVBLTEN V tendency due to ! PBL parameterization (m/s^2) !-- RTHBLTEN Theta tendency due to ! PBL parameterization (K/s) !-- RQVBLTEN Qv tendency due to ! PBL parameterization (kg/kg/s) !-- RQCBLTEN Qc tendency due to ! PBL parameterization (kg/kg/s) !-- RQIBLTEN Qi tendency due to ! PBL parameterization (kg/kg/s) !-- RQNIBLTEN Qni tendency due to ! PBL parameterization (#/kg/s) !For CAMUWPBL scheme !-- id WRF grid id (optional, only needed by turbine drag schemes) !-- itimestep number of time steps !-- GLW downward long wave flux at ground surface (W/m^2) !-- GSW downward short wave flux at ground surface (W/m^2) !-- EMISS surface emissivity (between 0 and 1) !-- TSK surface temperature (K) !-- TMN soil temperature at lower boundary (K) !-- XLAND land mask (1 for land, 2 for water) !-- ZNT roughness length (m) !-- MAVAIL surface moisture availability (between 0 and 1) !-- UST u* in similarity theory (m/s) !-- MOL T* (similarity theory) (K) !-- HOL PBL height over Monin-Obukhov length !-- PBLH PBL height (m) !-- CAPG heat capacity for soil (J/K/m^3) !-- THC thermal inertia (Cal/cm/K/s^0.5) !-- SNOWC flag indicating snow coverage (1 for snow cover) !-- HFX upward heat flux at the surface (W/m^2) !-- QFX upward moisture flux at the surface (kg/m^2/s) !-- REGIME flag indicating PBL regime (stable, unstable, etc.) !-- exch_m exchange coefficient for momentum, m^2/s !-- exch_h exchange coefficient for heat, K m/s !-- exch_tke exchange coeff. for TKE [enhanced], m^2/s (gbmpbl scheme) !-- rthraten tendency from radiation, used in GBM PBL scheme !-- akhs sfc exchange coefficient of heat/moisture from MYJ !-- akms sfc exchange coefficient of momentum from MYJ !-- tke_pbl turbulence kinetic energy from PBL schemes (m^2/s^2) !-- el_pbl length scale from PBL schemes (m) !-- wu_tur turbulent flux of momentum (x) (m^2/s^2) !-- wv_tur turbulent flux of momentum (y) (m^2/s^2) !-- wt_tur turbulent flux of potential temperature (K m/s) !-- wq_tur turbulent flux of water vapor (- m/s) !-- te_temf Total energy from TEMF BL scheme !-- km_temf Exchange coefficient for momentum from TEMF BL scheme !-- kh_temf Exchange coefficient for heat from TEMF BL scheme !-- shf_temf Sensible heat flux from TEMF BL scheme !-- qf_temf Water vapor flux from TEMF BL scheme !-- uw_temf Momentum flux in U direction from TEMF BL scheme !-- vw_temf Momentum flux in V direction from TEMF BL scheme !-- wupd_temf Updraft velocity from TEMF BL scheme !-- mf_temf Mass flux from TEMF BL scheme !-- thup_temf Updraft thetal from TEMF BL scheme !-- qtup_temf Updraft qt from TEMF BL scheme !-- qlup_temf Updraft ql from TEMF BL scheme !-- cf3d_temf 3D cloud fraction from TEMF PBL !-- cfm_temf Column cloud fraction from TEMF PBL !-- exch_temf Surface exchange coefficient (as for moisture) from TEMF surface layer scheme !-- flhc Surface exchange coefficient for heat (for TEMF) !-- flqc Surface exchange coefficient for moisture (for TEMF) !-- thz0 potential temperature at roughness length (K) !-- uz0 u wind component at roughness length (m/s) !-- vz0 v wind component at roughness length (m/s) !-- qsfc specific humidity at lower boundary (kg/kg) !-- th2 diagnostic 2-m theta from surface layer and lsm !-- t2 diagnostic 2-m temperature from surface layer and lsm !-- q2 diagnostic 2-m mixing ratio from surface layer and lsm !-- lowlyr index of lowest model layer above ground !-- rr dry air density (kg/m^3) !-- u_phy u-velocity interpolated to theta points (m/s) !-- v_phy v-velocity interpolated to theta points (m/s) !-- th_phy potential temperature (K) !-- p_phy pressure (Pa) !-- pi_phy exner function (dimensionless) !-- p8w pressure at full levels (Pa) !-- t_phy temperature (K) !-- dz8w dz between full levels (m) !-- z height above sea level (m) !-- DX horizontal space interval (m) !-- DT time step (second) !-- n_moist number of moisture species !-- PSFC pressure at the surface (Pa) !-- TSLB !-- ZS !-- DZS !-- num_soil_layers number of soil layer !-- IFSNOW ifsnow=1 for snow-cover effects !-- z_at_w Height above sea level at layer interfaces (m) !-- cldfra Cloud fraction [unitless] !-- cldfra_old_mp Cloud fraction [unitless] !-- rthratenlw Tendency for LW ( K/s) !-- tauresx2d X-COMP OF RESIDUAL STRESS(m^2/s^2) !-- tauresy2d Y-COMP OF RESIDUAL STRESS(m^2/s^2) !-- tpert2d Convective temperature excess (K) !-- qpert2d Convective humidity excess (kg/kg) !-- wpert2d Turbulent velocity excess (m/s) !-- wsedl3d Sedimentation velocity of stratiform liquid cloud droplet (m/s) !-- turbtype3d Turbulent interface types [ no unit ] !-- smaw3d Normalized Galperin instability function for momentum ( 0<= <=4.964 and 1 at neutral ) [no units] ! !-- P_QV species index for water vapor !-- P_QC species index for cloud water !-- P_QR species index for rain water !-- P_QI species index for cloud ice !-- P_QNC species index for cloud liq number concentration !For CAMUWPBL scheme !-- P_QNI species index for cloud ice number concentration !For CAMUWPBL scheme !-- P_QS species index for snow !-- P_QG species index for graupel !-- ids start index for i in domain !-- ide end index for i in domain !-- jds start index for j in domain !-- jde end index for j in domain !-- kds start index for k in domain !-- kde end index for k in domain !-- ims start index for i in memory !-- ime end index for i in memory !-- jms start index for j in memory !-- jme end index for j in memory !-- kms start index for k in memory !-- kme end index for k in memory !-- jts start index for j in tile !-- jte end index for j in tile !-- kts start index for k in tile !-- kte end index for k in tile ! !****************************************************************** !------------------------------------------------------------------ ! INTEGER, INTENT(IN) :: bl_pbl_physics, ra_lw_physics, & & sf_sfclay_physics, sf_urban_physics INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, kts, kte, num_tiles INTEGER, DIMENSION(num_tiles), INTENT(IN) :: i_start, i_end, j_start, & & j_end INTEGER, INTENT(IN) :: itimestep, stepbl INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: lowlyr ! LOGICAL, INTENT(IN) :: warm_rain !BSINGH:01/31/2013: Added for CAMUWPBL REAL, DIMENSION(kms:kme), OPTIONAL, INTENT(IN) :: znu, znw ! REAL, INTENT(IN) :: dt, dx REAL, INTENT(IN), OPTIONAL :: bldt REAL, INTENT(IN), OPTIONAL :: curr_secs LOGICAL, INTENT(IN), OPTIONAL :: adapt_step_flag REAL, INTENT(INOUT), OPTIONAL :: bldtacttime ! Optional for Wind Turbine Parameterizations REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN), OPTIONAL :: & & phb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN), OPTIONAL :: xlat_u, & & xlong_u, xlat_v, xlong_v ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: p_phy, & & pi_phy, p8w, rho, t_phy, u_phy, v_phy, dz8w, z, th_phy REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: pi_phyb, p8wb, t_phyb, & & u_phyb, v_phyb, zb !1D variables required for CAMUWPBL scheme REAL, DIMENSION(kms:kme), INTENT(IN), OPTIONAL :: fnm, fnp !3D Variables for camuwpbl scheme REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN), OPTIONAL :: & & z_at_w, cldfra_old_mp, cldfra, rthratenlw, wsedl3d !2D Variables required by camuwpbl scheme REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT), OPTIONAL :: & & tauresx2d, tauresy2d, tpert2d, qpert2d, wpert2d !3D Variables for camuwpbl scheme - out REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT), OPTIONAL :: & & turbtype3d, smaw3d ! ! for grims shallow convection with ysupbl ! REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT), OPTIONAL :: wstar REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT), OPTIONAL :: delta ! REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: xland, ht, psim, psih& & , fm, fhh, gz1oz0, br, f, chklowq ! REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: tsk, ust, pblh, & & hfx, qfx, znt, qsfc, akhs, akms, mixht, qz0, thz0, uz0, vz0, ct, & & grdflx, u10, v10, t2, wspd ! ! for GBM PBL scheme REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rublten, & & rvblten, rthblten, exch_h, exch_m, tke_pbl REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rubltenb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: wu_tur, & & wv_tur, wt_tur, wq_tur ! !MYNN !,k_m,k_h,k_q & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & tsq, qsq, cov, qke, el_mynn, dqke, qwt, qshear, qbuoy, qdiss INTEGER, OPTIONAL, INTENT(IN) :: tke_budget, grav_settling !ACF-QKE advection start REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & qke_adv LOGICAL, OPTIONAL, INTENT(IN) :: bl_mynn_tkeadvect !ACF-QKE advection end ! for GBM PBL scheme REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & exch_tke INTEGER, OPTIONAL :: id REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN) :: qcg, rmol, & & ch ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: el_pbl REAL, INTENT(IN) :: u_frame, v_frame ! INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: kpbl REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: xice, snow, lh ! Bep changes: variable added for urban ! URBAN Landuse fraction REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT) :: & & frc_urb2d ! Implicit component for the momemtum in X-direction REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & a_u_bep ! Implicit component for the momemtum in Y-direction REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & a_v_bep ! Implicit component for the Pot. Temp. REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & a_t_bep ! Implicit component for Moisture REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & a_q_bep ! Implicit component for the TKE REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & a_e_bep ! Explicit component for the momemtum in X-direction REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & b_u_bep ! Explicit component for the momemtum in Y-direction REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & b_v_bep ! Explicit component for the Pot. Temp. REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & b_t_bep ! Explicit component for Moisture REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & b_q_bep ! Explicit component for the TKE REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & b_e_bep ! Height above ground (L_ground in formula (24) of the BLM paper). REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & dlg_bep ! Length scale (lb in formula (22) ofthe BLM paper). REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & dl_u_bep ! urban surface and volumes ! surfaces REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & sf_bep ! volumes REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & vl_bep ! Bep changes end ! New variables for TEMF scheme REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & te_temf REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(OUT) :: & & km_temf, kh_temf, shf_temf, qf_temf, uw_temf, vw_temf, wupd_temf, & & mf_temf, thup_temf, qtup_temf, qlup_temf, cf3d_temf REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT) :: flhc, & & flqc REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(OUT) :: hd_temf, & & lcl_temf, hct_temf, cfm_temf REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT) :: & & exch_temf ! ! ! Optional ! ! ! Flags relating to the optional tendency arrays declared above ! Models that carry the optional tendencies will provdide the ! optional arguments at compile time; these flags all the model ! to determine at run-time whether a particular tracer is in ! use or not. ! !used in CAMUWPBL !used in CAMUWPBL LOGICAL, INTENT(IN), OPTIONAL :: f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, & & f_qnc, f_qni ! optional moisture tracers ! 2 time levels; if only one then use CURR !used in CAMUWPBL !rqniblten used in CAMUWPBL REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & qv_curr, qc_curr, qr_curr, qi_curr, qs_curr, qg_curr, qnc_curr, & & qni_curr, rqvblten, rqcblten, rqrblten, rqiblten, rqsblten, rqgblten, & & rqniblten REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL :: qv_currb, & & rqvbltenb, rqcbltenb, rqibltenb REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT) :: hol, mol& & , regime REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN) :: mut REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL :: mutb ! INTEGER, OPTIONAL, INTENT(IN) :: gwd_opt REAL, OPTIONAL, INTENT(IN) :: p_top ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT) ::& & dtaux3d, dtauy3d REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL :: dtaux3db, & & dtauy3db ! REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT) :: dusfcg, & & dvsfcg REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL :: dusfcgb, dvsfcgb ! REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN) :: var2d, & & oc12d, oa1, oa2, oa3, oa4, ol1, ol2, ol3, ol4, sina, cosa ! paj !mchen REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN) :: ctopo, & & ctopo2 ! Variables and Diagnostic for QNSE and EDKF JP INTEGER, INTENT(IN) :: mfshconv REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(OUT) :: & & massflux_edkf, entr_edkf, detr_edkf, thl_up, thv_up, rt_up, rv_up, & & rc_up, u_up, v_up, frac_up, rc_mf ! LOCAL VAR REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: v_phytmp REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: v_phytmpb REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: u_phytmp REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: u_phytmpb REAL, DIMENSION(ims:ime, jms:jme) :: tskold, ustold, zntold, zol, psfc ! make these allocatable depending on the setting of idiff ! Typically, we try to avoide allocating and deallocating local storage like this ! so as not to fragment the stack. But at this point, the idiff = 1 case is disabled ! (set to 0 for all cases) and has to be set manually by users who want to work with ! it. When it becomes a more standard option, this should be redone, either defining ! these as state with package clauses to turn them on and off and passing them in, ! or pass in an integer flag that can be used to dimension the arrays to 1:1:1 as ! local variables. JM 20100316 ! Implicit component for the momemtum in X-direction REAL, DIMENSION(:, :, :), ALLOCATABLE :: a_u ! Implicit component for the momemtum in Y-direction REAL, DIMENSION(:, :, :), ALLOCATABLE :: a_v ! Implicit component for the Pot. Temp. REAL, DIMENSION(:, :, :), ALLOCATABLE :: a_t ! Implicit component for the water vapor REAL, DIMENSION(:, :, :), ALLOCATABLE :: a_q ! Explicit component for the momemtum in X-direction REAL, DIMENSION(:, :, :), ALLOCATABLE :: b_u ! Explicit component for the momemtum in Y-direction REAL, DIMENSION(:, :, :), ALLOCATABLE :: b_v ! Explicit component for the Pot. Temp. REAL, DIMENSION(:, :, :), ALLOCATABLE :: b_t ! Explicit component for the water vapor REAL, DIMENSION(:, :, :), ALLOCATABLE :: b_q ! surfaces REAL, DIMENSION(:, :, :), ALLOCATABLE :: sf ! volumes REAL, DIMENSION(:, :, :), ALLOCATABLE :: vl REAL :: dtmin, dtbl ! INTEGER :: initflag ! INTEGER :: i, j, k, nk, jj, ij, its, ite, jts, jte LOGICAL :: radiation LOGICAL :: flag_bep LOGICAL :: flag_myjsfc !flag_qnc,flag_qnc are used in camuwpbl scheme LOGICAL :: flag_qv, flag_qc, flag_qr, flag_qi, flag_qs, flag_qg, & & flag_qnc, flag_qni CHARACTER(len=256) :: message REAL :: next_bl_time LOGICAL :: run_param, doing_adapt_dt, decided LOGICAL :: do_adapt INTEGER :: iu_bep, iurb, idiff REAL :: seamask, thsk, zzz, unew, vnew, tnew, qnew, umom, vmom REAL :: z0, z1, z2, w1, w2 !------------------------------------------------------------------ ! For shared physics REAL, DIMENSION(ims:ime, jms:jme) :: dx2dtmp character*256 :: errmsg integer :: errflg ! !!!!!!!if using BEP set flag_bep to true INTEGER :: branch INTEGER :: ad_to INTEGER :: ad_to0 INTEGER :: ad_from INTEGER :: ad_to1 INTEGER :: ad_from0 INTEGER :: ad_to2 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rvbltenb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthbltenb INTEGER :: min3 INTEGER :: min2 INTEGER :: min1 flag_qi = .false. IF (PRESENT(f_qi)) flag_qi = f_qi IF (bl_pbl_physics .NE. 0) THEN ! RAINBL in mm (Accumulation between PBL calls) ! doing_adapt_dt = .false. IF (PRESENT(adapt_step_flag)) THEN IF (adapt_step_flag) THEN doing_adapt_dt = .true. IF (bldtacttime .EQ. 0.) bldtacttime = curr_secs + bldt*60. END IF END IF ! Do we run through this scheme or not? ! Test 1: If this is the initial model time, then yes. ! ITIMESTEP=1 ! Test 2: If the user asked for the pbl to be run every time step, then yes. ! BLDT=0 or STEPBL=1 ! Test 3: If not adaptive dt, and this is on the requested pbl frequency, then yes. ! MOD(ITIMESTEP,STEPBL)=0 ! Test 4: If using adaptive dt and the current time is past the last requested activate pbl time, then yes. ! CURR_SECS >= BLDTACTTIME ! If we do run through the scheme, we set the flag run_param to TRUE and we set the decided flag ! to TRUE. The decided flag says that one of these tests was able to say "yes", run the scheme. ! We only proceed to other tests if the previous tests all have left decided as FALSE. ! If we set run_param to TRUE and this is adaptive time stepping, we set the time to the next ! pbl run. run_param = .false. decided = .false. IF (.NOT.decided .AND. itimestep .EQ. 1) THEN run_param = .true. decided = .true. END IF IF (PRESENT(bldt)) THEN IF (.NOT.decided .AND. (bldt .EQ. 0. .OR. stepbl .EQ. 1)) THEN run_param = .true. decided = .true. END IF ELSE IF (.NOT.decided .AND. stepbl .EQ. 1) THEN run_param = .true. decided = .true. END IF IF (.NOT.decided .AND. (.NOT.doing_adapt_dt) .AND. MOD(itimestep, & & stepbl) .EQ. 0) THEN run_param = .true. decided = .true. END IF IF (.NOT.decided .AND. doing_adapt_dt .AND. curr_secs .GE. & & bldtacttime) run_param = .true. IF (run_param) THEN !---- ! CALCULATE CONSTANT ! PBL schemes need PBL time step for updates IF (PRESENT(adapt_step_flag)) THEN IF (adapt_step_flag) THEN do_adapt = .true. ELSE do_adapt = .false. END IF ELSE do_adapt = .false. END IF IF (PRESENT(bldt)) THEN IF (bldt .EQ. 0) THEN dtbl = dt ELSE IF (do_adapt) THEN dtbl = bldt*60 ELSE dtbl = dt*stepbl END IF ELSE dtbl = dt*stepbl END IF ! SAVE OLD VALUES !$OMP PARALLEL DO & !$OMP PRIVATE ( ij,i,j,k ) DO ij=1,num_tiles ad_from0 = j_start(ij) DO j=ad_from0,j_end(ij) ad_from = i_start(ij) DO i=ad_from,i_end(ij) ! REVERSE ORDER IN THE VERTICAL DIRECTION ! testing change later DO k=kts,kte v_phytmp(i, k, j) = v_phy(i, k, j) + v_frame u_phytmp(i, k, j) = u_phy(i, k, j) + u_frame END DO ! PSFC : in Pa IF (kte + 1 .GT. kde) THEN min1 = kde ELSE min1 = kte + 1 END IF DO k=kts,min1 rublten(i, k, j) = 0. rvblten(i, k, j) = 0. IF (PRESENT(rqcblten)) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (PRESENT(rqvblten)) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(k - 1) IF (flag_qi .AND. PRESENT(rqiblten)) THEN IF (kte + 1 .GT. kde) THEN min2 = kde ELSE min2 = kte + 1 END IF k = min2 + 1 CALL PUSHINTEGER4(k - 1) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF dx2dtmp(i,j)=dx END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from0) END DO !$OMP END PARALLEL DO ! !$OMP PARALLEL DO & !$OMP PRIVATE ( ij, i,j,k, its, ite, jts, jte, z0, z1, z2, w1, w2, message, initflag ) DO ij=1,num_tiles CALL PUSHINTEGER4(its) its = i_start(ij) CALL PUSHINTEGER4(ite) ite = i_end(ij) CALL PUSHINTEGER4(jts) jts = j_start(ij) CALL PUSHINTEGER4(jte) jte = j_end(ij) SELECT CASE (bl_pbl_physics) CASE (surfdragscheme) CALL PUSHINTEGER4ARRAY(kpbl, (ime-ims+1)*(jme-jms+1)) CALL SURFACE_DRAG(rublten=rublten, rvblten=rvblten, u_phy=& & u_phy, v_phy=v_phy, z=z, xland=xland, ht=ht, & & kpbl2d=kpbl, ids=ids, ide=ide, jds=jds, jde=jde, & & kds=kds, kde=kde, ims=ims, ime=ime, jms=jms, jme=& & jme, kms=kms, kme=kme, its=its, ite=ite, jts=jts, & & jte=jte, kts=kts, kte=kte) CALL PUSHCONTROL1B(0) CASE DEFAULT CALL PUSHCONTROL1B(1) END SELECT IF (PRESENT(dtaux3d)) THEN IF (gwd_opt .EQ. 1) THEN CALL GWDO(u3d=u_phytmp, v3d=v_phytmp, t3d=t_phy, qv3d=& & qv_curr, p3d=p_phy, p3di=p8w, pi3d=pi_phy, z=z, rublten=& & rublten, rvblten=rvblten, dtaux3d=dtaux3d, dtauy3d=& & dtauy3d, dusfcg=dusfcg, dvsfcg=dvsfcg, var2d=var2d, & & oc12d=oc12d, oa2d1=oa1, oa2d2=oa2, oa2d3=oa3, oa2d4=oa4& & , ol2d1=ol1, ol2d2=ol2, ol2d3=ol3, ol2d4=ol4, & & SINA=sina,COSA=cosa, znu=znu, & & errmsg= errmsg, errflg=errflg, & & znw=znw, p_top=p_top, cp=cp, g=g, rd=r_d, rv=& & r_v, ep1=ep_1, pi=3.141592653, dt=dtbl, dx=dx2dtmp, kpbl2d=& & kpbl, itimestep=itimestep, ids=ids, ide=ide, jds=jds, & & jde=jde, kds=kds, kde=kde, ims=ims, ime=ime, jms=jms, & & jme=jme, kms=kms, kme=kme, its=its, ite=ite, jts=jts, & & jte=jte, kts=kts, kte=kte) CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(1) END IF ELSE CALL PUSHCONTROL2B(0) END IF END DO u_phytmpb = 0.0_8 v_phytmpb = 0.0_8 DO ij=num_tiles,1,-1 CALL POPCONTROL2B(branch) IF (branch .NE. 0) THEN IF (branch .NE. 1) THEN ite = i_end(ij) its = i_start(ij) jte = j_end(ij) jts = j_start(ij) CALL GWDO_B(u3d=u_phytmp, u3db=u_phytmpb, v3d=v_phytmp, v3db& & =v_phytmpb, t3d=t_phy, t3db=t_phyb, qv3d=qv_curr, & & qv3db=qv_currb, p3d=p_phy, p3di=p8w, p3dib=p8wb, pi3d=& & pi_phy, pi3db=pi_phyb, z=z, zb=zb, rublten=rublten, & & rubltenb=rubltenb, rvblten=rvblten, rvbltenb=rvbltenb& & , dtaux3d=dtaux3d, dtaux3db=dtaux3db, dtauy3d=dtauy3d& & , dtauy3db=dtauy3db, dusfcg=dusfcg, dusfcgb=dusfcgb, & & dvsfcg=dvsfcg, dvsfcgb=dvsfcgb, var2d=var2d, oc12d=& & oc12d, oa2d1=oa1, oa2d2=oa2, oa2d3=oa3, oa2d4=oa4, & & ol2d1=ol1, ol2d2=ol2, ol2d3=ol3, ol2d4=ol4, znu=znu, & & znw=znw, p_top=p_top, cp=cp, g=g, & & rd=r_d, rv=r_v, ep1=ep_1, pi=3.141592653, dt=dtbl, dx=& & dx, kpbl2d=kpbl, itimestep=itimestep, ids=ids, ide=ide& & , jds=jds, jde=jde, kds=kds, kde=kde, ims=ims, ime=ime& & , jms=jms, jme=jme, kms=kms, kme=kme, its=its, ite=ite& & , jts=jts, jte=jte, kts=kts, kte=kte) END IF END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4ARRAY(kpbl, (ime-ims+1)*(jme-jms+1)) CALL SURFACE_DRAG_B(rublten=rublten, rubltenb=rubltenb, & & rvblten=rvblten, rvbltenb=rvbltenb, u_phy=u_phy& & , u_phyb=u_phyb, v_phy=v_phy, v_phyb=v_phyb, & & xland=xland, z=z, zb=zb, ht=ht, kpbl2d=kpbl, ids& & =ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=& & kde, ims=ims, ime=ime, jms=jms, jme=jme, kms=kms& & , kme=kme, its=its, ite=ite, jts=jts, jte=jte, & & kts=kts, kte=kte) END IF CALL POPINTEGER4(jte) CALL POPINTEGER4(jts) CALL POPINTEGER4(ite) CALL POPINTEGER4(its) END DO DO ij=num_tiles,1,-1 CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to2) DO j=ad_to2,ad_from0,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from,-1 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_to0) DO k=ad_to0,kts,-1 rqibltenb(i, k, j) = 0.0_8 END DO END IF CALL POPINTEGER4(ad_to) DO k=ad_to,kts,-1 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) rqvbltenb(i, k, j) = 0.0_8 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) rqcbltenb(i, k, j) = 0.0_8 rvbltenb(i, k, j) = 0.0_8 rubltenb(i, k, j) = 0.0_8 rthbltenb(i, k, j) = 0.0_8 END DO DO k=kte,kts,-1 u_phyb(i, k, j) = u_phyb(i, k, j) + u_phytmpb(i, k, j) u_phytmpb(i, k, j) = 0.0_8 v_phyb(i, k, j) = v_phyb(i, k, j) + v_phytmpb(i, k, j) v_phytmpb(i, k, j) = 0.0_8 END DO END DO END DO END DO END IF END IF END SUBROUTINE A_PBL_DRIVER END MODULE a_module_pbl_driver