| blob | 7a99a7521b3f341724be9798efaf41117b508bc3 |
1 !WRF+/AD:MODEL_LAYER:DYNAMICS
2 !
4 MODULE a_module_em
6 USE module_model_constants
8 USE a_module_advect_em, only: a_advect_u, a_advect_v, a_advect_w, a_advect_scalar, a_advect_scalar_pd, a_advect_scalar_mono, &
9 a_advect_weno_u, a_advect_weno_v, a_advect_weno_w, a_advect_scalar_weno, a_advect_scalar_wenopd
11 USE module_big_step_utilities_em, only: calculate_full, calc_mu_uv
12 USE a_module_big_step_utilities_em, only: grid_config_rec_type, a_calculate_full, a_couple_momentum, a_calc_mu_uv, a_calc_ww_cp, a_calc_cq, a_calc_alt, a_calc_php, a_set_tend, a_rhs_ph, &
13 a_horizontal_pressure_gradient, a_pg_buoy_w, a_w_damp, a_perturbation_coriolis, a_coriolis, a_curvature, a_horizontal_diffusion, a_horizontal_diffusion_3dmp, a_vertical_diffusion_u, &
14 a_vertical_diffusion_v, a_vertical_diffusion, a_vertical_diffusion_3dmp, a_sixth_order_diffusion, a_rk_rayleigh_damp, a_theta_relaxation, a_vertical_diffusion_mp, a_zero_tend, a_zero_tend2d
16 USE module_state_description, only: param_first_scalar, p_qr, p_qv, p_qc, p_qg, p_qi, p_qs, tiedtkescheme, ntiedtkescheme, heldsuarez, positivedef, &
17 gdscheme, g3scheme, kfetascheme, mskfscheme, monotonic, wenopd_scalar, weno_scalar, weno_mom
19 !USE module_damping_em, only: held_suarez_damp
21 CONTAINS
23 !------------------------------------------------------------------------
25 SUBROUTINE a_rk_step_prep(config_flags,rk_step,u,a_u,v,a_v,w,a_w,t,a_t,ph, &
26 a_ph,mu,a_mu,moist,a_moist,ru,a_ru,rv,a_rv,rw,a_rw,ww,a_ww,php,a_php, &
27 alt,a_alt,muu,a_muu,muv,a_muv,mub,mut,a_mut,phb,pb,p,a_p,al,a_al,alb,cqu, &
28 a_cqu,cqv,a_cqv,cqw,a_cqw,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,fnm, &
29 fnp,dnw,rdx,rdy,n_moist,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
30 jte,kts,kte)
32 !PART I: DECLARATION OF VARIABLES
34 IMPLICIT NONE
36 INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
37 TYPE(grid_config_rec_type) :: config_flags
38 INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
39 INTEGER :: n_moist,rk_step
40 REAL :: rdx,rdy
41 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,a_u,v,a_v,w,a_w,t,a_t,ph,a_ph, &
42 phb,pb,al,a_al,alb
43 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru,a_ru,rv,a_rv,rw,a_rw,ww,a_ww, &
44 php,a_php,cqu,a_cqu,cqv,a_cqv,cqw,a_cqw,alt,a_alt
45 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: p,a_p
46 REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist,a_moist
47 REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty,msfux,msfuy,msfvx,msfvx_inv,msfvy,mu, &
48 a_mu,mub
49 REAL,DIMENSION(ims:ime,jms:jme) :: muu,a_muu,muv,a_muv,mut,a_mut
50 REAL,DIMENSION(kms:kme) :: fnm,fnp,dnw
51 integer :: k
53 !PART II: CALCULATIONS OF B. S. TRAJECTORY
55 !!LPB[0]
56 ! CALL calculate_full( mut, mub, mu, &
57 ! ids, ide, jds, jde, 1, 2, &
58 ! ims, ime, jms, jme, 1, 1, &
59 ! its, ite, jts, jte, 1, 1 )
60 ! CALL calc_mu_uv ( config_flags, &
61 ! mu, mub, muu, muv, &
62 ! ids, ide, jds, jde, kds, kde, &
63 ! ims, ime, jms, jme, kms, kme, &
64 ! its, ite, jts, jte, kts, kte )
65 ! CALL couple_momentum( muu, ru, u, msfuy, &
66 ! muv, rv, v, msfvx, msfvx_inv, &
67 ! mut, rw, w, msfty, &
68 ! ids, ide, jds, jde, kds, kde, &
69 ! ims, ime, jms, jme, kms, kme, &
70 ! its, ite, jts, jte, kts, kte )
71 ! CALL calc_ww_cp ( u, v, mu, mub, ww, &
72 ! rdx, rdy, msftx, msfty, &
73 ! msfux, msfuy, msfvx, msfvx_inv, &
74 ! msfvy, dnw, &
75 ! ids, ide, jds, jde, kds, kde, &
76 ! ims, ime, jms, jme, kms, kme, &
77 ! its, ite, jts, jte, kts, kte )
78 ! CALL calc_cq ( moist, cqu, cqv, cqw, n_moist, &
79 ! ids, ide, jds, jde, kds, kde, &
80 ! ims, ime, jms, jme, kms, kme, &
81 ! its, ite, jts, jte, kts, kte )
82 ! CALL calc_alt ( alt, al, alb, &
83 ! ids, ide, jds, jde, kds, kde, &
84 ! ims, ime, jms, jme, kms, kme, &
85 ! its, ite, jts, jte, kts, kte )
86 ! CALL calc_php ( php, ph, phb, &
87 ! ids, ide, jds, jde, kds, kde, &
88 ! ims, ime, jms, jme, kms, kme, &
89 ! its, ite, jts, jte, kts, kte )
91 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
93 !LPB[0]
94 CALL calculate_full(mut,mub,mu,ids,ide,jds,jde,1,2,ims,ime,jms,jme,1,1,its,ite, &
95 jts,jte,1,1)
97 CALL calc_mu_uv(config_flags,mu,mub,muu,muv,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
98 jme,kms,kme,its,ite,jts,jte,kts,kte)
100 ! Remarked by Ning Pan, 2010-07-13
101 ! CALL couple_momentum(muu,ru,u,msfuy,muv,rv,v,msfvx,msfvx_inv,mut,rw,w,msfty,ids, &
102 ! ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
104 ! CALL calc_ww_cp(u,v,mu,mub,ww,rdx,rdy,msftx,msfty,msfux,msfuy,msfvx,msfvx_inv, &
105 ! msfvy,dnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
107 ! CALL calc_cq(moist,cqu,cqv,cqw,n_moist,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
108 ! kms,kme,its,ite,jts,jte,kts,kte)
110 ! CALL calc_alt(alt,al,alb,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
111 ! jts,jte,kts,kte)
113 ! CALL calc_php(php,ph,phb,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
114 ! jts,jte,kts,kte)
116 CALL a_calc_php(php,a_php,ph,a_ph,phb,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
117 jme,kms,kme,its,ite,jts,jte,kts,kte)
118 CALL a_calc_alt(alt,a_alt,al,a_al,alb,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
119 jme,kms,kme,its,ite,jts,jte,kts,kte)
120 CALL a_calc_cq(moist,a_moist,cqu,a_cqu,cqv,a_cqv,cqw,a_cqw,n_moist,ids, &
121 ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
122 CALL a_calc_ww_cp(u,a_u,v,a_v,mu,a_mu,mub,ww,a_ww,rdx,rdy,msftx,msfty, &
123 msfux,msfuy,msfvx,msfvx_inv,msfvy,dnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
124 kme,its,ite,jts,jte,kts,kte)
125 ! Revised by Ning Pan, 2010-07-13
126 ! CALL a_couple_momentum(muu,a_muu,ru,a_ru,u,a_u,msfuy,muv,a_muv,rv, &
127 ! a_rv,v,a_v,msfvx,msfvx_inv,mut,a_mut,rw,a_rw,w,a_w,msfty,ids,ide,jds,jde, &
128 ! kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
129 CALL a_couple_momentum(muu,a_muu,a_ru,u,a_u,msfuy,muv,a_muv, &
130 a_rv,v,a_v,msfvx,msfvx_inv,mut,a_mut,a_rw,w,a_w,msfty,ids,ide,jds,jde, &
131 kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
132 ! Revised by Ning Pan, 2010-07-13
133 ! CALL a_calc_mu_uv(config_flags,mu,a_mu,mub,muu,a_muu,muv,a_muv,ids,ide, &
134 ! jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
135 CALL a_calc_mu_uv(config_flags,a_mu,a_muu,a_muv,ids,ide, &
136 jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
137 ! Revised by Ning Pan, 2010-07-13
138 ! CALL a_calculate_full(mut,a_mut,mub,mu,a_mu,ids,ide,jds,jde,1,2,ims,ime,jms, &
139 ! jme,1,1,its,ite,jts,jte,1,1)
140 CALL a_calculate_full(a_mut,a_mu,ids,ide,jds,jde,1,2,ims,ime,jms, &
141 jme,1,1,its,ite,jts,jte,1,1)
143 END SUBROUTINE a_rk_step_prep
145 !-------------------------------------------------------------------------------
147 SUBROUTINE a_rk_tendency(config_flags,rk_step,ru_tend,a_ru_tend,rv_tend, &
148 a_rv_tend,rw_tend,a_rw_tend,ph_tend,a_ph_tend,t_tend,a_t_tend,ru_tendf, &
149 a_ru_tendf,rv_tendf,a_rv_tendf,rw_tendf,a_rw_tendf,ph_tendf,a_ph_tendf, &
150 t_tendf,a_t_tendf,mu_tend,a_mu_tend,u_save,a_u_save,v_save,a_v_save,w_save, &
151 a_w_save,ph_save,a_ph_save,t_save,a_t_save,mu_save,a_mu_save,RTHFTEN, &
152 a_RTHFTEN,ru,a_ru,rv,a_rv,rw,a_rw,ww,a_ww,u,a_u,v,a_v,w,a_w,t,a_t, &
153 ph,a_ph,u_old,a_u_old,v_old,a_v_old,w_old,a_w_old,t_old,a_t_old,ph_old, &
154 ! Revised by Ning Pan, 2010-07-30
155 ! a_ph_old,h_diabatic,a_h_diabatic,phb,t_init,a_t_init,mu,a_mu,mut,a_mut,muu, &
156 a_ph_old,h_diabatic,a_h_diabatic,phb,t_init,mu,a_mu,mut,a_mut,muu, &
157 a_muu,muv,a_muv,mub,al,a_al,alt,a_alt,p,a_p,pb,php,a_php,cqu,a_cqu,cqv, &
158 a_cqv,cqw,a_cqw,u_base,v_base,t_base,qv_base,z_base,msfux,msfuy,msfvx,msfvx_inv, &
159 ! Revised by Ning Pan, 2010-07-30
160 ! msfvy,msftx,msfty,xlat,a_xlat,f,e,sina,cosa,fnm,fnp,rdn,rdnw,dt,rdx,rdy,khdif, &
161 ! kvdif,xkmhd,a_xkmhd,xkhh,a_xkhh,diff_6th_opt,diff_6th_factor,a_diff_6th_factor, &
162 ! dampcoef,a_dampcoef,zdamp,a_zdamp,damp_opt,cf1,cf2,cf3,cfn,cfn1,n_moist, &
163 ! non_hydrostatic,top_lid,u_frame,a_u_frame,v_frame,a_v_frame,ids,ide,jds,jde,kds, &
164 ! kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte,max_vert_cfl,a_max_vert_cfl, &
165 ! max_horiz_cfl,a_max_horiz_cfl)
166 msfvy,msftx,msfty,xlat,f,e,sina,cosa,fnm,fnp,rdn,rdnw,dt,rdx,rdy,khdif, &
167 kvdif,xkmhd,a_xkmhd,xkhh,a_xkhh,diff_6th_opt,diff_6th_factor, &
168 adv_opt,dampcoef,zdamp,damp_opt,rad_nudge,cf1,cf2,cf3,cfn,cfn1,n_moist, &
169 non_hydrostatic,top_lid,u_frame,v_frame,ids,ide,jds,jde,kds, &
170 kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte,max_vert_cfl, &
171 max_horiz_cfl)
173 ! PART I: DECLARATION OF VARIABLES
175 IMPLICIT NONE
177 INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
178 TYPE(grid_config_rec_type) :: config_flags
179 INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
180 LOGICAL :: non_hydrostatic,top_lid
181 INTEGER :: n_moist,rk_step
182 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru,a_ru,rv,a_rv,rw,a_rw,ww,a_ww,u, &
183 a_u,v,a_v,w,a_w,t,a_t,ph,a_ph,u_old,a_u_old,v_old,a_v_old,w_old, &
184 a_w_old,t_old,a_t_old,ph_old,a_ph_old,phb,al,a_al,alt,a_alt,p,a_p,pb,php, &
185 ! Revised by Ning Pan, 2010-07-30
186 ! a_php,cqu,a_cqu,cqv,a_cqv,t_init,a_t_init,xkmhd,a_xkmhd,xkhh,a_xkhh, &
187 a_php,cqu,a_cqu,cqv,a_cqv,t_init,xkmhd,a_xkmhd,xkhh,a_xkhh, &
188 h_diabatic,a_h_diabatic
189 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_tend,a_ru_tend,rv_tend,a_rv_tend, &
190 rw_tend,a_rw_tend,t_tend,a_t_tend,ph_tend,a_ph_tend,RTHFTEN,a_RTHFTEN,u_save, &
191 a_u_save,v_save,a_v_save,w_save,a_w_save,ph_save,a_ph_save,t_save,a_t_save
192 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_tendf,a_ru_tendf,rv_tendf, &
193 a_rv_tendf,rw_tendf,a_rw_tendf,t_tendf,a_t_tendf,ph_tendf,a_ph_tendf,cqw,a_cqw
194 REAL,DIMENSION(ims:ime,jms:jme) :: mu_tend,a_mu_tend,mu_save,a_mu_save
195 REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty, &
196 ! Revised by Ning Pan, 2010-07-30
197 ! xlat,a_xlat,f,e,sina,cosa,mu,a_mu,mut,a_mut,mub,muu,a_muu,muv,a_muv
198 xlat,f,e,sina,cosa,mu,a_mu,mut,a_mut,mub,muu,a_muu,muv,a_muv
199 REAL,DIMENSION(kms:kme) :: fnm,fnp,rdn,rdnw,u_base,v_base,t_base,qv_base,z_base
200 ! Revised by Ning Pan, 2010-07-30
201 ! REAL :: rdx,rdy,dt,u_frame,a_u_frame,v_frame,a_v_frame,khdif,kvdif
202 REAL :: rdx,rdy,dt,u_frame,v_frame,khdif,kvdif
203 INTEGER :: diff_6th_opt
204 ! Revised by Ning Pan, 2010-07-30
205 ! REAL :: diff_6th_factor,a_diff_6th_factor
206 REAL :: diff_6th_factor
207 INTEGER :: adv_opt
208 INTEGER :: damp_opt,rad_nudge
209 ! Revised by Ning Pan, 2010-07-30
210 ! REAL :: zdamp,a_zdamp,dampcoef,a_dampcoef
211 ! REAL :: max_horiz_cfl,a_max_horiz_cfl
212 ! REAL :: max_vert_cfl,a_max_vert_cfl
213 REAL :: zdamp,dampcoef
214 REAL :: max_horiz_cfl
215 REAL :: max_vert_cfl
216 ! Revised by Ning Pan, 2010-07-30
217 ! REAL :: kdift,a_kdift,khdq,a_khdq,kvdq,a_kvdq,cfn,cfn1,cf1,cf2,cf3
218 REAL :: kdift,khdq,kvdq,cfn,cfn1,cf1,cf2,cf3
219 INTEGER :: i,j,k
220 INTEGER :: time_step
222 ! Remarked by Ning Pan, 2010-07-30
223 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb0_u
224 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb0_v
225 ! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb1_w
226 ! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb1_rw_tend
227 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb2_t
228 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb2_t_tend
229 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb2_ru
230 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb2_rv
231 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb4_ph_tend
232 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb4_ru_tend
233 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb4_rv_tend
234 ! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb5_rw_tend
235 ! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb5_cqw
236 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb6_rw_tend
237 ! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb7_ru_tend
238 ! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb7_rv_tend
239 ! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb7_rw_tend
240 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb8_ru_tend
241 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb8_rv_tend
242 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb8_rw_tend
243 ! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb9_ru_tend
244 ! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb9_rv_tend
245 !! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb11_ru_tendf
246 !! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb11_rv_tendf
247 !! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb11_rw_tendf
248 !! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb11_t_tendf
249 ! INTEGER :: IX1,IX2,IX3
250 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv400
251 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv401
252 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv402
253 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv403
254 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv404
255 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv405
256 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv406
257 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv407
258 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv408
259 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv409
260 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv4010
261 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv4011
262 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv4012
263 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv4013
264 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv4014
265 ! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv4015
267 ! REAL :: Const_Diff_A0,Const_A0
269 ! This line is fail to be recognized
270 CALL nl_get_time_step ( 1, time_step )
272 ! Remarked by Ning Pan, 2010-07-30 : Part II is not needed
273 !! PART! II: CALCULATIONS OF B. S. TRAJECTORY
275 !! LPB[0]
276 ! DO IX3=jms,jme
277 ! DO IX2=kms,kme
278 ! DO IX1=ims,ime
279 ! Keep_Lpb0_u(IX1,IX2,IX3) =u(IX1,IX2,IX3)
280 ! END DO
281 ! END DO
282 ! END DO
283 ! DO IX3=jms,jme
284 ! DO IX2=kms,kme
285 ! DO IX1=ims,ime
286 ! Keep_Lpb0_v(IX1,IX2,IX3) =v(IX1,IX2,IX3)
287 ! END DO
288 ! END DO
289 ! END DO
291 ! CALL zero_tend ( ru_tend, &
292 ! ids, ide, jds, jde, kds, kde, &
293 ! ims, ime, jms, jme, kms, kme, &
294 ! its, ite, jts, jte, kts, kte )
295 ! CALL zero_tend ( rv_tend, &
296 ! ids, ide, jds, jde, kds, kde, &
297 ! ims, ime, jms, jme, kms, kme, &
298 ! its, ite, jts, jte, kts, kte )
299 ! CALL zero_tend ( rw_tend, &
300 ! ids, ide, jds, jde, kds, kde, &
301 ! ims, ime, jms, jme, kms, kme, &
302 ! its, ite, jts, jte, kts, kte )
303 ! CALL zero_tend ( t_tend, &
304 ! ids, ide, jds, jde, kds, kde, &
305 ! ims, ime, jms, jme, kms, kme, &
306 ! its, ite, jts, jte, kts, kte )
307 ! CALL zero_tend ( ph_tend, &
308 ! ids, ide, jds, jde, kds, kde, &
309 ! ims, ime, jms, jme, kms, kme, &
310 ! its, ite, jts, jte, kts, kte )
311 ! CALL zero_tend ( u_save, &
312 ! ids, ide, jds, jde, kds, kde, &
313 ! ims, ime, jms, jme, kms, kme, &
314 ! its, ite, jts, jte, kts, kte )
315 ! CALL zero_tend ( v_save, &
316 ! ids, ide, jds, jde, kds, kde, &
317 ! ims, ime, jms, jme, kms, kme, &
318 ! its, ite, jts, jte, kts, kte )
319 ! CALL zero_tend ( w_save, &
320 ! ids, ide, jds, jde, kds, kde, &
321 ! ims, ime, jms, jme, kms, kme, &
322 ! its, ite, jts, jte, kts, kte )
323 ! CALL zero_tend ( ph_save, &
324 ! ids, ide, jds, jde, kds, kde, &
325 ! ims, ime, jms, jme, kms, kme, &
326 ! its, ite, jts, jte, kts, kte )
327 ! CALL zero_tend ( t_save, &
328 ! ids, ide, jds, jde, kds, kde, &
329 ! ims, ime, jms, jme, kms, kme, &
330 ! its, ite, jts, jte, kts, kte )
331 ! CALL zero_tend ( mu_tend, &
332 ! ids, ide, jds, jde, 1, 1, &
333 ! ims, ime, jms, jme, 1, 1, &
334 ! its, ite, jts, jte, 1, 1 )
335 ! CALL zero_tend ( mu_save, &
336 ! ids, ide, jds, jde, 1, 1, &
337 ! ims, ime, jms, jme, 1, 1, &
338 ! its, ite, jts, jte, 1, 1 )
339 ! CALL advect_u ( u, u , ru_tend, ru, rv, ww, &
340 ! mut, time_step, config_flags, &
341 ! msfux, msfuy, msfvx, msfvy, &
342 ! msftx, msfty, &
343 ! fnm, fnp, rdx, rdy, rdnw, &
344 ! ids, ide, jds, jde, kds, kde, &
345 ! ims, ime, jms, jme, kms, kme, &
346 ! its, ite, jts, jte, kts, kte )
347 ! CALL advect_v ( v, v , rv_tend, ru, rv, ww, &
348 ! mut, time_step, config_flags, &
349 ! msfux, msfuy, msfvx, msfvy, &
350 ! msftx, msfty, &
351 ! fnm, fnp, rdx, rdy, rdnw, &
352 ! ids, ide, jds, jde, kds, kde, &
353 ! ims, ime, jms, jme, kms, kme, &
354 ! its, ite, jts, jte, kts, kte )
356 !LPB[1]
357 ! DO IX3=jms,jme
358 ! DO IX2=kms,kme
359 ! DO IX1=ims,ime
360 ! Keep_Lpb1_w(IX1,IX2,IX3) =w(IX1,IX2,IX3)
361 ! END DO
362 ! END DO
363 ! END DO
364 ! DO IX3=jms,jme
365 ! DO IX2=kms,kme
366 ! DO IX1=ims,ime
367 ! Keep_Lpb1_rw_tend(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
368 ! END DO
369 ! END DO
370 ! END DO
372 ! IF (non_hydrostatic) &
373 ! CALL advect_w ( w, w, rw_tend, ru, rv, ww, &
374 ! mut, time_step, config_flags, &
375 ! msfux, msfuy, msfvx, msfvy, &
376 ! msftx, msfty, &
377 ! fnm, fnp, rdx, rdy, rdn, &
378 ! ids, ide, jds, jde, kds, kde, &
379 ! ims, ime, jms, jme, kms, kme, &
380 ! its, ite, jts, jte, kts, kte )
382 !LPB[2]
383 ! DO IX3=jms,jme
384 ! DO IX2=kms,kme
385 ! DO IX1=ims,ime
386 ! Keep_Lpb2_t(IX1,IX2,IX3) =t(IX1,IX2,IX3)
387 ! END DO
388 ! END DO
389 ! END DO
390 ! DO IX3=jms,jme
391 ! DO IX2=kms,kme
392 ! DO IX1=ims,ime
393 ! Keep_Lpb2_t_tend(IX1,IX2,IX3) =t_tend(IX1,IX2,IX3)
394 ! END DO
395 ! END DO
396 ! END DO
397 ! DO IX3=jms,jme
398 ! DO IX2=kms,kme
399 ! DO IX1=ims,ime
400 ! Keep_Lpb2_ru(IX1,IX2,IX3) =ru(IX1,IX2,IX3)
401 ! END DO
402 ! END DO
403 ! END DO
404 ! DO IX3=jms,jme
405 ! DO IX2=kms,kme
406 ! DO IX1=ims,ime
407 ! Keep_Lpb2_rv(IX1,IX2,IX3) =rv(IX1,IX2,IX3)
408 ! END DO
409 ! END DO
410 ! END DO
412 ! CALL advect_scalar ( t, t, t_tend, ru, rv, ww, &
413 ! mut, time_step, config_flags, &
414 ! msfux, msfuy, msfvx, msfvy, &
415 ! msftx, msfty, fnm, fnp, &
416 ! rdx, rdy, rdnw, &
417 ! ids, ide, jds, jde, kds, kde, &
418 ! ims, ime, jms, jme, kms, kme, &
419 ! its, ite, jts, jte, kts, kte )
421 !LPB[3]
422 ! IF ( config_flags%cu_physics == GDSCHEME .OR. &
423 ! config_flags%cu_physics == G3SCHEME ) THEN
425 ! CALL set_tend( RTHFTEN, t_tend, msfty, &
426 ! ids, ide, jds, jde, kds, kde, &
427 ! ims, ime, jms, jme, kms, kme, &
428 ! its, ite, jts, jte, kts, kte )
430 ! END IF
432 !LPB[4]
433 ! DO IX3=jms,jme
434 ! DO IX2=kms,kme
435 ! DO IX1=ims,ime
436 ! Keep_Lpb4_ph_tend(IX1,IX2,IX3) =ph_tend(IX1,IX2,IX3)
437 ! END DO
438 ! END DO
439 ! END DO
440 ! DO IX3=jms,jme
441 ! DO IX2=kms,kme
442 ! DO IX1=ims,ime
443 ! Keep_Lpb4_ru_tend(IX1,IX2,IX3) =ru_tend(IX1,IX2,IX3)
444 ! END DO
445 ! END DO
446 ! END DO
447 ! DO IX3=jms,jme
448 ! DO IX2=kms,kme
449 ! DO IX1=ims,ime
450 ! Keep_Lpb4_rv_tend(IX1,IX2,IX3) =rv_tend(IX1,IX2,IX3)
451 ! END DO
452 ! END DO
453 ! END DO
455 ! CALL rhs_ph( ph_tend, u, v, ww, ph, ph, phb, w, &
456 ! mut, muu, muv, &
457 ! fnm, fnp, &
458 ! rdnw, cfn, cfn1, rdx, rdy, &
459 ! msfux, msfuy, msfvx, &
460 ! msfvx_inv, msfvy, &
461 ! msftx, msfty, &
462 ! non_hydrostatic, &
463 ! config_flags, &
464 ! ids, ide, jds, jde, kds, kde, &
465 ! ims, ime, jms, jme, kms, kme, &
466 ! its, ite, jts, jte, kts, kte )
467 ! CALL horizontal_pressure_gradient( ru_tend,rv_tend, &
468 ! ph,alt,p,pb,al,php,cqu,cqv, &
469 ! muu,muv,mu,fnm,fnp,rdnw, &
470 ! cf1,cf2,cf3,cfn,cfn1, &
471 ! rdx,rdy,msfux,msfuy, &
472 ! msfvx,msfvy,msftx,msfty, &
473 ! config_flags, non_hydrostatic, &
474 ! top_lid, &
475 ! ids, ide, jds, jde, kds, kde, &
476 ! ims, ime, jms, jme, kms, kme, &
477 ! its, ite, jts, jte, kts, kte )
479 !LPB[5]
480 ! DO IX3=jms,jme
481 ! DO IX2=kms,kme
482 ! DO IX1=ims,ime
483 ! Keep_Lpb5_rw_tend(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
484 ! END DO
485 ! END DO
486 ! END DO
487 ! DO IX3=jms,jme
488 ! DO IX2=kms,kme
489 ! DO IX1=ims,ime
490 ! Keep_Lpb5_cqw(IX1,IX2,IX3) =cqw(IX1,IX2,IX3)
491 ! END DO
492 ! END DO
493 ! END DO
495 ! IF (non_hydrostatic) THEN
497 ! CALL pg_buoy_w( rw_tend, p, cqw, mu, mub, &
498 ! rdnw, rdn, g, msftx, msfty, &
499 ! ids, ide, jds, jde, kds, kde, &
500 ! ims, ime, jms, jme, kms, kme, &
501 ! its, ite, jts, jte, kts, kte )
503 ! ENDIF
505 !LPB[6]
506 ! DO IX3=jms,jme
507 ! DO IX2=kms,kme
508 ! DO IX1=ims,ime
509 ! Keep_Lpb6_rw_tend(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
510 ! END DO
511 ! END DO
512 ! END DO
514 ! CALL w_damp ( rw_tend, max_vert_cfl, &
515 ! max_horiz_cfl, &
516 ! u, v, ww, w, mut, rdnw, &
517 ! rdx, rdy, msfux, msfuy, msfvx, &
518 ! msfvy, dt, config_flags, &
519 ! ids, ide, jds, jde, kds, kde, &
520 ! ims, ime, jms, jme, kms, kme, &
521 ! its, ite, jts, jte, kts, kte )
523 !LPB[7]
524 ! DO IX3=jms,jme
525 ! DO IX2=kms,kme
526 ! DO IX1=ims,ime
527 ! Keep_Lpb7_ru_tend(IX1,IX2,IX3) =ru_tend(IX1,IX2,IX3)
528 ! END DO
529 ! END DO
530 ! END DO
531 ! DO IX3=jms,jme
532 ! DO IX2=kms,kme
533 ! DO IX1=ims,ime
534 ! Keep_Lpb7_rv_tend(IX1,IX2,IX3) =rv_tend(IX1,IX2,IX3)
535 ! END DO
536 ! END DO
537 ! END DO
538 ! DO IX3=jms,jme
539 ! DO IX2=kms,kme
540 ! DO IX1=ims,ime
541 ! Keep_Lpb7_rw_tend(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
542 ! END DO
543 ! END DO
544 ! END DO
546 ! IF(config_flags%pert_coriolis) THEN
548 ! CALL perturbation_coriolis ( ru, rv, rw, &
549 ! ru_tend, rv_tend, rw_tend, &
550 ! config_flags, &
551 ! u_base, v_base, z_base, &
552 ! muu, muv, phb, ph, &
553 ! msftx, msfty, msfux, msfuy, &
554 ! msfvx, msfvy, &
555 ! f, e, sina, cosa, fnm, fnp, &
556 ! ids, ide, jds, jde, kds, kde, &
557 ! ims, ime, jms, jme, kms, kme, &
558 ! its, ite, jts, jte, kts, kte )
559 ! ELSE
560 ! CALL coriolis ( ru, rv, rw, &
561 ! ru_tend, rv_tend, rw_tend, &
562 ! config_flags, &
563 ! msftx, msfty, msfux, msfuy, &
564 ! msfvx, msfvy, &
565 ! f, e, sina, cosa, fnm, fnp, &
566 ! ids, ide, jds, jde, kds, kde, &
567 ! ims, ime, jms, jme, kms, kme, &
568 ! its, ite, jts, jte, kts, kte )
570 ! END IF
572 !LPB[8]
573 ! DO IX3=jms,jme
574 ! DO IX2=kms,kme
575 ! DO IX1=ims,ime
576 ! Keep_Lpb8_ru_tend(IX1,IX2,IX3) =ru_tend(IX1,IX2,IX3)
577 ! END DO
578 ! END DO
579 ! END DO
580 ! DO IX3=jms,jme
581 ! DO IX2=kms,kme
582 ! DO IX1=ims,ime
583 ! Keep_Lpb8_rv_tend(IX1,IX2,IX3) =rv_tend(IX1,IX2,IX3)
584 ! END DO
585 ! END DO
586 ! END DO
587 ! DO IX3=jms,jme
588 ! DO IX2=kms,kme
589 ! DO IX1=ims,ime
590 ! Keep_Lpb8_rw_tend(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
591 ! END DO
592 ! END DO
593 ! END DO
595 ! CALL curvature ( ru, rv, rw, u, v, w, &
596 ! ru_tend, rv_tend, rw_tend, &
597 ! config_flags, &
598 ! msfux, msfuy, msfvx, msfvy, &
599 ! msftx, msfty, &
600 ! xlat, fnm, fnp, rdx, rdy, &
601 ! ids, ide, jds, jde, kds, kde, &
602 ! ims, ime, jms, jme, kms, kme, &
603 ! its, ite, jts, jte, kts, kte )
605 !LPB[9]
606 ! DO IX3=jms,jme
607 ! DO IX2=kms,kme
608 ! DO IX1=ims,ime
609 ! Keep_Lpb9_ru_tend(IX1,IX2,IX3) =ru_tend(IX1,IX2,IX3)
610 ! END DO
611 ! END DO
612 ! END DO
613 ! DO IX3=jms,jme
614 ! DO IX2=kms,kme
615 ! DO IX1=ims,ime
616 ! Keep_Lpb9_rv_tend(IX1,IX2,IX3) =rv_tend(IX1,IX2,IX3)
617 ! END DO
618 ! END DO
619 ! END DO
621 ! IF (config_flags%ra_lw_physics == HELDSUAREZ) THEN
623 ! CALL held_suarez_damp ( ru_tend, rv_tend, &
624 ! ru,rv,p,pb, &
625 ! ids, ide, jds, jde, kds, kde, &
626 ! ims, ime, jms, jme, kms, kme, &
627 ! its, ite, jts, jte, kts, kte )
629 ! END IF
631 !LPB[10]
633 !!LPB[11]
634 !! DO IX3=jms,jme
635 !! DO IX2=kms,kme
636 !! DO IX1=ims,ime
637 ! ! Keep_Lpb11_ru_tendf(IX1,IX2,IX3) =ru_tendf(IX1,IX2,IX3)
638 !! END DO
639 !! END DO
640 !! END DO
641 !! DO IX3=jms,jme
642 !! DO IX2=kms,kme
643 !! DO IX1=ims,ime
644 ! ! Keep_Lpb11_rv_tendf(IX1,IX2,IX3) =rv_tendf(IX1,IX2,IX3)
645 !! END DO
646 !! END DO
647 !! END DO
648 !! DO IX3=jms,jme
649 !! DO IX2=kms,kme
650 !! DO IX1=ims,ime
651 ! ! Keep_Lpb11_rw_tendf(IX1,IX2,IX3) =rw_tendf(IX1,IX2,IX3)
652 !! END DO
653 !! END DO
654 !! END DO
655 !! DO IX3=jms,jme
656 !! DO IX2=kms,kme
657 !! DO IX1=ims,ime
658 ! ! Keep_Lpb11_t_tendf(IX1,IX2,IX3) =t_tendf(IX1,IX2,IX3)
659 !! END DO
660 !! END DO
661 !! END DO
663 !
664 ! forward_step: IF( rk_step == 1 ) THEN
666 ! diff_opt1 : IF (config_flags%diff_opt .eq. 1) THEN
668 ! CALL horizontal_diffusion ('u', u, ru_tendf, mut, config_flags, &
669 ! msfux, msfuy, msfvx, msfvx_inv, &
670 ! msfvy,msftx, msfty, &
671 ! khdif, xkmhd, rdx, rdy, &
672 ! ids, ide, jds, jde, kds, kde, &
673 ! ims, ime, jms, jme, kms, kme, &
674 ! its, ite, jts, jte, kts, kte )
675 ! CALL horizontal_diffusion ('v', v, rv_tendf, mut, config_flags, &
676 ! msfux, msfuy, msfvx, msfvx_inv, &
677 ! msfvy,msftx, msfty, &
678 ! khdif, xkmhd, rdx, rdy, &
679 ! ids, ide, jds, jde, kds, kde, &
680 ! ims, ime, jms, jme, kms, kme, &
681 ! its, ite, jts, jte, kts, kte )
682 ! CALL horizontal_diffusion ('w', w, rw_tendf, mut, config_flags, &
683 ! msfux, msfuy, msfvx, msfvx_inv, &
684 ! msfvy,msftx, msfty, &
685 ! khdif, xkmhd, rdx, rdy, &
686 ! ids, ide, jds, jde, kds, kde, &
687 ! ims, ime, jms, jme, kms, kme, &
688 ! its, ite, jts, jte, kts, kte )
689 ! khdq = 3.*khdif
690 ! CALL horizontal_diffusion_3dmp ( 'm', t, t_tendf, mut, &
691 ! config_flags, t_init, &
692 ! msfux, msfuy, msfvx, msfvx_inv, &
693 ! msfvy, msftx, msfty, &
694 ! khdq , xkhh, rdx, rdy, &
695 ! ids, ide, jds, jde, kds, kde, &
696 ! ims, ime, jms, jme, kms, kme, &
697 ! its, ite, jts, jte, kts, kte )
698 ! pbl_test : IF (config_flags%bl_pbl_physics .eq. 0) THEN
700 ! CALL vertical_diffusion_u ( u, ru_tendf, config_flags, &
701 ! u_base, &
702 ! alt, muu, rdn, rdnw, kvdif, &
703 ! ids, ide, jds, jde, kds, kde, &
704 ! ims, ime, jms, jme, kms, kme, &
705 ! its, ite, jts, jte, kts, kte )
706 ! CALL vertical_diffusion_v ( v, rv_tendf, config_flags, &
707 ! v_base, &
708 ! alt, muv, rdn, rdnw, kvdif, &
709 ! ids, ide, jds, jde, kds, kde, &
710 ! ims, ime, jms, jme, kms, kme, &
711 ! its, ite, jts, jte, kts, kte )
712 ! IF (non_hydrostatic) &
713 ! CALL vertical_diffusion ( 'w', w, rw_tendf, config_flags, &
714 ! alt, mut, rdn, rdnw, kvdif, &
715 ! ids, ide, jds, jde, kds, kde, &
716 ! ims, ime, jms, jme, kms, kme, &
717 ! its, ite, jts, jte, kts, kte )
719 ! kvdq = 3.*kvdif
720 ! CALL vertical_diffusion_3dmp ( t, t_tendf, config_flags, t_init, &
721 ! alt, mut, rdn, rdnw, kvdq , &
722 ! ids, ide, jds, jde, kds, kde, &
723 ! ims, ime, jms, jme, kms, kme, &
724 ! its, ite, jts, jte, kts, kte )
725 ! ENDIF pbl_test
726 ! END IF diff_opt1
727 ! IF ( diff_6th_opt .NE. 0 ) THEN
729 ! CALL sixth_order_diffusion( 'u', u, ru_tendf, mut, dt, &
730 ! config_flags, &
731 ! diff_6th_opt, diff_6th_factor, &
732 ! ids, ide, jds, jde, kds, kde, &
733 ! ims, ime, jms, jme, kms, kme, &
734 ! its, ite, jts, jte, kts, kte )
735 ! CALL sixth_order_diffusion( 'v', v, rv_tendf, mut, dt, &
736 ! config_flags, &
737 ! diff_6th_opt, diff_6th_factor, &
738 ! ids, ide, jds, jde, kds, kde, &
739 ! ims, ime, jms, jme, kms, kme, &
740 ! its, ite, jts, jte, kts, kte )
741 ! IF (non_hydrostatic) &
742 ! CALL sixth_order_diffusion( 'w', w, rw_tendf, mut, dt, &
743 ! config_flags, &
744 ! diff_6th_opt, diff_6th_factor, &
745 ! ids, ide, jds, jde, kds, kde, &
746 ! ims, ime, jms, jme, kms, kme, &
747 ! its, ite, jts, jte, kts, kte )
749 ! CALL sixth_order_diffusion( 'm', t, t_tendf, mut, dt, &
750 ! config_flags, &
751 ! diff_6th_opt, diff_6th_factor, &
752 ! ids, ide, jds, jde, kds, kde, &
753 ! ims, ime, jms, jme, kms, kme, &
754 ! its, ite, jts, jte, kts, kte )
755 ! ENDIF
756 ! IF( damp_opt .eq. 2 ) &
757 ! CALL rk_rayleigh_damp( ru_tendf, rv_tendf, &
758 ! rw_tendf, t_tendf, &
759 ! u, v, w, t, t_init, &
760 ! mut, muu, muv, ph, phb, &
761 ! u_base, v_base, t_base, z_base, &
762 ! dampcoef, zdamp, &
763 ! ids, ide, jds, jde, kds, kde, &
764 ! ims, ime, jms, jme, kms, kme, &
765 ! its, ite, jts, jte, kts, kte )
767 ! END IF
769 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
771 ! Remarked by Ning Pan, 2010-07-30
772 ! a_kdift =0.0
773 ! a_khdq =0.0
774 ! a_kvdq =0.0
776 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
778 !LPB[11]
779 ! DO IX3=jms,jme
780 ! DO IX2=kms,kme
781 ! DO IX1=ims,ime
782 ! ru_tendf(IX1,IX2,IX3) =Keep_Lpb11_ru_tendf(IX1,IX2,IX3)
783 ! END DO
784 ! END DO
785 ! END DO
786 ! DO IX3=jms,jme
787 ! DO IX2=kms,kme
788 ! DO IX1=ims,ime
789 ! rv_tendf(IX1,IX2,IX3) =Keep_Lpb11_rv_tendf(IX1,IX2,IX3)
790 ! END DO
791 ! END DO
792 ! END DO
793 ! DO IX3=jms,jme
794 ! DO IX2=kms,kme
795 ! DO IX1=ims,ime
796 ! rw_tendf(IX1,IX2,IX3) =Keep_Lpb11_rw_tendf(IX1,IX2,IX3)
797 ! END DO
798 ! END DO
799 ! END DO
800 ! DO IX3=jms,jme
801 ! DO IX2=kms,kme
802 ! DO IX1=ims,ime
803 ! t_tendf(IX1,IX2,IX3) =Keep_Lpb11_t_tendf(IX1,IX2,IX3)
804 ! END DO
805 ! END DO
806 ! END DO
808 ! Remarked by Ning Pan, 2010-07-30
809 ! IF( rk_step == 1 ) THEN
810 ! IF(config_flags%diff_opt .eq. 1) THEN
811 ! DO IX3=jms,jme
812 ! DO IX2=kms,kme
813 ! DO IX1=ims,ime
814 ! Tmpv400(IX1,IX2,IX3) =ru_tendf(IX1,IX2,IX3)
815 ! END DO
816 ! END DO
817 ! END DO
819 ! CALL horizontal_diffusion('u',u,ru_tendf,mut,config_flags,msfux,msfuy,msfvx, &
820 ! msfvx_inv,msfvy,msftx,msfty,khdif,xkmhd,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
821 ! jme,kms,kme,its,ite,jts,jte,kts,kte)
823 ! DO IX3=jms,jme
824 ! DO IX2=kms,kme
825 ! DO IX1=ims,ime
826 ! Tmpv401(IX1,IX2,IX3) =rv_tendf(IX1,IX2,IX3)
827 ! END DO
828 ! END DO
829 ! END DO
831 ! CALL horizontal_diffusion('v',v,rv_tendf,mut,config_flags,msfux,msfuy,msfvx, &
832 ! msfvx_inv,msfvy,msftx,msfty,khdif,xkmhd,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
833 ! jme,kms,kme,its,ite,jts,jte,kts,kte)
835 ! DO IX3=jms,jme
836 ! DO IX2=kms,kme
837 ! DO IX1=ims,ime
838 ! Tmpv402(IX1,IX2,IX3) =rw_tendf(IX1,IX2,IX3)
839 ! END DO
840 ! END DO
841 ! END DO
843 ! CALL horizontal_diffusion('w',w,rw_tendf,mut,config_flags,msfux,msfuy,msfvx, &
844 ! msfvx_inv,msfvy,msftx,msfty,khdif,xkmhd,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
845 ! jme,kms,kme,its,ite,jts,jte,kts,kte)
847 ! khdq =3.*khdif
849 ! DO IX3=jms,jme
850 ! DO IX2=kms,kme
851 ! DO IX1=ims,ime
852 ! Tmpv403(IX1,IX2,IX3) =t_tendf(IX1,IX2,IX3)
853 ! END DO
854 ! END DO
855 ! END DO
857 ! CALL horizontal_diffusion_3dmp('m',t,t_tendf,mut,config_flags,t_init,msfux,msfuy, &
858 ! msfvx,msfvx_inv,msfvy,msftx,msfty,khdq,xkhh,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime, &
859 ! jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
861 ! IF(config_flags%bl_pbl_physics .eq. 0) THEN
862 ! DO IX3=jms,jme
863 ! DO IX2=kms,kme
864 ! DO IX1=ims,ime
865 ! Tmpv404(IX1,IX2,IX3) =ru_tendf(IX1,IX2,IX3)
866 ! END DO
867 ! END DO
868 ! END DO
870 ! CALL vertical_diffusion_u(u,ru_tendf,config_flags,u_base,alt,muu,rdn,rdnw,kvdif, &
871 ! ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
873 ! DO IX3=jms,jme
874 ! DO IX2=kms,kme
875 ! DO IX1=ims,ime
876 ! Tmpv405(IX1,IX2,IX3) =rv_tendf(IX1,IX2,IX3)
877 ! END DO
878 ! END DO
879 ! END DO
881 ! CALL vertical_diffusion_v(v,rv_tendf,config_flags,v_base,alt,muv,rdn,rdnw,kvdif, &
882 ! ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
884 ! IF(non_hydrostatic) THEN
885 ! DO IX3=jms,jme
886 ! DO IX2=kms,kme
887 ! DO IX1=ims,ime
888 ! Tmpv406(IX1,IX2,IX3) =rw_tendf(IX1,IX2,IX3)
889 ! END DO
890 ! END DO
891 ! END DO
893 ! CALL vertical_diffusion('w',w,rw_tendf,config_flags,alt,mut,rdn,rdnw,kvdif,ids, &
894 ! ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
896 ! END IF
897 ! kvdq =3.*kvdif
899 ! DO IX3=jms,jme
900 ! DO IX2=kms,kme
901 ! DO IX1=ims,ime
902 ! Tmpv407(IX1,IX2,IX3) =t_tendf(IX1,IX2,IX3)
903 ! END DO
904 ! END DO
905 ! END DO
907 ! CALL vertical_diffusion_3dmp(t,t_tendf,config_flags,t_init,alt,mut,rdn,rdnw,kvdq, &
908 ! ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
910 ! ENDIF
911 ! END IF
912 ! IF( diff_6th_opt .NE. 0 ) THEN
913 ! DO IX3=jms,jme
914 ! DO IX2=kms,kme
915 ! DO IX1=ims,ime
916 ! Tmpv408(IX1,IX2,IX3) =ru_tendf(IX1,IX2,IX3)
917 ! END DO
918 ! END DO
919 ! END DO
921 ! CALL sixth_order_diffusion('u',u,ru_tendf,mut,dt,config_flags,diff_6th_opt, &
922 ! diff_6th_factor,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
924 ! DO IX3=jms,jme
925 ! DO IX2=kms,kme
926 ! DO IX1=ims,ime
927 ! Tmpv409(IX1,IX2,IX3) =rv_tendf(IX1,IX2,IX3)
928 ! END DO
929 ! END DO
930 ! END DO
932 ! CALL sixth_order_diffusion('v',v,rv_tendf,mut,dt,config_flags,diff_6th_opt, &
933 ! diff_6th_factor,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
935 ! IF(non_hydrostatic) THEN
936 ! DO IX3=jms,jme
937 ! DO IX2=kms,kme
938 ! DO IX1=ims,ime
939 ! Tmpv4010(IX1,IX2,IX3) =rw_tendf(IX1,IX2,IX3)
940 ! END DO
941 ! END DO
942 ! END DO
944 ! CALL sixth_order_diffusion('w',w,rw_tendf,mut,dt,config_flags,diff_6th_opt, &
945 ! diff_6th_factor,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
947 ! END IF
948 ! DO IX3=jms,jme
949 ! DO IX2=kms,kme
950 ! DO IX1=ims,ime
951 ! Tmpv4011(IX1,IX2,IX3) =t_tendf(IX1,IX2,IX3)
952 ! END DO
953 ! END DO
954 ! END DO
956 ! CALL sixth_order_diffusion('m',t,t_tendf,mut,dt,config_flags,diff_6th_opt, &
957 ! diff_6th_factor,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
959 ! ENDIF
960 ! IF( damp_opt .eq. 2 ) THEN
961 ! DO IX3=jms,jme
962 ! DO IX2=kms,kme
963 ! DO IX1=ims,ime
964 ! Tmpv4012(IX1,IX2,IX3) =ru_tendf(IX1,IX2,IX3)
965 ! END DO
966 ! END DO
967 ! END DO
969 ! DO IX3=jms,jme
970 ! DO IX2=kms,kme
971 ! DO IX1=ims,ime
972 ! Tmpv4013(IX1,IX2,IX3) =rv_tendf(IX1,IX2,IX3)
973 ! END DO
974 ! END DO
975 ! END DO
977 ! DO IX3=jms,jme
978 ! DO IX2=kms,kme
979 ! DO IX1=ims,ime
980 ! Tmpv4014(IX1,IX2,IX3) =rw_tendf(IX1,IX2,IX3)
981 ! END DO
982 ! END DO
983 ! END DO
985 ! DO IX3=jms,jme
986 ! DO IX2=kms,kme
987 ! DO IX1=ims,ime
988 ! Tmpv4015(IX1,IX2,IX3) =t_tendf(IX1,IX2,IX3)
989 ! END DO
990 ! END DO
991 ! END DO
993 ! CALL rk_rayleigh_damp(ru_tendf,rv_tendf,rw_tendf,t_tendf,u,v,w,t,t_init,mut,muu, &
994 ! muv,ph,phb,u_base,v_base,t_base,z_base,dampcoef,zdamp,ids,ide,jds,jde,kds,kde,ims, &
995 ! ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
997 ! END IF
998 ! END IF
1000 !! temp NING
1001 IF( rk_step == 1 ) THEN
1003 IF( rad_nudge .eq. 1 ) &
1004 CALL a_theta_relaxation( t_tendf, a_t_tendf, t, a_t, t_init, &
1005 mut, a_mut, ph, a_ph, phb, &
1006 t_base, z_base, &
1007 ids, ide, jds, jde, kds, kde, &
1008 ims, ime, jms, jme, kms, kme, &
1009 its, ite, jts, jte, kts, kte )
1011 IF( damp_opt .eq. 2 ) THEN
1013 ! Remarked by Ning Pan, 2010-07-30
1014 ! DO IX3=jms,jme
1015 ! DO IX2=kms,kme
1016 ! DO IX1=ims,ime
1017 ! t_tendf(IX1,IX2,IX3) =Tmpv4015(IX1,IX2,IX3)
1018 ! END DO
1019 ! END DO
1020 ! END DO
1022 ! DO IX3=jms,jme
1023 ! DO IX2=kms,kme
1024 ! DO IX1=ims,ime
1025 ! rw_tendf(IX1,IX2,IX3) =Tmpv4014(IX1,IX2,IX3)
1026 ! END DO
1027 ! END DO
1028 ! END DO
1030 ! DO IX3=jms,jme
1031 ! DO IX2=kms,kme
1032 ! DO IX1=ims,ime
1033 ! rv_tendf(IX1,IX2,IX3) =Tmpv4013(IX1,IX2,IX3)
1034 ! END DO
1035 ! END DO
1036 ! END DO
1038 ! DO IX3=jms,jme
1039 ! DO IX2=kms,kme
1040 ! DO IX1=ims,ime
1041 ! ru_tendf(IX1,IX2,IX3) =Tmpv4012(IX1,IX2,IX3)
1042 ! END DO
1043 ! END DO
1044 ! END DO
1046 CALL a_rk_rayleigh_damp(ru_tendf,a_ru_tendf,rv_tendf,a_rv_tendf,rw_tendf, &
1047 ! Revised by Ning Pan, 2010-07-23
1048 ! a_rw_tendf,t_tendf,a_t_tendf,u,a_u,v,a_v,w,a_w,t,a_t,t_init,a_t_init, &
1049 a_rw_tendf,t_tendf,a_t_tendf,u,a_u,v,a_v,w,a_w,t,a_t,t_init, &
1050 mut,a_mut,muu,a_muu,muv,a_muv,ph,a_ph,phb,u_base,v_base,t_base,z_base, &
1051 ! Revised by Ning Pan, 2010-07-30
1052 ! dampcoef,a_dampcoef,zdamp,a_zdamp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
1053 dampcoef,zdamp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
1054 kme,its,ite,jts,jte,kts,kte)
1056 END IF
1058 IF( diff_6th_opt .NE. 0 ) THEN
1060 ! Remarked by Ning Pan, 2010-07-30
1061 ! DO IX3=jms,jme
1062 ! DO IX2=kms,kme
1063 ! DO IX1=ims,ime
1064 ! t_tendf(IX1,IX2,IX3) =Tmpv4011(IX1,IX2,IX3)
1065 ! END DO
1066 ! END DO
1067 ! END DO
1069 CALL a_sixth_order_diffusion('m',t,a_t,t_tendf,a_t_tendf,mut,a_mut,dt, &
1070 ! Revised by Ning Pan, 2010-07-30
1071 ! config_flags,diff_6th_opt,diff_6th_factor,a_diff_6th_factor,ids,ide,jds,jde,kds, &
1072 config_flags,diff_6th_opt,diff_6th_factor,ids,ide,jds,jde,kds, &
1073 kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1075 IF(non_hydrostatic) THEN
1077 ! Remarked by Ning Pan, 2010-07-30
1078 ! DO IX3=jms,jme
1079 ! DO IX2=kms,kme
1080 ! DO IX1=ims,ime
1081 ! rw_tendf(IX1,IX2,IX3) =Tmpv4010(IX1,IX2,IX3)
1082 ! END DO
1083 ! END DO
1084 ! END DO
1086 CALL a_sixth_order_diffusion('w',w,a_w,rw_tendf,a_rw_tendf,mut,a_mut,dt, &
1087 ! Revised by Ning Pan, 2010-07-30
1088 ! config_flags,diff_6th_opt,diff_6th_factor,a_diff_6th_factor,ids,ide,jds,jde,kds, &
1089 config_flags,diff_6th_opt,diff_6th_factor,ids,ide,jds,jde,kds, &
1090 kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1092 END IF
1094 ! Remarked by Ning Pan, 2010-07-30
1095 ! DO IX3=jms,jme
1096 ! DO IX2=kms,kme
1097 ! DO IX1=ims,ime
1098 ! rv_tendf(IX1,IX2,IX3) =Tmpv409(IX1,IX2,IX3)
1099 ! END DO
1100 ! END DO
1101 ! END DO
1103 CALL a_sixth_order_diffusion('v',v,a_v,rv_tendf,a_rv_tendf,mut,a_mut,dt, &
1104 ! Revised by Ning Pan, 2010-07-30
1105 ! config_flags,diff_6th_opt,diff_6th_factor,a_diff_6th_factor,ids,ide,jds,jde,kds, &
1106 config_flags,diff_6th_opt,diff_6th_factor,ids,ide,jds,jde,kds, &
1107 kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1109 ! Remarked by Ning Pan, 2010-07-30
1110 ! DO IX3=jms,jme
1111 ! DO IX2=kms,kme
1112 ! DO IX1=ims,ime
1113 ! ru_tendf(IX1,IX2,IX3) =Tmpv408(IX1,IX2,IX3)
1114 ! END DO
1115 ! END DO
1116 ! END DO
1118 CALL a_sixth_order_diffusion('u',u,a_u,ru_tendf,a_ru_tendf,mut,a_mut,dt, &
1119 ! Revised by Ning Pan, 2010-07-30
1120 ! config_flags,diff_6th_opt,diff_6th_factor,a_diff_6th_factor,ids,ide,jds,jde,kds, &
1121 config_flags,diff_6th_opt,diff_6th_factor,ids,ide,jds,jde,kds, &
1122 kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1124 ENDIF
1126 IF(config_flags%diff_opt .eq. 1) THEN
1128 ! Revised by Ning Pan, 2010-07-30 : reverse the adjoint computation order
1129 ! revise actual arguments
1130 ! remark useless recalculation
1131 IF(config_flags%bl_pbl_physics .eq. 0) THEN
1133 kvdq = 3.*kvdif
1134 CALL a_vertical_diffusion_3dmp(t,a_t,t_tendf,a_t_tendf,config_flags,t_init, &
1135 alt,a_alt,mut,a_mut,rdn,rdnw,kvdq,ids,ide,jds,jde,kds,kde, &
1136 ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1138 IF(non_hydrostatic) THEN
1139 CALL a_vertical_diffusion('w',w,a_w,rw_tendf,a_rw_tendf,config_flags,alt, &
1140 a_alt,mut,a_mut,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
1141 its,ite,jts,jte,kts,kte)
1142 END IF
1144 CALL a_vertical_diffusion_v(v,a_v,rv_tendf,a_rv_tendf,config_flags,v_base, &
1145 alt,a_alt,muv,a_muv,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
1146 kme,its,ite,jts,jte,kts,kte)
1148 CALL a_vertical_diffusion_u(u,a_u,ru_tendf,a_ru_tendf,config_flags,u_base, &
1149 alt,a_alt,muu,a_muu,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
1150 kme,its,ite,jts,jte,kts,kte)
1152 ENDIF
1154 khdq = 3.*khdif
1155 CALL a_horizontal_diffusion_3dmp('m',t,a_t,t_tendf,a_t_tendf,mut,a_mut, &
1156 config_flags,t_init,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdq, &
1157 xkhh,a_xkhh,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
1158 ite,jts,jte,kts,kte)
1160 CALL a_horizontal_diffusion('w',w,a_w,rw_tendf,a_rw_tendf,mut,a_mut, &
1161 config_flags,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdif,xkmhd,a_xkmhd,rdx, &
1162 rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1164 CALL a_horizontal_diffusion('v',v,a_v,rv_tendf,a_rv_tendf,mut,a_mut, &
1165 config_flags,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdif,xkmhd,a_xkmhd,rdx, &
1166 rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1168 CALL a_horizontal_diffusion('u',u,a_u,ru_tendf,a_ru_tendf,mut,a_mut, &
1169 config_flags,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdif,xkmhd,a_xkmhd,rdx, &
1170 rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1172 ! DO IX3=jms,jme
1173 ! DO IX2=kms,kme
1174 ! DO IX1=ims,ime
1175 ! ru_tendf(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
1176 ! END DO
1177 ! END DO
1178 ! END DO
1180 ! CALL a_horizontal_diffusion('u',u,a_u,ru_tendf,a_ru_tendf,mut,a_mut, &
1181 ! config_flags,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdif,xkmhd,a_xkmhd,rdx, &
1182 ! rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1184 ! DO IX3=jms,jme
1185 ! DO IX2=kms,kme
1186 ! DO IX1=ims,ime
1187 ! rv_tendf(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
1188 ! END DO
1189 ! END DO
1190 ! END DO
1192 ! CALL a_horizontal_diffusion('v',v,a_v,rv_tendf,a_rv_tendf,mut,a_mut, &
1193 ! config_flags,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdif,xkmhd,a_xkmhd,rdx, &
1194 ! rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1196 ! DO IX3=jms,jme
1197 ! DO IX2=kms,kme
1198 ! DO IX1=ims,ime
1199 ! rw_tendf(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
1200 ! END DO
1201 ! END DO
1202 ! END DO
1204 ! CALL a_horizontal_diffusion('w',w,a_w,rw_tendf,a_rw_tendf,mut,a_mut, &
1205 ! config_flags,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdif,xkmhd,a_xkmhd,rdx, &
1206 ! rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1207 ! a_khdq =0.0
1209 ! DO IX3=jms,jme
1210 ! DO IX2=kms,kme
1211 ! DO IX1=ims,ime
1212 ! t_tendf(IX1,IX2,IX3) =Tmpv403(IX1,IX2,IX3)
1213 ! END DO
1214 ! END DO
1215 ! END DO
1217 ! CALL a_horizontal_diffusion_3dmp('m',t,a_t,t_tendf,a_t_tendf,mut,a_mut, &
1218 ! config_flags,t_init,a_t_init,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdq, &
1219 ! a_khdq,xkhh,a_xkhh,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
1220 ! ite,jts,jte,kts,kte)
1222 ! IF(config_flags%bl_pbl_physics .eq. 0) THEN
1224 ! DO IX3=jms,jme
1225 ! DO IX2=kms,kme
1226 ! DO IX1=ims,ime
1227 ! ru_tendf(IX1,IX2,IX3) =Tmpv404(IX1,IX2,IX3)
1228 ! END DO
1229 ! END DO
1230 ! END DO
1232 ! CALL a_vertical_diffusion_u(u,a_u,ru_tendf,a_ru_tendf,config_flags,u_base, &
1233 ! alt,a_alt,muu,a_muu,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
1234 ! kme,its,ite,jts,jte,kts,kte)
1236 ! DO IX3=jms,jme
1237 ! DO IX2=kms,kme
1238 ! DO IX1=ims,ime
1239 ! rv_tendf(IX1,IX2,IX3) =Tmpv405(IX1,IX2,IX3)
1240 ! END DO
1241 ! END DO
1242 ! END DO
1244 ! CALL a_vertical_diffusion_v(v,a_v,rv_tendf,a_rv_tendf,config_flags,v_base, &
1245 ! alt,a_alt,muv,a_muv,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
1246 ! kme,its,ite,jts,jte,kts,kte)
1248 ! IF(non_hydrostatic) THEN
1250 ! DO IX3=jms,jme
1251 ! DO IX2=kms,kme
1252 ! DO IX1=ims,ime
1253 ! rw_tendf(IX1,IX2,IX3) =Tmpv406(IX1,IX2,IX3)
1254 ! END DO
1255 ! END DO
1256 ! END DO
1258 ! CALL a_vertical_diffusion('w',w,a_w,rw_tendf,a_rw_tendf,config_flags,alt, &
1259 ! a_alt,mut,a_mut,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
1260 ! its,ite,jts,jte,kts,kte)
1262 ! END IF
1263 ! a_kvdq =0.0
1265 ! DO IX3=jms,jme
1266 ! DO IX2=kms,kme
1267 ! DO IX1=ims,ime
1268 ! t_tendf(IX1,IX2,IX3) =Tmpv407(IX1,IX2,IX3)
1269 ! END DO
1270 ! END DO
1271 ! END DO
1273 ! CALL a_vertical_diffusion_3dmp(t,a_t,t_tendf,a_t_tendf,config_flags,t_init, &
1274 ! a_t_init,alt,a_alt,mut,a_mut,rdn,rdnw,kvdq,a_kvdq,ids,ide,jds,jde,kds,kde, &
1275 ! ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1277 ! ENDIF
1279 END IF
1281 END IF
1283 !LPB[10]
1285 !LPB[9]
1286 ! Remarked by Ning Pan, 2010-07-30
1287 ! DO IX3=jms,jme
1288 ! DO IX2=kms,kme
1289 ! DO IX1=ims,ime
1290 ! ru_tend(IX1,IX2,IX3) =Keep_Lpb9_ru_tend(IX1,IX2,IX3)
1291 ! END DO
1292 ! END DO
1293 ! END DO
1294 ! DO IX3=jms,jme
1295 ! DO IX2=kms,kme
1296 ! DO IX1=ims,ime
1297 ! rv_tend(IX1,IX2,IX3) =Keep_Lpb9_rv_tend(IX1,IX2,IX3)
1298 ! END DO
1299 ! END DO
1300 ! END DO
1302 ! IF(config_flags%ra_lw_physics == HELDSUAREZ) THEN
1303 ! DO IX3=jms,jme
1304 ! DO IX2=kms,kme
1305 ! DO IX1=ims,ime
1306 ! Tmpv400(IX1,IX2,IX3) =ru_tend(IX1,IX2,IX3)
1307 ! END DO
1308 ! END DO
1309 ! END DO
1311 ! DO IX3=jms,jme
1312 ! DO IX2=kms,kme
1313 ! DO IX1=ims,ime
1314 ! Tmpv401(IX1,IX2,IX3) =rv_tend(IX1,IX2,IX3)
1315 ! END DO
1316 ! END DO
1317 ! END DO
1319 ! CALL held_suarez_damp(ru_tend,rv_tend,ru,rv,p,pb,ids,ide,jds,jde,kds,kde,ims,ime, &
1320 ! jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1322 ! END IF
1324 IF(config_flags%ra_lw_physics == HELDSUAREZ) THEN
1326 ! Remarked by Ning Pan, 2010-07-30
1327 ! DO IX3=jms,jme
1328 ! DO IX2=kms,kme
1329 ! DO IX1=ims,ime
1330 ! rv_tend(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
1331 ! END DO
1332 ! END DO
1333 ! END DO
1335 ! DO IX3=jms,jme
1336 ! DO IX2=kms,kme
1337 ! DO IX1=ims,ime
1338 ! ru_tend(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
1339 ! END DO
1340 ! END DO
1341 ! END DO
1343 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1344 !!! Reamarked by Ning Pan, 2010-07-30 : JUST FOR DEBUGGING DYNAMICS OF WRF+ !!!
1345 !!! REMARK SHOULD BE REMOVED WHEN CONSTRUCTING PHYSICS OF WRF+ !!!
1346 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1347 ! CALL a_held_suarez_damp(ru_tend,a_ru_tend,rv_tend,a_rv_tend,ru,a_ru,rv, &
1348 ! a_rv,p,a_p,pb,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1350 END IF
1352 !LPB[8]
1353 ! Remarked by Ning Pan, 2010-07-30
1354 ! DO IX3=jms,jme
1355 ! DO IX2=kms,kme
1356 ! DO IX1=ims,ime
1357 ! ru_tend(IX1,IX2,IX3) =Keep_Lpb8_ru_tend(IX1,IX2,IX3)
1358 ! END DO
1359 ! END DO
1360 ! END DO
1361 ! DO IX3=jms,jme
1362 ! DO IX2=kms,kme
1363 ! DO IX1=ims,ime
1364 ! rv_tend(IX1,IX2,IX3) =Keep_Lpb8_rv_tend(IX1,IX2,IX3)
1365 ! END DO
1366 ! END DO
1367 ! END DO
1368 ! DO IX3=jms,jme
1369 ! DO IX2=kms,kme
1370 ! DO IX1=ims,ime
1371 ! rw_tend(IX1,IX2,IX3) =Keep_Lpb8_rw_tend(IX1,IX2,IX3)
1372 ! END DO
1373 ! END DO
1374 ! END DO
1376 ! DO IX3=jms,jme
1377 ! DO IX2=kms,kme
1378 ! DO IX1=ims,ime
1379 ! Tmpv400(IX1,IX2,IX3) =ru_tend(IX1,IX2,IX3)
1380 ! END DO
1381 ! END DO
1382 ! END DO
1384 ! DO IX3=jms,jme
1385 ! DO IX2=kms,kme
1386 ! DO IX1=ims,ime
1387 ! Tmpv401(IX1,IX2,IX3) =rv_tend(IX1,IX2,IX3)
1388 ! END DO
1389 ! END DO
1390 ! END DO
1392 ! DO IX3=jms,jme
1393 ! DO IX2=kms,kme
1394 ! DO IX1=ims,ime
1395 ! Tmpv402(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
1396 ! END DO
1397 ! END DO
1398 ! END DO
1400 ! CALL curvature(ru,rv,rw,u,v,w,ru_tend,rv_tend,rw_tend,config_flags,msfux,msfuy, &
1401 ! msfvx,msfvy,msftx,msfty,xlat,fnm,fnp,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
1402 ! kms,kme,its,ite,jts,jte,kts,kte)
1404 ! Remarked by Ning Pan, 2010-07-30
1405 ! DO IX3=jms,jme
1406 ! DO IX2=kms,kme
1407 ! DO IX1=ims,ime
1408 ! rw_tend(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
1409 ! END DO
1410 ! END DO
1411 ! END DO
1413 ! DO IX3=jms,jme
1414 ! DO IX2=kms,kme
1415 ! DO IX1=ims,ime
1416 ! rv_tend(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
1417 ! END DO
1418 ! END DO
1419 ! END DO
1421 ! DO IX3=jms,jme
1422 ! DO IX2=kms,kme
1423 ! DO IX1=ims,ime
1424 ! ru_tend(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
1425 ! END DO
1426 ! END DO
1427 ! END DO
1429 CALL a_curvature(ru,a_ru,rv,a_rv,rw,a_rw,u,a_u,v,a_v,w,ru_tend, &
1430 a_ru_tend,rv_tend,a_rv_tend,rw_tend,a_rw_tend,config_flags,msfux,msfuy,msfvx, &
1431 ! Revised by Ning Pan, 2010-07-30
1432 ! msfvy,msftx,msfty,xlat,a_xlat,fnm,fnp,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
1433 msfvy,msftx,msfty,xlat,fnm,fnp,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
1434 jme,kms,kme,its,ite,jts,jte,kts,kte)
1436 !LPB[7]
1437 !! Remarked by Ning Pan, 2010-07-30
1438 !! DO IX3=jms,jme
1439 !! DO IX2=kms,kme
1440 !! DO IX1=ims,ime
1441 !! ru_tend(IX1,IX2,IX3) =Keep_Lpb7_ru_tend(IX1,IX2,IX3)
1442 !! END DO
1443 !! END DO
1444 !! END DO
1445 !! DO IX3=jms,jme
1446 !! DO IX2=kms,kme
1447 !! DO IX1=ims,ime
1448 !! rv_tend(IX1,IX2,IX3) =Keep_Lpb7_rv_tend(IX1,IX2,IX3)
1449 !! END DO
1450 !! END DO
1451 !! END DO
1452 !! DO IX3=jms,jme
1453 !! DO IX2=kms,kme
1454 !! DO IX1=ims,ime
1455 !! rw_tend(IX1,IX2,IX3) =Keep_Lpb7_rw_tend(IX1,IX2,IX3)
1456 !! END DO
1457 !! END DO
1458 !! END DO
1460 !! IF(config_flags%pert_coriolis) THEN
1461 !! DO IX3=jms,jme
1462 !! DO IX2=kms,kme
1463 !! DO IX1=ims,ime
1464 !! Tmpv400(IX1,IX2,IX3) =ru_tend(IX1,IX2,IX3)
1465 !! END DO
1466 !! END DO
1467 !! END DO
1469 !! DO IX3=jms,jme
1470 !! DO IX2=kms,kme
1471 !! DO IX1=ims,ime
1472 !! Tmpv401(IX1,IX2,IX3) =rv_tend(IX1,IX2,IX3)
1473 !! END DO
1474 !! END DO
1475 !! END DO
1477 !! DO IX3=jms,jme
1478 !! DO IX2=kms,kme
1479 !! DO IX1=ims,ime
1480 !! Tmpv402(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
1481 !! END DO
1482 !! END DO
1483 !! END DO
1485 !! CALL perturbation_coriolis(ru,rv,rw,ru_tend,rv_tend,rw_tend,config_flags,u_base, &
1486 !! v_base,z_base,muu,muv,phb,ph,msftx,msfty,msfux,msfuy,msfvx,msfvy,f,e,sina,cosa,fnm, &
1487 !! fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1489 !! ELSE
1490 !! DO IX3=jms,jme
1491 !! DO IX2=kms,kme
1492 !! DO IX1=ims,ime
1493 !! Tmpv403(IX1,IX2,IX3) =ru_tend(IX1,IX2,IX3)
1494 !! END DO
1495 !! END DO
1496 !! END DO
1498 !! DO IX3=jms,jme
1499 !! DO IX2=kms,kme
1500 !! DO IX1=ims,ime
1501 !! Tmpv404(IX1,IX2,IX3) =rv_tend(IX1,IX2,IX3)
1502 !! END DO
1503 !! END DO
1504 !! END DO
1506 !! DO IX3=jms,jme
1507 !! DO IX2=kms,kme
1508 !! DO IX1=ims,ime
1509 !! Tmpv405(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
1510 !! END DO
1511 !! END DO
1512 !! END DO
1514 !! CALL coriolis(ru,rv,rw,ru_tend,rv_tend,rw_tend,config_flags,msftx,msfty,msfux, &
1515 !! msfuy,msfvx,msfvy,f,e,sina,cosa,fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
1516 !! kme,its,ite,jts,jte,kts,kte)
1518 !! END IF
1520 IF(config_flags%pert_coriolis) THEN
1522 !! Remarked by Ning Pan, 2010-07-30
1523 !! DO IX3=jms,jme
1524 !! DO IX2=kms,kme
1525 !! DO IX1=ims,ime
1526 !! rw_tend(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
1527 !! END DO
1528 !! END DO
1529 !! END DO
1531 !! DO IX3=jms,jme
1532 !! DO IX2=kms,kme
1533 !! DO IX1=ims,ime
1534 !! rv_tend(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
1535 !! END DO
1536 !! END DO
1537 !! END DO
1539 !! DO IX3=jms,jme
1540 !! DO IX2=kms,kme
1541 !! DO IX1=ims,ime
1542 !! ru_tend(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
1543 !! END DO
1544 !! END DO
1545 !! END DO
1547 CALL a_perturbation_coriolis(ru,a_ru,rv,a_rv,rw,a_rw,ru_tend,a_ru_tend, &
1548 rv_tend,a_rv_tend,rw_tend,a_rw_tend,config_flags,u_base,v_base,z_base,muu, &
1549 a_muu,muv,a_muv,phb,ph,a_ph,msftx,msfty,msfux,msfuy,msfvx,msfvy,f,e,sina,cosa, &
1550 fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1552 ELSE
1554 !! Remarked by Ning Pan, 2010-07-30
1555 !! DO IX3=jms,jme
1556 !! DO IX2=kms,kme
1557 !! DO IX1=ims,ime
1558 !! rw_tend(IX1,IX2,IX3) =Tmpv405(IX1,IX2,IX3)
1559 !! END DO
1560 !! END DO
1561 !! END DO
1563 !! DO IX3=jms,jme
1564 !! DO IX2=kms,kme
1565 !! DO IX1=ims,ime
1566 !! rv_tend(IX1,IX2,IX3) =Tmpv404(IX1,IX2,IX3)
1567 !! END DO
1568 !! END DO
1569 !! END DO
1571 !! DO IX3=jms,jme
1572 !! DO IX2=kms,kme
1573 !! DO IX1=ims,ime
1574 !! ru_tend(IX1,IX2,IX3) =Tmpv403(IX1,IX2,IX3)
1575 !! END DO
1576 !! END DO
1577 !! END DO
1579 CALL a_coriolis(ru,a_ru,rv,a_rv,rw,a_rw,ru_tend,a_ru_tend,rv_tend, &
1580 a_rv_tend,rw_tend,a_rw_tend,config_flags,msftx,msfty,msfux,msfuy,msfvx,msfvy,f,e, &
1581 sina,cosa,fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1583 END IF
1585 !LPB[6]
1586 !! Remarked by Ning Pan, 2010-07-30
1587 !! DO IX3=jms,jme
1588 !! DO IX2=kms,kme
1589 !! DO IX1=ims,ime
1590 !! rw_tend(IX1,IX2,IX3) =Keep_Lpb6_rw_tend(IX1,IX2,IX3)
1591 !! END DO
1592 !! END DO
1593 !! END DO
1595 !! DO IX3=jms,jme
1596 !! DO IX2=kms,kme
1597 !! DO IX1=ims,ime
1598 !! Tmpv400(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
1599 !! END DO
1600 !! END DO
1601 !! END DO
1603 !! CALL w_damp(rw_tend,max_vert_cfl,max_horiz_cfl,u,v,ww,w,mut,rdnw,rdx,rdy,msfux, &
1604 !! msfuy,msfvx,msfvy,dt,config_flags,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
1605 !! its,ite,jts,jte,kts,kte)
1607 !! Remarked by Ning Pan, 2010-07-30
1608 !! DO IX3=jms,jme
1609 !! DO IX2=kms,kme
1610 !! DO IX1=ims,ime
1611 !! rw_tend(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
1612 !! END DO
1613 !! END DO
1614 !! END DO
1616 ! Revised by Ning Pan, 2010-07-30
1617 ! CALL a_w_damp(rw_tend,a_rw_tend,max_vert_cfl,a_max_vert_cfl,max_horiz_cfl, &
1618 ! a_max_horiz_cfl,u,a_u,v,a_v,ww,a_ww,w,a_w,mut,a_mut,rdnw,rdx,rdy,msfux, &
1619 CALL a_w_damp(rw_tend,a_rw_tend,max_vert_cfl,max_horiz_cfl, &
1620 u,a_u,v,a_v,ww,a_ww,w,a_w,mut,a_mut,rdnw,rdx,rdy,msfux, &
1621 msfuy,msfvx,msfvy,dt,config_flags,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
1622 its,ite,jts,jte,kts,kte)
1624 !LPB[5]
1625 !! Remarked by Ning Pan, 2010-07-30
1626 !! DO IX3=jms,jme
1627 !! DO IX2=kms,kme
1628 !! DO IX1=ims,ime
1629 !! rw_tend(IX1,IX2,IX3) =Keep_Lpb5_rw_tend(IX1,IX2,IX3)
1630 !! END DO
1631 !! END DO
1632 !! END DO
1633 !! DO IX3=jms,jme
1634 !! DO IX2=kms,kme
1635 !! DO IX1=ims,ime
1636 !! cqw(IX1,IX2,IX3) =Keep_Lpb5_cqw(IX1,IX2,IX3)
1637 !! END DO
1638 !! END DO
1639 !! END DO
1641 !! IF(non_hydrostatic) THEN
1642 !! DO IX3=jms,jme
1643 !! DO IX2=kms,kme
1644 !! DO IX1=ims,ime
1645 !! Tmpv400(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
1646 !! END DO
1647 !! END DO
1648 !! END DO
1650 !! DO IX3=jms,jme
1651 !! DO IX2=kms,kme
1652 !! DO IX1=ims,ime
1653 !! Tmpv401(IX1,IX2,IX3) =cqw(IX1,IX2,IX3)
1654 !! END DO
1655 !! END DO
1656 !! END DO
1658 !! CALL pg_buoy_w(rw_tend,p,cqw,mu,mub,rdnw,rdn,g,msftx,msfty,ids,ide,jds,jde,kds, &
1659 !! kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1661 !! ENDIF
1663 IF(non_hydrostatic) THEN
1665 ! Remarked by Ning Pan, 2010-07-30
1666 ! Const_A0=g
1667 ! Const_Diff_A0=0.0
1669 ! DO IX3=jms,jme
1670 ! DO IX2=kms,kme
1671 ! DO IX1=ims,ime
1672 ! cqw(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
1673 ! END DO
1674 ! END DO
1675 ! END DO
1677 ! DO IX3=jms,jme
1678 ! DO IX2=kms,kme
1679 ! DO IX1=ims,ime
1680 ! rw_tend(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
1681 ! END DO
1682 ! END DO
1683 CALL a_pg_buoy_w(rw_tend,a_rw_tend,p,a_p,cqw,a_cqw,mu,a_mu,mub,rdnw,rdn, &
1684 g,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1685 ! END DO ! Remarked by Ning Pan, 2010-07-30
1687 ENDIF
1689 !LPB[4]
1690 !! Remarked by Ning Pan, 2010-07-30
1691 !! DO IX3=jms,jme
1692 !! DO IX2=kms,kme
1693 !! DO IX1=ims,ime
1694 !! ph_tend(IX1,IX2,IX3) =Keep_Lpb4_ph_tend(IX1,IX2,IX3)
1695 !! END DO
1696 !! END DO
1697 !! END DO
1698 !! DO IX3=jms,jme
1699 !! DO IX2=kms,kme
1700 !! DO IX1=ims,ime
1701 !! ru_tend(IX1,IX2,IX3) =Keep_Lpb4_ru_tend(IX1,IX2,IX3)
1702 !! END DO
1703 !! END DO
1704 !! END DO
1705 !! DO IX3=jms,jme
1706 !! DO IX2=kms,kme
1707 !! DO IX1=ims,ime
1708 !! rv_tend(IX1,IX2,IX3) =Keep_Lpb4_rv_tend(IX1,IX2,IX3)
1709 !! END DO
1710 !! END DO
1711 !! END DO
1713 !! DO IX3=jms,jme
1714 !! DO IX2=kms,kme
1715 !! DO IX1=ims,ime
1716 !! Tmpv400(IX1,IX2,IX3) =ph_tend(IX1,IX2,IX3)
1717 !! END DO
1718 !! END DO
1719 !! END DO
1721 !! CALL rhs_ph(ph_tend,u,v,ww,ph,ph,phb,w,mut,muu,muv,fnm,fnp,rdnw,cfn,cfn1,rdx,rdy, &
1722 !! msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,non_hydrostatic,config_flags,ids,ide, &
1723 !! jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1725 !! DO IX3=jms,jme
1726 !! DO IX2=kms,kme
1727 !! DO IX1=ims,ime
1728 !! Tmpv401(IX1,IX2,IX3) =ru_tend(IX1,IX2,IX3)
1729 !! END DO
1730 !! END DO
1731 !! END DO
1733 !! DO IX3=jms,jme
1734 !! DO IX2=kms,kme
1735 !! DO IX1=ims,ime
1736 !! Tmpv402(IX1,IX2,IX3) =rv_tend(IX1,IX2,IX3)
1737 !! END DO
1738 !! END DO
1739 !! END DO
1741 !! CALL horizontal_pressure_gradient(ru_tend,rv_tend,ph,alt,p,pb,al,php,cqu,cqv,muu, &
1742 !! muv,mu,fnm,fnp,rdnw,cf1,cf2,cf3,cfn,cfn1,rdx,rdy,msfux,msfuy,msfvx,msfvy,msftx,msfty, &
1743 !! config_flags,non_hydrostatic,top_lid,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
1744 !! its,ite,jts,jte,kts,kte)
1746 !! DO IX3=jms,jme
1747 !! DO IX2=kms,kme
1748 !! DO IX1=ims,ime
1749 !! rv_tend(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
1750 !! END DO
1751 !! END DO
1752 !! END DO
1754 !! DO IX3=jms,jme
1755 !! DO IX2=kms,kme
1756 !! DO IX1=ims,ime
1757 !! ru_tend(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
1758 !! END DO
1759 !! END DO
1760 !! END DO
1762 CALL a_horizontal_pressure_gradient(ru_tend,a_ru_tend,rv_tend,a_rv_tend,ph, &
1763 a_ph,alt,a_alt,p,a_p,pb,al,a_al,php,a_php,cqu,a_cqu,cqv,a_cqv,muu, &
1764 a_muu,muv,a_muv,mu,a_mu,fnm,fnp,rdnw,cf1,cf2,cf3,cfn,cfn1,rdx,rdy,msfux,msfuy,msfvx, &
1765 ! Revised by Ning Pan, 2010-07-30
1766 ! msfvy,msftx,msfty,config_flags,,,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
1767 msfvy,msftx,msfty,config_flags,non_hydrostatic,top_lid,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
1768 ite,jts,jte,kts,kte)
1770 !! Remarked by Ning Pan, 2010-07-30
1771 !! DO IX3=jms,jme
1772 !! DO IX2=kms,kme
1773 !! DO IX1=ims,ime
1774 !! ph_tend(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
1775 !! END DO
1776 !! END DO
1777 !! END DO
1779 CALL a_rhs_ph(ph_tend,a_ph_tend,u,a_u,v,a_v,ww,a_ww,ph,a_ph,ph,a_ph, &
1780 phb,w,a_w,mut,a_mut,muu,a_muu,muv,a_muv,fnm,fnp,rdnw,cfn,cfn1,rdx,rdy,msfux, &
1781 ! Remarked by Ning Pan, 2010-07-30
1782 ! msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,,config_flags,ids,ide,jds,jde,kds,kde,ims, &
1783 msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,non_hydrostatic,config_flags,ids,ide,jds,jde,kds,kde,ims, &
1784 ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1786 !LPB[3]
1788 !! IF( config_flags%cu_physics == GDSCHEME .OR. config_flags%cu_physics == G3SCHEME ) THEN
1789 !! CALL set_tend(RTHFTEN,t_tend,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
1790 !! kme,its,ite,jts,jte,kts,kte)
1792 !! END IF
1794 IF( config_flags%cu_physics == GDSCHEME .OR. &
1795 config_flags%cu_physics == G3SCHEME .OR. &
1796 config_flags%cu_physics == NTIEDTKESCHEME ) THEN
1798 CALL a_set_tend(RTHFTEN,a_RTHFTEN,t_tend,a_t_tend,msfty,ids,ide,jds,jde,kds, &
1799 kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1801 END IF
1803 !LPB[2]
1804 !! Remarked by Ning Pan, 2010-07-30
1805 !! DO IX3=jms,jme
1806 !! DO IX2=kms,kme
1807 !! DO IX1=ims,ime
1808 !! t(IX1,IX2,IX3) =Keep_Lpb2_t(IX1,IX2,IX3)
1809 !! END DO
1810 !! END DO
1811 !! END DO
1812 !! DO IX3=jms,jme
1813 !! DO IX2=kms,kme
1814 !! DO IX1=ims,ime
1815 !! t_tend(IX1,IX2,IX3) =Keep_Lpb2_t_tend(IX1,IX2,IX3)
1816 !! END DO
1817 !! END DO
1818 !! END DO
1819 !! DO IX3=jms,jme
1820 !! DO IX2=kms,kme
1821 !! DO IX1=ims,ime
1822 !! ru(IX1,IX2,IX3) =Keep_Lpb2_ru(IX1,IX2,IX3)
1823 !! END DO
1824 !! END DO
1825 !! END DO
1826 !! DO IX3=jms,jme
1827 !! DO IX2=kms,kme
1828 !! DO IX1=ims,ime
1829 !! rv(IX1,IX2,IX3) =Keep_Lpb2_rv(IX1,IX2,IX3)
1830 !! END DO
1831 !! END DO
1832 !! END DO
1834 !! DO IX3=jms,jme
1835 !! DO IX2=kms,kme
1836 !! DO IX1=ims,ime
1837 !! Tmpv400(IX1,IX2,IX3) =t(IX1,IX2,IX3)
1838 !! END DO
1839 !! END DO
1840 !! END DO
1842 !! DO IX3=jms,jme
1843 !! DO IX2=kms,kme
1844 !! DO IX1=ims,ime
1845 !! Tmpv401(IX1,IX2,IX3) =t_tend(IX1,IX2,IX3)
1846 !! END DO
1847 !! END DO
1848 !! END DO
1850 !! DO IX3=jms,jme
1851 !! DO IX2=kms,kme
1852 !! DO IX1=ims,ime
1853 !! Tmpv402(IX1,IX2,IX3) =ru(IX1,IX2,IX3)
1854 !! END DO
1855 !! END DO
1856 !! END DO
1858 !! DO IX3=jms,jme
1859 !! DO IX2=kms,kme
1860 !! DO IX1=ims,ime
1861 !! Tmpv403(IX1,IX2,IX3) =rv(IX1,IX2,IX3)
1862 !! END DO
1863 !! END DO
1864 !! END DO
1866 !! CALL advect_scalar(t,t,t_tend,ru,rv,ww,mut,time_step,config_flags,msfux,msfuy, &
1867 !! msfvx,msfvy,msftx,msfty,fnm,fnp,rdx,rdy,rdnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
1868 !! kms,kme,its,ite,jts,jte,kts,kte)
1870 !! Remarked by Ning Pan, 2010-07-30
1871 !! DO IX3=jms,jme
1872 !! DO IX2=kms,kme
1873 !! DO IX1=ims,ime
1874 !! rv(IX1,IX2,IX3) =Tmpv403(IX1,IX2,IX3)
1875 !! END DO
1876 !! END DO
1877 !! END DO
1879 !! DO IX3=jms,jme
1880 !! DO IX2=kms,kme
1881 !! DO IX1=ims,ime
1882 !! ru(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
1883 !! END DO
1884 !! END DO
1885 !! END DO
1887 !! DO IX3=jms,jme
1888 !! DO IX2=kms,kme
1889 !! DO IX1=ims,ime
1890 !! t_tend(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
1891 !! END DO
1892 !! END DO
1893 !! END DO
1895 !! DO IX3=jms,jme
1896 !! DO IX2=kms,kme
1897 !! DO IX1=ims,ime
1898 !! t(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
1899 !! END DO
1900 !! END DO
1901 !! END DO
1903 !hcl 11/2016 ERM: Use WENO for theta flux on 3rd RK step if using WENO_SCALAR or WENOPD_SCALAR
1904 ! to be consistent with other scalar fluxes
1905 IF( ( config_flags%scalar_adv_opt == WENO_SCALAR &
1906 .or. config_flags%scalar_adv_opt == WENOPD_SCALAR &
1907 .or. config_flags%moist_adv_opt == WENO_SCALAR &
1908 .or. config_flags%moist_adv_opt == WENOPD_SCALAR &
1909 ) .and. (rk_step == 3) ) THEN
1911 CALL a_advect_scalar_weno(t,a_t,t,a_t,t_tend,a_t_tend,ru,a_ru,rv,a_rv,ww, &
1912 a_ww,mut,time_step,config_flags,msfux,msfuy,msfvx,msfvy,msftx,msfty,fnm, &
1913 fnp,rdx,rdy,rdnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1915 ELSE
1917 CALL a_advect_scalar(t,a_t,t,a_t,t_tend,a_t_tend,ru,a_ru,rv,a_rv,ww, &
1918 a_ww,mut,time_step,config_flags,msfux,msfuy,msfvx,msfvy,msftx,msfty,fnm, &
1919 fnp,rdx,rdy,rdnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1921 ENDIF
1923 !LPB[1]
1924 !! Remarked by Ning Pan, 2010-07-30
1925 !! DO IX3=jms,jme
1926 !! DO IX2=kms,kme
1927 !! DO IX1=ims,ime
1928 !! w(IX1,IX2,IX3) =Keep_Lpb1_w(IX1,IX2,IX3)
1929 !! END DO
1930 !! END DO
1931 !! END DO
1932 !! DO IX3=jms,jme
1933 !! DO IX2=kms,kme
1934 !! DO IX1=ims,ime
1935 !! rw_tend(IX1,IX2,IX3) =Keep_Lpb1_rw_tend(IX1,IX2,IX3)
1936 !! END DO
1937 !! END DO
1938 !! END DO
1940 !! IF(non_hydrostatic) THEN
1941 !! DO IX3=jms,jme
1942 !! DO IX2=kms,kme
1943 !! DO IX1=ims,ime
1944 !! Tmpv400(IX1,IX2,IX3) =w(IX1,IX2,IX3)
1945 !! END DO
1946 !! END DO
1947 !! END DO
1949 !! DO IX3=jms,jme
1950 !! DO IX2=kms,kme
1951 !! DO IX1=ims,ime
1952 !! Tmpv401(IX1,IX2,IX3) =rw_tend(IX1,IX2,IX3)
1953 !! END DO
1954 !! END DO
1955 !! END DO
1957 !! CALL advect_w(w,w,rw_tend,ru,rv,ww,mut,time_step,config_flags,msfux,msfuy,msfvx, &
1958 !! msfvy,msftx,msfty,fnm,fnp,rdx,rdy,rdn,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
1959 !! kme,its,ite,jts,jte,kts,kte)
1961 !! END IF
1963 IF(non_hydrostatic) THEN
1965 !! Remarked by Ning Pan, 2010-07-30
1966 !! DO IX3=jms,jme
1967 !! DO IX2=kms,kme
1968 !! DO IX1=ims,ime
1969 !! rw_tend(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
1970 !! END DO
1971 !! END DO
1972 !! END DO
1974 !! DO IX3=jms,jme
1975 !! DO IX2=kms,kme
1976 !! DO IX1=ims,ime
1977 !! w(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
1978 !! END DO
1979 !! END DO
1980 !! END DO
1982 IF( (rk_step == 3) .and. ( adv_opt == WENO_MOM ) ) THEN
1983 CALL a_advect_weno_w ( w, a_w, w, a_w, rw_tend, a_rw_tend, &
1984 ru, a_ru, rv, a_rv, ww, a_ww, &
1985 mut, time_step, config_flags, &
1986 msfux, msfuy, msfvx, msfvy, &
1987 msftx, msfty, &
1988 fnm, fnp, rdx, rdy, rdn, &
1989 ids, ide, jds, jde, kds, kde, &
1990 ims, ime, jms, jme, kms, kme, &
1991 its, ite, jts, jte, kts, kte )
1993 ELSE
1995 CALL a_advect_w(w,a_w,w,a_w,rw_tend,a_rw_tend,ru,a_ru,rv,a_rv,ww, &
1996 a_ww,mut,time_step,config_flags,msfux,msfuy,msfvx,msfvy,msftx,msfty,fnm, &
1997 fnp,rdx,rdy,rdn,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1999 END IF
2001 END IF
2003 !LPB[0]
2004 !! Remarked by Ning Pan, 2010-07-30
2005 !! DO IX3=jms,jme
2006 !! DO IX2=kms,kme
2007 !! DO IX1=ims,ime
2008 !! u(IX1,IX2,IX3) =Keep_Lpb0_u(IX1,IX2,IX3)
2009 !! END DO
2010 !! END DO
2011 !! END DO
2012 !! DO IX3=jms,jme
2013 !! DO IX2=kms,kme
2014 !! DO IX1=ims,ime
2015 !! v(IX1,IX2,IX3) =Keep_Lpb0_v(IX1,IX2,IX3)
2016 !! END DO
2017 !! END DO
2018 !! END DO
2020 !! CALL zero_tend(ru_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
2021 !! jts,jte,kts,kte)
2023 !! CALL zero_tend(rv_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
2024 !! jts,jte,kts,kte)
2026 !! CALL zero_tend(rw_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
2027 !! jts,jte,kts,kte)
2029 !! CALL zero_tend(t_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
2030 !! jte,kts,kte)
2032 !! CALL zero_tend(ph_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
2033 !! jts,jte,kts,kte)
2035 !! CALL zero_tend(u_save,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
2036 !! jte,kts,kte)
2038 !! CALL zero_tend(v_save,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
2039 !! jte,kts,kte)
2041 !! CALL zero_tend(w_save,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
2042 !! jte,kts,kte)
2044 !! CALL zero_tend(ph_save,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
2045 !! jts,jte,kts,kte)
2047 !! CALL zero_tend(t_save,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
2048 !! jte,kts,kte)
2050 !! CALL zero_tend(mu_tend,ids,ide,jds,jde,1,1,ims,ime,jms,jme,1,1,its,ite,jts,jte,1,1)
2052 !! CALL zero_tend(mu_save,ids,ide,jds,jde,1,1,ims,ime,jms,jme,1,1,its,ite,jts,jte,1,1)
2054 !! DO IX3=jms,jme
2055 !! DO IX2=kms,kme
2056 !! DO IX1=ims,ime
2057 !! Tmpv400(IX1,IX2,IX3) =u(IX1,IX2,IX3)
2058 !! END DO
2059 !! END DO
2060 !! END DO
2062 !! DO IX3=jms,jme
2063 !! DO IX2=kms,kme
2064 !! DO IX1=ims,ime
2065 !! Tmpv401(IX1,IX2,IX3) =ru_tend(IX1,IX2,IX3)
2066 !! END DO
2067 !! END DO
2068 !! END DO
2070 !! CALL advect_u(u,u,ru_tend,ru,rv,ww,mut,time_step,config_flags,msfux,msfuy,msfvx, &
2071 !! msfvy,msftx,msfty,fnm,fnp,rdx,rdy,rdnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
2072 !! kme,its,ite,jts,jte,kts,kte)
2074 !! DO IX3=jms,jme
2075 !! DO IX2=kms,kme
2076 !! DO IX1=ims,ime
2077 !! Tmpv402(IX1,IX2,IX3) =v(IX1,IX2,IX3)
2078 !! END DO
2079 !! END DO
2080 !! END DO
2082 !! CALL advect_v(v,v,rv_tend,ru,rv,ww,mut,time_step,config_flags,msfux,msfuy,msfvx, &
2083 !! msfvy,msftx,msfty,fnm,fnp,rdx,rdy,rdnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
2084 !! kme,its,ite,jts,jte,kts,kte)
2086 !! DO IX3=jms,jme
2087 !! DO IX2=kms,kme
2088 !! DO IX1=ims,ime
2089 !! v(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
2090 !! END DO
2091 !! END DO
2092 !! END DO
2094 IF( (rk_step == 3) .and. ( adv_opt == WENO_MOM ) ) THEN
2096 CALL a_advect_weno_v ( v, a_v, v, a_v, rv_tend, a_rv_tend, &
2097 ru, a_ru, rv, a_rv, ww, a_ww, &
2098 mut, a_mut, time_step, config_flags, &
2099 msfux, msfuy, msfvx, msfvy, &
2100 msftx, msfty, &
2101 fnm, fnp, rdx, rdy, rdnw, &
2102 ids, ide, jds, jde, kds, kde, &
2103 ims, ime, jms, jme, kms, kme, &
2104 its, ite, jts, jte, kts, kte )
2106 ELSE
2108 CALL a_advect_v(v,a_v,v,a_v,rv_tend,a_rv_tend,ru,a_ru,rv,a_rv,ww, &
2109 a_ww,mut,a_mut,time_step,config_flags,msfux,msfuy,msfvx,msfvy,msftx,msfty,fnm, &
2110 fnp,rdx,rdy,rdnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2112 ENDIF
2114 !! Remarked by Ning Pan, 2010-07-30
2115 !! DO IX3=jms,jme
2116 !! DO IX2=kms,kme
2117 !! DO IX1=ims,ime
2118 !! ru_tend(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
2119 !! END DO
2120 !! END DO
2121 !! END DO
2123 !! DO IX3=jms,jme
2124 !! DO IX2=kms,kme
2125 !! DO IX1=ims,ime
2126 !! u(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
2127 !! END DO
2128 !! END DO
2129 !! END DO
2132 IF( (rk_step == 3) .and. ( adv_opt == WENO_MOM ) ) THEN
2134 CALL a_advect_weno_u ( u, a_u, u, a_u, ru_tend, a_ru_tend, &
2135 ru, a_ru, rv, a_rv, ww, a_ww, &
2136 mut, a_mut, time_step, config_flags, &
2137 msfux, msfuy, msfvx, msfvy, &
2138 msftx, msfty, &
2139 fnm, fnp, rdx, rdy, rdnw, &
2140 ids, ide, jds, jde, kds, kde, &
2141 ims, ime, jms, jme, kms, kme, &
2142 its, ite, jts, jte, kts, kte )
2143 ELSE
2145 CALL a_advect_u(u,a_u,u,a_u,ru_tend,a_ru_tend,ru,a_ru,rv,a_rv,ww, &
2146 a_ww,mut,a_mut,time_step,config_flags,msfux,msfuy,msfvx,msfvy,msftx,msfty,fnm, &
2147 fnp,rdx,rdy,rdnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2149 ENDIF
2151 ! Added by Ning Pan, 2010-07-30
2152 CALL a_zero_tend2d(a_mu_save,ids,ide,jds,jde,1,1,ims,ime,jms,jme,1,1, &
2153 its,ite,jts,jte,1,1)
2154 CALL a_zero_tend2d(a_mu_tend,ids,ide,jds,jde,1,1,ims,ime,jms,jme,1,1, &
2155 its,ite,jts,jte,1,1)
2156 CALL a_zero_tend(a_t_save,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
2157 kme,its,ite,jts,jte,kts,kte)
2158 CALL a_zero_tend(a_ph_save,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2159 kms,kme,its,ite,jts,jte,kts,kte)
2160 CALL a_zero_tend(a_w_save,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
2161 kme,its,ite,jts,jte,kts,kte)
2162 CALL a_zero_tend(a_v_save,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
2163 kme,its,ite,jts,jte,kts,kte)
2164 CALL a_zero_tend(a_u_save,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
2165 kme,its,ite,jts,jte,kts,kte)
2166 CALL a_zero_tend(a_ph_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2167 kms,kme,its,ite,jts,jte,kts,kte)
2168 CALL a_zero_tend(a_t_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
2169 kme,its,ite,jts,jte,kts,kte)
2170 CALL a_zero_tend(a_rw_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2171 kms,kme,its,ite,jts,jte,kts,kte)
2172 CALL a_zero_tend(a_rv_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2173 kms,kme,its,ite,jts,jte,kts,kte)
2174 CALL a_zero_tend(a_ru_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2175 kms,kme,its,ite,jts,jte,kts,kte)
2177 END SUBROUTINE a_rk_tendency
2179 !-------------------------------------------------------------------------------
2181 ! Generated by TAPENADE (INRIA, Tropics team)
2182 ! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
2183 !
2184 ! Differentiation of rk_addtend_dry in reverse (adjoint) mode:
2185 ! gradient of useful results: ph_tendf rw_tendf u_save ph_save
2186 ! w_save mu_tend rv_tendf ru_tend rw_tend h_diabatic
2187 ! ru_tendf t_tend mu_tendf t_save v_save rv_tend
2188 ! t_tendf mut ph_tend
2189 ! with respect to varying inputs: ph_tendf rw_tendf u_save ph_save
2190 ! w_save mu_tend rv_tendf ru_tend rw_tend h_diabatic
2191 ! ru_tendf t_tend mu_tendf t_save v_save rv_tend
2192 ! t_tendf mut ph_tend
2193 ! RW status of diff variables: ph_tendf:in-out rw_tendf:in-out
2194 ! u_save:incr ph_save:incr w_save:incr mu_tend:in-out
2195 ! rv_tendf:in-out ru_tend:in-out rw_tend:in-out
2196 ! h_diabatic:incr ru_tendf:in-out t_tend:in-out
2197 ! mu_tendf:incr t_save:incr v_save:incr rv_tend:in-out
2198 ! t_tendf:in-out mut:incr ph_tend:in-out
2199 SUBROUTINE A_RK_ADDTEND_DRY(ru_tend, ru_tendb, rv_tend, rv_tendb, &
2200 & rw_tend, rw_tendb, ph_tend, ph_tendb, t_tend, t_tendb, ru_tendf, &
2201 & ru_tendfb, rv_tendf, rv_tendfb, rw_tendf, rw_tendfb, ph_tendf, &
2202 & ph_tendfb, t_tendf, t_tendfb, u_save, u_saveb, v_save, v_saveb, w_save&
2203 & , w_saveb, ph_save, ph_saveb, t_save, t_saveb, mu_tend, mu_tendb, &
2204 & mu_tendf, mu_tendfb, rk_step, h_diabatic, h_diabaticb, mut, mutb, &
2205 & msftx, msfty, msfux, msfuy, msfvx, msfvx_inv, msfvy, ids, ide, jds, &
2206 & jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, &
2207 & kpe, its, ite, jts, jte, kts, kte)
2208 IMPLICIT NONE
2209 ! Input data.
2210 INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
2211 & jme, kms, kme, ips, ipe, jps, jpe, kps, kpe, its, ite, jts, jte, kts, &
2212 & kte
2213 INTEGER, INTENT(IN) :: rk_step
2214 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tend, &
2215 & rv_tend, rw_tend, ph_tend, t_tend, ru_tendf, rv_tendf, rw_tendf, &
2216 & ph_tendf, t_tendf
2217 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: ru_tendb, rv_tendb, &
2218 & rw_tendb, ph_tendb, t_tendb, ru_tendfb, rv_tendfb, rw_tendfb, &
2219 & ph_tendfb, t_tendfb
2220 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: mu_tend, mu_tendf
2221 REAL, DIMENSION(ims:ime, jms:jme) :: mu_tendb, mu_tendfb
2222 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u_save, &
2223 & v_save, w_save, ph_save, t_save, h_diabatic
2224 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: u_saveb, v_saveb, &
2225 & w_saveb, ph_saveb, t_saveb, h_diabaticb
2226 REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut, msftx, msfty, &
2227 & msfux, msfuy, msfvx, msfvx_inv, msfvy
2228 REAL, DIMENSION(ims:ime, jms:jme) :: mutb
2229 ! Local
2230 INTEGER :: i, j, k
2231 INTEGER :: branch
2232 INTEGER :: ad_to
2233 INTEGER :: ad_to0
2234 INTEGER :: ad_to1
2235 INTEGER :: ad_to2
2236 INTEGER :: min8
2237 INTEGER :: min7
2238 INTEGER :: min6
2239 INTEGER :: min5
2240 INTEGER :: min4
2241 INTEGER :: min3
2242 INTEGER :: min2
2243 INTEGER :: min1
2244 IF (jte .GT. jde - 1) THEN
2245 min1 = jde - 1
2246 ELSE
2247 min1 = jte
2248 END IF
2249 !<DESCRIPTION>
2250 !
2251 ! rk_addtend_dry constructs the full large-timestep tendency terms for
2252 ! momentum (u,v,w), theta and geopotential equations. This is accomplished
2253 ! by combining the physics tendencies (in *tendf; these are computed
2254 ! the first RK substep, held fixed thereafter) with the RK tendencies
2255 ! (in *tend, these include advection, pressure gradient, etc;
2256 ! these change each rk substep). Output is in *tend.
2257 !
2258 !</DESCRIPTION>
2259 ! Finally, add the forward-step tendency to the rk_tendency
2260 ! u/v/w/save contain bc tendency that needs to be multiplied by msf
2261 ! (u by msfuy, v by msfvx)
2262 ! before adding it to physics tendency (*tendf)
2263 ! For momentum we need the final tendency to include an inverse msf
2264 ! physics/bc tendency needs to be divided, advection tendency already has it
2265 ! For scalars we need the final tendency to include an inverse msf (msfty)
2266 ! advection tendency is OK, physics/bc tendency needs to be divided by msf
2267 DO j=jts,min1
2268 DO k=kts,kte-1
2269 DO i=its,ite
2270 ! multiply by my to uncouple u
2271 IF (rk_step .EQ. 1) THEN
2272 CALL PUSHCONTROL1B(0)
2273 ELSE
2274 CALL PUSHCONTROL1B(1)
2275 END IF
2276 END DO
2277 END DO
2278 END DO
2279 DO j=jts,jte
2280 DO k=kts,kte-1
2281 IF (ite .GT. ide - 1) THEN
2282 min2 = ide - 1
2283 ELSE
2284 min2 = ite
2285 END IF
2286 DO i=its,min2
2287 ! multiply by mx to uncouple v
2288 IF (rk_step .EQ. 1) THEN
2289 CALL PUSHCONTROL1B(0)
2290 ELSE
2291 CALL PUSHCONTROL1B(1)
2292 END IF
2293 END DO
2294 CALL PUSHINTEGER4(i - 1)
2295 END DO
2296 END DO
2297 IF (jte .GT. jde - 1) THEN
2298 min3 = jde - 1
2299 ELSE
2300 min3 = jte
2301 END IF
2302 DO j=jts,min3
2303 DO k=kts,kte
2304 IF (ite .GT. ide - 1) THEN
2305 min4 = ide - 1
2306 ELSE
2307 min4 = ite
2308 END IF
2309 DO i=its,min4
2310 ! multiply by my to uncouple w
2311 IF (rk_step .EQ. 1) THEN
2312 CALL PUSHCONTROL1B(0)
2313 ELSE
2314 CALL PUSHCONTROL1B(1)
2315 END IF
2316 ! divide by my to couple w
2317 IF (rk_step .EQ. 1) THEN
2318 CALL PUSHCONTROL1B(0)
2319 ELSE
2320 CALL PUSHCONTROL1B(1)
2321 END IF
2322 END DO
2323 CALL PUSHINTEGER4(i - 1)
2324 END DO
2325 END DO
2326 IF (jte .GT. jde - 1) THEN
2327 min5 = jde - 1
2328 ELSE
2329 min5 = jte
2330 END IF
2331 DO j=jts,min5
2332 DO k=kts,kte-1
2333 IF (ite .GT. ide - 1) THEN
2334 min6 = ide - 1
2335 ELSE
2336 min6 = ite
2337 END IF
2338 DO i=its,min6
2339 IF (rk_step .EQ. 1) THEN
2340 CALL PUSHCONTROL1B(0)
2341 ELSE
2342 CALL PUSHCONTROL1B(1)
2343 END IF
2344 END DO
2345 CALL PUSHINTEGER4(i - 1)
2346 END DO
2347 END DO
2348 IF (jte .GT. jde - 1) THEN
2349 min7 = jde - 1
2350 ELSE
2351 min7 = jte
2352 END IF
2353 ! divide by my to couple heating
2354 DO j=jts,min7
2355 IF (ite .GT. ide - 1) THEN
2356 min8 = ide - 1
2357 ELSE
2358 min8 = ite
2359 END IF
2360 i = min8 + 1
2361 CALL PUSHINTEGER4(i - 1)
2362 END DO
2363 DO j=min7,jts,-1
2364 CALL POPINTEGER4(ad_to2)
2365 DO i=ad_to2,its,-1
2366 mu_tendfb(i, j) = mu_tendfb(i, j) + mu_tendb(i, j)
2367 END DO
2368 END DO
2369 DO j=min5,jts,-1
2370 DO k=kte-1,kts,-1
2371 CALL POPINTEGER4(ad_to1)
2372 DO i=ad_to1,its,-1
2373 t_tendfb(i, k, j) = t_tendfb(i, k, j) + t_tendb(i, k, j)/msfty(i&
2374 & , j)
2375 h_diabaticb(i, k, j) = h_diabaticb(i, k, j) + mut(i, j)*t_tendb(&
2376 & i, k, j)/msfty(i, j)
2377 mutb(i, j) = mutb(i, j) + h_diabatic(i, k, j)*t_tendb(i, k, j)/&
2378 & msfty(i, j)
2379 CALL POPCONTROL1B(branch)
2380 IF (branch .EQ. 0) t_saveb(i, k, j) = t_saveb(i, k, j) + &
2381 & t_tendfb(i, k, j)
2382 END DO
2383 END DO
2384 END DO
2385 DO j=min3,jts,-1
2386 DO k=kte,kts,-1
2387 CALL POPINTEGER4(ad_to0)
2388 DO i=ad_to0,its,-1
2389 ph_tendfb(i, k, j) = ph_tendfb(i, k, j) + ph_tendb(i, k, j)/&
2390 & msfty(i, j)
2391 CALL POPCONTROL1B(branch)
2392 IF (branch .EQ. 0) ph_saveb(i, k, j) = ph_saveb(i, k, j) + &
2393 & ph_tendfb(i, k, j)
2394 rw_tendfb(i, k, j) = rw_tendfb(i, k, j) + rw_tendb(i, k, j)/&
2395 & msfty(i, j)
2396 CALL POPCONTROL1B(branch)
2397 IF (branch .EQ. 0) w_saveb(i, k, j) = w_saveb(i, k, j) + msfty(i&
2398 & , j)*rw_tendfb(i, k, j)
2399 END DO
2400 END DO
2401 END DO
2402 DO j=jte,jts,-1
2403 DO k=kte-1,kts,-1
2404 CALL POPINTEGER4(ad_to)
2405 DO i=ad_to,its,-1
2406 rv_tendfb(i, k, j) = rv_tendfb(i, k, j) + msfvx_inv(i, j)*&
2407 & rv_tendb(i, k, j)
2408 CALL POPCONTROL1B(branch)
2409 IF (branch .EQ. 0) v_saveb(i, k, j) = v_saveb(i, k, j) + msfvx(i&
2410 & , j)*rv_tendfb(i, k, j)
2411 END DO
2412 END DO
2413 END DO
2414 DO j=min1,jts,-1
2415 DO k=kte-1,kts,-1
2416 DO i=ite,its,-1
2417 ru_tendfb(i, k, j) = ru_tendfb(i, k, j) + ru_tendb(i, k, j)/&
2418 & msfuy(i, j)
2419 CALL POPCONTROL1B(branch)
2420 IF (branch .EQ. 0) u_saveb(i, k, j) = u_saveb(i, k, j) + msfuy(i&
2421 & , j)*ru_tendfb(i, k, j)
2422 END DO
2423 END DO
2424 END DO
2425 END SUBROUTINE A_RK_ADDTEND_DRY
2426 !-------------------------------------------------------------------------------
2428 ! Revised by Ning Pan, 2010-08-02
2429 ! SUBROUTINE a_rk_scalar_tend(scs,sce,config_flags,rk_step,dt,a_dt,ru,a_ru,rv, &
2430 SUBROUTINE a_rk_scalar_tend(scs,sce,config_flags,tenddec,rk_step,dt,ru,a_ru,rv, &
2431 a_rv,ww,a_ww,mut,a_mut,mub,mu_old,a_mu_old,alt,a_alt,scalar_old, &
2432 a_scalar_old,scalar,a_scalar,scalar_tends,a_scalar_tends,advect_tend, &
2433 a_advect_tend,h_tendency,a_h_tendency,z_tendency,a_z_tendency, &
2434 RQVFTEN,a_RQVFTEN,base,moist_step,fnm,fnp,msfux,msfuy,msfvx, &
2435 msfvx_inv,msfvy,msftx,msfty,rdx,rdy,rdn,rdnw,khdif,kvdif,xkmhd,a_xkmhd, &
2436 ! Revised by Ning Pan, 2010-08-02
2437 ! diff_6th_opt,diff_6th_factor,a_diff_6th_factor,adv_opt,ids,ide,jds,jde,kds,kde,ims, &
2438 diff_6th_opt,diff_6th_factor,adv_opt,ids,ide,jds,jde,kds,kde,ims, &
2439 ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2441 !PART I: DECLARATION OF VARIABLES
2443 IMPLICIT NONE
2445 INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
2446 TYPE(grid_config_rec_type) :: config_flags
2447 LOGICAL :: tenddec
2448 INTEGER :: rk_step,scs,sce
2449 INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
2450 LOGICAL :: moist_step
2451 REAL,DIMENSION(ims:ime,kms:kme,jms:jme,scs:sce) :: scalar,a_scalar,scalar_old, &
2452 a_scalar_old
2453 REAL,DIMENSION(ims:ime,kms:kme,jms:jme,scs:sce) :: scalar_tends,a_scalar_tends
2454 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: advect_tend,a_advect_tend
2455 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: h_tendency, z_tendency
2456 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_h_tendency, a_z_tendency
2457 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: RQVFTEN,a_RQVFTEN
2458 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru,a_ru,rv,a_rv,ww,a_ww,xkmhd, &
2459 a_xkmhd,alt,a_alt
2460 REAL,DIMENSION(kms:kme) :: fnm,fnp,rdn,rdnw,base
2461 REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,mub, &
2462 mut,a_mut,mu_old,a_mu_old
2463 REAL :: rdx,rdy,khdif,kvdif
2464 INTEGER :: diff_6th_opt
2465 ! Revised by Ning Pan, 2010-08-02
2466 ! REAL :: diff_6th_factor,a_diff_6th_factor
2467 ! REAL :: dt,a_dt
2468 REAL :: diff_6th_factor
2469 REAL :: dt
2470 INTEGER :: adv_opt
2471 INTEGER :: im,i,j,k
2472 INTEGER :: time_step
2473 REAL :: khdq,kvdq,tendency,a_tendency
2475 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,scs:sce,ims:ime,kms:kme,jms:jme,scs:sce) &
2476 ! :: Keep_Lpb1_scalar
2477 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,scs:sce,ims:ime,kms:kme,jms:jme,scs:sce) &
2478 ! :: Keep_Lpb1_scalar_old
2479 ! REAL,DIMENSION(scs:sce,ims:ime,kms:kme,jms:jme) :: Keep_Lpb1_ru
2480 ! REAL,DIMENSION(scs:sce,ims:ime,kms:kme,jms:jme) :: Keep_Lpb1_rv
2481 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,scs:sce,ims:ime,kms:kme,jms:jme,scs:sce) &
2482 ! :: Keep_Lpb1_scalar_tends
2483 INTEGER :: IX1,IX2,IX3,IX4
2485 REAL :: Tmpv_1,Tmpv_2,Tmpv_3,Tmpv_4,Tmpv_5,Tmpv_6,Tmpv_7,Tmpv_8,Tmpv_9,Tmpv_10, &
2486 Tmpv_11,Tmpv_12
2487 REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv400
2488 REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv401
2490 !This line is fail to be recognized
2491 ! CALL nl_get_time_step ( 1, time_step ) ! Remarked by Ning Pan, 2010-08-02
2493 !PART II: CALCULATIONS OF B. S. TRAJECTORY
2495 !LPB[0]
2496 khdq = khdif/prandtl
2497 kvdq = kvdif/prandtl
2499 !!LPB[1]
2500 ! scalar_loop : DO im = scs, sce
2502 !! DO IX3=jms,jme
2503 !! DO IX2=kms,kme
2504 !! DO IX1=ims,ime
2505 ! ! Keep_Lpb1_ru(im,IX1,IX2,IX3) =ru(IX1,IX2,IX3)
2506 !! END DO
2507 !! END DO
2508 !! END DO
2509 !! DO IX3=jms,jme
2510 !! DO IX2=kms,kme
2511 !! DO IX1=ims,ime
2512 ! ! Keep_Lpb1_rv(im,IX1,IX2,IX3) =rv(IX1,IX2,IX3)
2513 !! END DO
2514 !! END DO
2515 !! END DO
2516 !! DO IX4=scs,sce
2517 !! DO IX3=jms,jme
2518 !! DO IX2=kms,kme
2519 !! DO IX1=ims,ime
2520 ! ! Keep_Lpb1_scalar_tends(ims,kms,jms,im,IX1,IX2,IX3,IX4) =scalar_tends(ims,kms,jms,im)(IX1,IX2,IX3,IX4)
2521 !! END DO
2522 !! END DO
2523 !! END DO
2524 !! END DO
2526 ! CALL zero_tend ( advect_tend(ims,kms,jms), &
2527 ! ids, ide, jds, jde, kds, kde, &
2528 ! ims, ime, jms, jme, kms, kme, &
2529 ! its, ite, jts, jte, kts, kte )
2530 ! IF( (rk_step == 3) .and. (adv_opt == POSITIVEDEF) ) THEN
2532 ! CALL advect_scalar_pd ( scalar(ims,kms,jms,im), &
2533 ! scalar_old(ims,kms,jms,im), &
2534 ! advect_tend(ims,kms,jms), &
2535 ! ru, rv, ww, mut, mub, mu_old, &
2536 ! time_step, config_flags, &
2537 ! msfux, msfuy, msfvx, msfvy, &
2538 ! msftx, msfty, fnm, fnp, &
2539 ! rdx, rdy, rdnw,dt, &
2540 ! ids, ide, jds, jde, kds, kde, &
2541 ! ims, ime, jms, jme, kms, kme, &
2542 ! its, ite, jts, jte, kts, kte )
2543 ! ELSE IF( (rk_step == 3) .and. (adv_opt == MONOTONIC) ) THEN
2544 ! CALL advect_scalar_mono ( scalar(ims,kms,jms,im), &
2545 ! scalar_old(ims,kms,jms,im), &
2546 ! advect_tend(ims,kms,jms), &
2547 ! ru, rv, ww, mut, mub, mu_old, &
2548 ! config_flags, &
2549 ! msfux, msfuy, msfvx, msfvy, &
2550 ! msftx, msfty, fnm, fnp, &
2551 ! rdx, rdy, rdnw,dt, &
2552 ! ids, ide, jds, jde, kds, kde, &
2553 ! ims, ime, jms, jme, kms, kme, &
2554 ! its, ite, jts, jte, kts, kte )
2555 ! ELSE
2556 ! CALL advect_scalar ( scalar(ims,kms,jms,im), &
2557 ! scalar(ims,kms,jms,im), &
2558 ! advect_tend(ims,kms,jms), &
2559 ! ru, rv, ww, mut, time_step, &
2560 ! config_flags, &
2561 ! msfux, msfuy, msfvx, msfvy, &
2562 ! msftx, msfty, fnm, fnp, &
2563 ! rdx, rdy, rdnw, &
2564 ! ids, ide, jds, jde, kds, kde, &
2565 ! ims, ime, jms, jme, kms, kme, &
2566 ! its, ite, jts, jte, kts, kte )
2567 ! END IF
2568 ! IF((config_flags%cu_physics == GDSCHEME .OR. config_flags%cu_physics == G3SCHEME &
2569 !) .and. moist_step .and. ( im == P_QV) ) THEN
2571 ! CALL set_tend( RQVFTEN, advect_tend, msfty, &
2572 ! ids, ide, jds, jde, kds, kde, &
2573 ! ims, ime, jms, jme, kms, kme, &
2574 ! its, ite, jts, jte, kts, kte )
2575 ! ENDIF
2576 ! rk_step_1: IF( rk_step == 1 ) THEN
2578 ! diff_opt1 : IF (config_flags%diff_opt .eq. 1) THEN
2580 ! CALL horizontal_diffusion ( 'm', scalar(ims,kms,jms,im), &
2581 ! scalar_tends(ims,kms,jms,im), mut, &
2582 ! config_flags, &
2583 ! msfux, msfuy, msfvx, msfvx_inv, &
2584 ! msfvy, msftx, msfty, &
2585 ! khdq , xkmhd, rdx, rdy, &
2586 ! ids, ide, jds, jde, kds, kde, &
2587 ! ims, ime, jms, jme, kms, kme, &
2588 ! its, ite, jts, jte, kts, kte )
2589 ! pbl_test : IF (config_flags%bl_pbl_physics .eq. 0) THEN
2591 ! IF( (moist_step) .and. ( im == P_QV)) THEN
2593 ! CALL vertical_diffusion_mp ( scalar(ims,kms,jms,im), &
2594 ! scalar_tends(ims,kms,jms,im), &
2595 ! config_flags, base, &
2596 ! alt, mut, rdn, rdnw, kvdq , &
2597 ! ids, ide, jds, jde, kds, kde, &
2598 ! ims, ime, jms, jme, kms, kme, &
2599 ! its, ite, jts, jte, kts, kte )
2600 ! ELSE
2601 ! CALL vertical_diffusion ( 'm', scalar(ims,kms,jms,im), &
2602 ! scalar_tends(ims,kms,jms,im), &
2603 ! config_flags, &
2604 ! alt, mut, rdn, rdnw, kvdq, &
2605 ! ids, ide, jds, jde, kds, kde, &
2606 ! ims, ime, jms, jme, kms, kme, &
2607 ! its, ite, jts, jte, kts, kte )
2608 ! END IF
2609 ! ENDIF pbl_test
2610 ! ENDIF diff_opt1
2611 ! IF ( diff_6th_opt .NE. 0 ) &
2612 ! CALL sixth_order_diffusion( 'm', scalar(ims,kms,jms,im), &
2613 ! scalar_tends(ims,kms,jms,im), &
2614 ! mut, dt, config_flags, &
2615 ! diff_6th_opt, diff_6th_factor, &
2616 ! ids, ide, jds, jde, kds, kde, &
2617 ! ims, ime, jms, jme, kms, kme, &
2618 ! its, ite, jts, jte, kts, kte )
2620 ! ENDIF rk_step_1
2622 ! END DO scalar_loop
2624 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
2626 ! a_tendency =0.0 ! Remarked by Ning Pan, 2010-08-02
2628 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
2630 !LPB[1]
2631 DO im =sce, scs, -1
2632 CALL nl_get_time_step ( 1, time_step ) ! Added by Ning Pan, 2010-08-02
2634 ! DO IX3=jms,jme
2635 ! DO IX2=kms,kme
2636 ! DO IX1=ims,ime
2637 ! ru(IX1,IX2,IX3) =Keep_Lpb1_ru(im,IX1,IX2,IX3)
2638 ! END DO
2639 ! END DO
2640 ! END DO
2641 ! DO IX3=jms,jme
2642 ! DO IX2=kms,kme
2643 ! DO IX1=ims,ime
2644 ! rv(IX1,IX2,IX3) =Keep_Lpb1_rv(im,IX1,IX2,IX3)
2645 ! END DO
2646 ! END DO
2647 ! END DO
2648 ! DO IX4=scs,sce
2649 ! DO IX3=jms,jme
2650 ! DO IX2=kms,kme
2651 ! DO IX1=ims,ime
2652 ! scalar_tends(ims,kms,jms,im)(IX1,IX2,IX3,IX4) =Keep_Lpb1_scalar_tends(ims,kms,jms,im,IX1,IX2,IX3,IX4)
2653 ! END DO
2654 ! END DO
2655 ! END DO
2656 ! END DO
2658 ! Remarked by Ning Pan, 2010-08-02 : useless recomputation
2659 ! CALL zero_tend(advect_tend(ims,kms,jms),ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2660 ! kms,kme,its,ite,jts,jte,kts,kte)
2662 ! IF( (rk_step == 3) .and. (adv_opt == POSITIVEDEF) ) THEN
2663 ! Tmpv_1 =scalar(ims,kms,jms,im)
2664 ! Tmpv_2 =scalar_old(ims,kms,jms,im)
2665 ! Tmpv_3 =advect_tend(ims,kms,jms)
2666 ! CALL advect_scalar_pd(scalar(ims,kms,jms,im),scalar_old(ims,kms,jms,im) &
2667 ! ,advect_tend(ims,kms,jms),ru,rv,ww,mut,mub,mu_old,time_step,config_flags,msfux,msfuy, &
2668 ! msfvx,msfvy,msftx,msfty,fnm,fnp,rdx,rdy,rdnw,dt,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
2669 ! jme,kms,kme,its,ite,jts,jte,kts,kte)
2671 ! ELSE IF( (rk_step == 3) .and. (adv_opt == MONOTONIC) ) THEN
2672 ! Tmpv_4 =scalar(ims,kms,jms,im)
2673 ! Tmpv_5 =scalar_old(ims,kms,jms,im)
2674 ! Tmpv_6 =advect_tend(ims,kms,jms)
2675 ! CALL advect_scalar_mono(scalar(ims,kms,jms,im),scalar_old(ims,kms,jms,im) &
2676 ! ,advect_tend(ims,kms,jms),ru,rv,ww,mut,mub,mu_old,config_flags,msfux,msfuy,msfvx, &
2677 ! msfvy,msftx,msfty,fnm,fnp,rdx,rdy,rdnw,dt,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2678 ! kms,kme,its,ite,jts,jte,kts,kte)
2680 ! ELSE
2681 ! Tmpv_7 =scalar(ims,kms,jms,im)
2682 ! Tmpv_8 =advect_tend(ims,kms,jms)
2683 ! DO IX3=jms,jme
2684 ! DO IX2=kms,kme
2685 ! DO IX1=ims,ime
2686 ! Tmpv400(IX1,IX2,IX3) =ru(IX1,IX2,IX3)
2687 ! END DO
2688 ! END DO
2689 ! END DO
2691 ! DO IX3=jms,jme
2692 ! DO IX2=kms,kme
2693 ! DO IX1=ims,ime
2694 ! Tmpv401(IX1,IX2,IX3) =rv(IX1,IX2,IX3)
2695 ! END DO
2696 ! END DO
2697 ! END DO
2699 ! CALL advect_scalar(scalar(ims,kms,jms,im),scalar(ims,kms,jms,im),advect_tend(ims, &
2700 ! kms,jms),ru,rv,ww,mut,time_step,config_flags,msfux,msfuy,msfvx,msfvy,msftx,msfty,fnm, &
2701 ! fnp,rdx,rdy,rdnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2703 ! END IF
2704 ! IF((config_flags%cu_physics == GDSCHEME .OR. config_flags%cu_physics == G3SCHEME) .and. moist_step .and. ( im == P_QV) ) THEN
2705 ! CALL set_tend(RQVFTEN,advect_tend,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2706 ! kms,kme,its,ite,jts,jte,kts,kte)
2708 ! ENDIF
2709 ! IF( rk_step == 1 ) THEN
2710 ! IF(config_flags%diff_opt .eq. 1) THEN
2711 ! Tmpv_9 =scalar_tends(ims,kms,jms,im)
2712 ! CALL horizontal_diffusion('m',scalar(ims,kms,jms,im),scalar_tends(ims,kms,jms,im) &
2713 ! ,mut,config_flags,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdq,xkmhd,rdx,rdy, &
2714 ! ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2716 ! IF(config_flags%bl_pbl_physics .eq. 0) THEN
2717 ! IF( (moist_step) .and. ( im == P_QV)) THEN
2718 ! Tmpv_10 =scalar_tends(ims,kms,jms,im)
2719 ! CALL vertical_diffusion_mp(scalar(ims,kms,jms,im),scalar_tends(ims,kms,jms,im) &
2720 ! ,config_flags,base,alt,mut,rdn,rdnw,kvdq,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
2721 ! kme,its,ite,jts,jte,kts,kte)
2723 ! ELSE
2724 ! Tmpv_11 =scalar_tends(ims,kms,jms,im)
2725 ! CALL vertical_diffusion('m',scalar(ims,kms,jms,im),scalar_tends(ims,kms,jms,im) &
2726 ! ,config_flags,alt,mut,rdn,rdnw,kvdq,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
2727 ! its,ite,jts,jte,kts,kte)
2729 ! END IF
2730 ! ENDIF
2731 ! ENDIF
2732 ! IF( diff_6th_opt .NE. 0 ) THEN
2733 ! Tmpv_12 =scalar_tends(ims,kms,jms,im)
2734 ! CALL sixth_order_diffusion('m',scalar(ims,kms,jms,im),scalar_tends(ims,kms,jms,im) &
2735 ! ,mut,dt,config_flags,diff_6th_opt,diff_6th_factor,ids,ide,jds,jde,kds,kde,ims,ime, &
2736 ! jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2738 ! END IF
2739 ! ENDIF
2741 IF( rk_step == 1 ) THEN
2743 IF( diff_6th_opt .NE. 0 ) THEN
2745 ! scalar_tends(ims,kms,jms,im) =Tmpv_12 ! Remarked by Ning Pan, 2010-08-02
2747 CALL a_sixth_order_diffusion('m',scalar(ims,kms,jms,im),a_scalar(ims,kms,jms, &
2748 im),scalar_tends(ims,kms,jms,im),a_scalar_tends(ims,kms,jms,im),mut,a_mut,dt, &
2749 ! Revised by Ning Pan, 2010-08-02
2750 ! a_dt,config_flags,diff_6th_opt,diff_6th_factor,a_diff_6th_factor,ids,ide,jds,jde, &
2751 config_flags,diff_6th_opt,diff_6th_factor,ids,ide,jds,jde, &
2752 kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2754 END IF
2756 IF(config_flags%diff_opt .eq. 1) THEN
2758 IF(config_flags%bl_pbl_physics .eq. 0) THEN
2760 ! Added by Ning Pan, 2010-08-02
2761 IF( (moist_step) .and. ( im == P_QV)) THEN
2762 CALL a_vertical_diffusion_mp(scalar(ims,kms,jms,im),a_scalar(ims,kms,jms,im) &
2763 ,scalar_tends(ims,kms,jms,im),a_scalar_tends(ims,kms,jms,im),config_flags,base,alt, &
2764 a_alt,mut,a_mut,rdn,rdnw,kvdq,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
2765 its,ite,jts,jte,kts,kte)
2767 ELSE
2769 ! scalar_tends(ims,kms,jms,im) =Tmpv_11 ! Remarked by Ning Pan, 2010-08-02
2771 CALL a_vertical_diffusion('m',scalar(ims,kms,jms,im),a_scalar(ims,kms,jms,im) &
2772 ,scalar_tends(ims,kms,jms,im),a_scalar_tends(ims,kms,jms,im),config_flags,alt, &
2773 a_alt,mut,a_mut,rdn,rdnw,kvdq,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
2774 its,ite,jts,jte,kts,kte)
2776 ! Remarked by Ning Pan, 2010-08-02
2777 ! IF( (moist_step) .and. ( im == P_QV)) THEN
2779 ! scalar_tends(ims,kms,jms,im) =Tmpv_10
2781 ! CALL a_vertical_diffusion_mp(scalar(ims,kms,jms,im),a_scalar(ims,kms,jms,im) &
2782 ! ,scalar_tends(ims,kms,jms,im),a_scalar_tends(ims,kms,jms,im),config_flags,base,alt, &
2783 ! a_alt,mut,a_mut,rdn,rdnw,kvdq,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
2784 ! its,ite,jts,jte,kts,kte)
2786 END IF
2788 ENDIF
2790 ! scalar_tends(ims,kms,jms,im) =Tmpv_9 ! Remarked by Ning Pan, 2010-08-02
2792 CALL a_horizontal_diffusion('m',scalar(ims,kms,jms,im),a_scalar(ims,kms,jms, &
2793 im),scalar_tends(ims,kms,jms,im),a_scalar_tends(ims,kms,jms,im),mut,a_mut, &
2794 config_flags,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdq,xkmhd,a_xkmhd,rdx, &
2795 rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2797 ENDIF
2799 ENDIF
2801 IF((config_flags%cu_physics == GDSCHEME .OR. config_flags%cu_physics == G3SCHEME .OR. &
2802 config_flags%cu_physics == KFETASCHEME .OR. & ! new trigger in KF
2803 config_flags%cu_physics == MSKFSCHEME .OR. &
2804 config_flags%cu_physics == TIEDTKESCHEME .OR. & ! Tiedtke
2805 config_flags%cu_physics == NTIEDTKESCHEME) & ! new Tiedtke
2806 .and. moist_step .and. ( im == P_QV) ) THEN
2808 CALL a_set_tend(RQVFTEN,a_RQVFTEN,advect_tend,a_advect_tend,msfty,ids,ide, &
2809 jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2811 ENDIF
2813 IF( (rk_step == 3) .and. (adv_opt == POSITIVEDEF) ) THEN
2815 ! advect_tend(ims,kms,jms) =Tmpv_3 ! Remarked by Ning Pan, 2010-08-02
2817 ! scalar_old(ims,kms,jms,im) =Tmpv_2 ! Remarked by Ning Pan, 2010-08-02
2819 ! scalar(ims,kms,jms,im) =Tmpv_1 ! Remarked by Ning Pan, 2010-08-02
2821 CALL a_advect_scalar_pd(scalar(ims,kms,jms,im),a_scalar(ims,kms,jms,im) &
2822 ,scalar_old(ims,kms,jms,im),a_scalar_old(ims,kms,jms,im),advect_tend(ims,kms,jms) &
2823 ,a_advect_tend(ims,kms,jms),h_tendency(ims,kms,jms),a_h_tendency(ims,kms,jms),z_tendency(ims,kms,jms),a_z_tendency(ims,kms,jms) &
2824 ,ru,a_ru,rv,a_rv,ww,a_ww,mut,a_mut,mub,mu_old, &
2825 a_mu_old,time_step,config_flags,tenddec,msfux,msfuy,msfvx,msfvy,msftx,msfty,fnm,fnp,rdx, &
2826 ! Revised by Ning Pan, 2010-08-02
2827 ! rdy,rdnw,dt,a_dt,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2828 rdy,rdnw,dt,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2830 ELSE IF( (rk_step == 3) .and. (adv_opt == MONOTONIC) ) THEN
2832 ! advect_tend(ims,kms,jms) =Tmpv_6 ! Remarked by Ning Pan, 2010-08-02
2834 ! scalar_old(ims,kms,jms,im) =Tmpv_5 ! Remarked by Ning Pan, 2010-08-02
2836 ! scalar(ims,kms,jms,im) =Tmpv_4 ! Remarked by Ning Pan, 2010-08-02
2838 CALL a_advect_scalar_mono(scalar(ims,kms,jms,im),a_scalar(ims,kms,jms,im) &
2839 ,scalar_old(ims,kms,jms,im),a_scalar_old(ims,kms,jms,im),advect_tend(ims,kms,jms) &
2840 ,a_advect_tend(ims,kms,jms),h_tendency(ims,kms,jms),a_h_tendency(ims,kms,jms),z_tendency(ims,kms,jms),a_z_tendency(ims,kms,jms) &
2841 ,ru,a_ru,rv,a_rv,ww,a_ww,mut,a_mut,mub,mu_old, &
2842 a_mu_old,config_flags,tenddec,msfux,msfuy,msfvx,msfvy,msftx,msfty,fnm,fnp,rdx,rdy,rdnw,dt, &
2843 ! Revised by Ning Pan, 2010-08-02
2844 ! a_dt,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2845 ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2847 ELSE IF( (rk_step == 3) .and. (adv_opt == WENO_SCALAR) ) THEN
2849 CALL a_advect_scalar_weno ( scalar(ims,kms,jms,im), &
2850 a_scalar(ims,kms,jms,im), &
2851 scalar(ims,kms,jms,im), &
2852 a_scalar(ims,kms,jms,im), &
2853 advect_tend(ims,kms,jms), &
2854 a_advect_tend(ims,kms,jms), &
2855 ru, a_ru, rv, a_rv, ww, a_ww, &
2856 mut, time_step, &
2857 config_flags, &
2858 msfux, msfuy, msfvx, msfvy, &
2859 msftx, msfty, fnm, fnp, &
2860 rdx, rdy, rdnw, &
2861 ids, ide, jds, jde, kds, kde, &
2862 ims, ime, jms, jme, kms, kme, &
2863 its, ite, jts, jte, kts, kte )
2865 ELSEIF( (rk_step == 3) .and. (adv_opt == WENOPD_SCALAR) ) THEN
2867 CALL a_advect_scalar_wenopd ( scalar(ims,kms,jms,im), &
2868 a_scalar(ims,kms,jms,im), &
2869 scalar_old(ims,kms,jms,im), &
2870 a_scalar_old(ims,kms,jms,im), &
2871 advect_tend(ims,kms,jms), &
2872 a_advect_tend(ims,kms,jms), &
2873 ru, a_ru, rv, a_rv, ww, a_ww, &
2874 mut, a_mut, mub, mu_old, a_mu_old, &
2875 time_step, config_flags, &
2876 msfux, msfuy, msfvx, msfvy, &
2877 msftx, msfty, fnm, fnp, &
2878 rdx, rdy, rdnw,dt, &
2879 ids, ide, jds, jde, kds, kde, &
2880 ims, ime, jms, jme, kms, kme, &
2881 its, ite, jts, jte, kts, kte )
2883 ELSE
2885 ! Remarked by Ning Pan, 2010-08-02
2886 ! DO IX3=jms,jme
2887 ! DO IX2=kms,kme
2888 ! DO IX1=ims,ime
2889 ! rv(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
2890 ! END DO
2891 ! END DO
2892 ! END DO
2894 ! DO IX3=jms,jme
2895 ! DO IX2=kms,kme
2896 ! DO IX1=ims,ime
2897 ! ru(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
2898 ! END DO
2899 ! END DO
2900 ! END DO
2902 ! advect_tend(ims,kms,jms) =Tmpv_8
2904 ! scalar(ims,kms,jms,im) =Tmpv_7
2906 CALL a_advect_scalar(scalar(ims,kms,jms,im),a_scalar(ims,kms,jms,im) &
2907 ,scalar(ims,kms,jms,im),a_scalar(ims,kms,jms,im),advect_tend(ims,kms,jms) &
2908 ,a_advect_tend(ims,kms,jms),ru,a_ru,rv,a_rv,ww,a_ww,mut,time_step, &
2909 config_flags,msfux,msfuy,msfvx,msfvy,msftx,msfty,fnm,fnp,rdx,rdy,rdnw,ids,ide,jds, &
2910 jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2912 END IF
2914 ! Added by Ning Pan, 2010-08-02
2915 CALL a_zero_tend(a_advect_tend,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2916 kms,kme,its,ite,jts,jte,kts,kte)
2917 CALL a_zero_tend(a_h_tendency,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2918 kms,kme,its,ite,jts,jte,kts,kte)
2919 CALL a_zero_tend(a_z_tendency,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
2920 kms,kme,its,ite,jts,jte,kts,kte)
2922 ENDDO
2924 !LPB[0]
2925 ! khdq =khdif/prandtl
2926 ! kvdq =kvdif/prandtl
2928 END SUBROUTINE a_rk_scalar_tend
2930 !-------------------------------------------------------------------------------
2931 ! Generated by TAPENADE (INRIA, Tropics team)
2932 ! Tapenade 3.10 (r5498) - 20 Jan 2015 09:48
2933 !
2934 ! Differentiation of q_diabatic_add in reverse (adjoint) mode:
2935 ! gradient of useful results: qc_diabatic qv_diabatic scalar_tends
2936 ! mu
2937 ! with respect to varying inputs: qc_diabatic qv_diabatic scalar_tends
2938 ! mu
2939 ! RW status of diff variables: qc_diabatic:incr qv_diabatic:incr
2940 ! scalar_tends:in-out mu:incr
2941 SUBROUTINE a_Q_DIABATIC_ADD(scs, sce, dt, mu, mub, qv_diabatic, &
2942 & qv_diabaticb, qc_diabatic, qc_diabaticb, scalar_tends, scalar_tendsb, &
2943 & ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, &
2944 & jts, jte, kts, kte)
2945 IMPLICIT NONE
2946 ! Input data.
2947 INTEGER, INTENT(IN) :: scs, sce
2948 INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
2949 & jme, kms, kme, its, ite, jts, jte, kts, kte
2950 REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu
2951 REAL, DIMENSION(ims:ime, jms:jme) :: mub
2952 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: qv_diabatic&
2953 & , qc_diabatic
2954 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: qv_diabaticb, &
2955 & qc_diabaticb
2956 REAL, DIMENSION(ims:ime, kms:kme, jms:jme, scs:sce), INTENT(INOUT) :: &
2957 & scalar_tends
2958 REAL, DIMENSION(ims:ime, kms:kme, jms:jme, scs:sce), INTENT(INOUT) :: &
2959 & scalar_tendsb
2960 REAL, INTENT(IN) :: dt
2961 ! Local data
2962 INTEGER :: im, i, j, k
2963 INTEGER :: ad_to
2964 INTEGER :: ad_to0
2965 INTEGER :: ad_to1
2966 INTEGER :: ad_to2
2967 INTEGER :: branch
2968 INTEGER :: min4
2969 INTEGER :: min3
2970 INTEGER :: min2
2971 INTEGER :: min1
2972 scalar_loop:DO im=scs,sce
2973 IF (im .EQ. p_qv) THEN
2974 IF (jte .GT. jde - 1) THEN
2975 min1 = jde - 1
2976 ELSE
2977 min1 = jte
2978 END IF
2979 DO j=jts,min1
2980 DO k=kts,kte-1
2981 IF (ite .GT. ide - 1) THEN
2982 min2 = ide - 1
2983 ELSE
2984 min2 = ite
2985 END IF
2986 i = min2 + 1
2987 CALL PUSHINTEGER4(i - 1)
2988 END DO
2989 END DO
2990 CALL PUSHINTEGER4(j - 1)
2991 CALL PUSHCONTROL1B(0)
2992 ELSE
2993 CALL PUSHCONTROL1B(1)
2994 END IF
2995 IF (im .EQ. p_qc) THEN
2996 IF (jte .GT. jde - 1) THEN
2997 min3 = jde - 1
2998 ELSE
2999 min3 = jte
3000 END IF
3001 DO j=jts,min3
3002 DO k=kts,kte-1
3003 IF (ite .GT. ide - 1) THEN
3004 min4 = ide - 1
3005 ELSE
3006 min4 = ite
3007 END IF
3008 i = min4 + 1
3009 CALL PUSHINTEGER4(i - 1)
3010 END DO
3011 END DO
3012 CALL PUSHINTEGER4(j - 1)
3013 CALL PUSHCONTROL1B(1)
3014 ELSE
3015 CALL PUSHCONTROL1B(0)
3016 END IF
3017 END DO scalar_loop
3018 DO im=sce,scs,-1
3019 CALL POPCONTROL1B(branch)
3020 IF (branch .NE. 0) THEN
3021 CALL POPINTEGER4(ad_to2)
3022 DO j=ad_to2,jts,-1
3023 DO k=kte-1,kts,-1
3024 CALL POPINTEGER4(ad_to1)
3025 DO i=ad_to1,its,-1
3026 qc_diabaticb(i,k,j) = qc_diabaticb(i,k,j) + &
3027 mu(i,j)*scalar_tendsb(i,k,j,im)
3028 mub(i,j) = mub(i,j) + &
3029 qc_diabatic(i,k,j)*scalar_tendsb(i,k,j,im)
3030 END DO
3031 END DO
3032 END DO
3033 END IF
3034 CALL POPCONTROL1B(branch)
3035 IF (branch .EQ. 0) THEN
3036 CALL POPINTEGER4(ad_to0)
3037 DO j=ad_to0,jts,-1
3038 DO k=kte-1,kts,-1
3039 CALL POPINTEGER4(ad_to)
3040 DO i=ad_to,its,-1
3041 qv_diabaticb(i,k,j) = qv_diabaticb(i,k,j) + &
3042 mu(i,j)*scalar_tendsb(i,k,j,im)
3043 mub(i,j) = mub(i,j) + &
3044 qv_diabatic(i,k,j)*scalar_tendsb(i,k,j,im)
3045 END DO
3046 END DO
3047 END DO
3048 END IF
3049 END DO
3050 END SUBROUTINE a_Q_DIABATIC_ADD
3052 !-------------------------------------------------------------------------------
3053 ! Generated by TAPENADE (INRIA, Tropics team)
3054 ! Tapenade 3.10 (r5498) - 20 Jan 2015 09:48
3055 !
3056 ! Differentiation of q_diabatic_subtr in reverse (adjoint) mode:
3057 ! gradient of useful results: qc_diabatic qv_diabatic scalar
3058 ! with respect to varying inputs: qc_diabatic qv_diabatic scalar
3059 ! RW status of diff variables: qc_diabatic:incr qv_diabatic:incr
3060 ! scalar:in-out
3061 SUBROUTINE a_Q_DIABATIC_SUBTR(scs, sce, dt, qv_diabatic, qv_diabaticb, &
3062 & qc_diabatic, qc_diabaticb, scalar, scalarb, ids, ide, jds, jde, kds, &
3063 & kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
3064 IMPLICIT NONE
3065 ! Input data.
3066 INTEGER, INTENT(IN) :: scs, sce
3067 INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
3068 & jme, kms, kme, its, ite, jts, jte, kts, kte
3069 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: qv_diabatic&
3070 & , qc_diabatic
3071 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: qv_diabaticb, &
3072 & qc_diabaticb
3073 REAL, DIMENSION(ims:ime, kms:kme, jms:jme, scs:sce), INTENT(INOUT) :: &
3074 & scalar
3075 REAL, DIMENSION(ims:ime, kms:kme, jms:jme, scs:sce), INTENT(INOUT) :: &
3076 & scalarb
3077 REAL, INTENT(IN) :: dt
3078 ! Local data
3079 INTEGER :: im, i, j, k
3080 INTEGER :: ad_to
3081 INTEGER :: ad_to0
3082 INTEGER :: ad_to1
3083 INTEGER :: ad_to2
3084 INTEGER :: branch
3085 INTEGER :: min4
3086 INTEGER :: min3
3087 INTEGER :: min2
3088 INTEGER :: min1
3089 scalar_loop:DO im=scs,sce
3090 IF (im .EQ. p_qv) THEN
3091 IF (jte .GT. jde - 1) THEN
3092 min1 = jde - 1
3093 ELSE
3094 min1 = jte
3095 END IF
3096 DO j=jts,min1
3097 DO k=kts,kte-1
3098 IF (ite .GT. ide - 1) THEN
3099 min2 = ide - 1
3100 ELSE
3101 min2 = ite
3102 END IF
3103 i = min2 + 1
3104 CALL PUSHINTEGER4(i - 1)
3105 END DO
3106 END DO
3107 CALL PUSHINTEGER4(j - 1)
3108 CALL PUSHCONTROL1B(0)
3109 ELSE
3110 CALL PUSHCONTROL1B(1)
3111 END IF
3112 IF (im .EQ. p_qc) THEN
3113 IF (jte .GT. jde - 1) THEN
3114 min3 = jde - 1
3115 ELSE
3116 min3 = jte
3117 END IF
3118 DO j=jts,min3
3119 DO k=kts,kte-1
3120 IF (ite .GT. ide - 1) THEN
3121 min4 = ide - 1
3122 ELSE
3123 min4 = ite
3124 END IF
3125 i = min4 + 1
3126 CALL PUSHINTEGER4(i - 1)
3127 END DO
3128 END DO
3129 CALL PUSHINTEGER4(j - 1)
3130 CALL PUSHCONTROL1B(1)
3131 ELSE
3132 CALL PUSHCONTROL1B(0)
3133 END IF
3134 END DO scalar_loop
3135 DO im=sce,scs,-1
3136 CALL POPCONTROL1B(branch)
3137 IF (branch .NE. 0) THEN
3138 CALL POPINTEGER4(ad_to2)
3139 DO j=ad_to2,jts,-1
3140 DO k=kte-1,kts,-1
3141 CALL POPINTEGER4(ad_to1)
3142 DO i=ad_to1,its,-1
3143 qc_diabaticb(i,k,j) = qc_diabaticb(i,k,j) - &
3144 dt*scalarb(i,k,j,im)
3145 END DO
3146 END DO
3147 END DO
3148 END IF
3149 CALL POPCONTROL1B(branch)
3150 IF (branch .EQ. 0) THEN
3151 CALL POPINTEGER4(ad_to0)
3152 DO j=ad_to0,jts,-1
3153 DO k=kte-1,kts,-1
3154 CALL POPINTEGER4(ad_to)
3155 DO i=ad_to,its,-1
3156 qv_diabaticb(i,k,j) = qv_diabaticb(i,k,j) - &
3157 dt*scalarb(i,k,j,im)
3158 END DO
3159 END DO
3160 END DO
3161 END IF
3162 END DO
3163 END SUBROUTINE a_Q_DIABATIC_SUBTR
3165 !-------------------------------------------------------------------------------
3167 SUBROUTINE a_rk_update_scalar ( scs, sce, &
3168 scalar_1, a_scalar_1, scalar_2, a_scalar_2, sc_tend, a_sc_tend, &
3169 advh_t, a_advh_t, advz_t, a_advz_t, &
3170 advect_tend, a_advect_tend, &
3171 h_tendency, a_h_tendency, z_tendency, a_z_tendency, &
3172 msftx, msfty, &
3173 mu_old, a_mu_old, mu_new, a_mu_new, mu_base, &
3174 rk_step, dt, spec_zone, &
3175 config_flags, &
3176 tenddec, &
3177 ids, ide, jds, jde, kds, kde, &
3178 ims, ime, jms, jme, kms, kme, &
3179 its, ite, jts, jte, kts, kte )
3181 IMPLICIT NONE
3183 ! Input data.
3185 TYPE(grid_config_rec_type), INTENT(IN) :: config_flags
3186 LOGICAL :: tenddec
3188 INTEGER, INTENT(IN) :: scs, sce, rk_step, spec_zone
3189 INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
3190 ims, ime, jms, jme, kms, kme, &
3191 its, ite, jts, jte, kts, kte
3193 REAL, INTENT(IN) :: dt
3195 REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce), &
3196 INTENT(INOUT) :: a_scalar_1, &
3197 a_scalar_2
3198 REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce), &
3199 INTENT(IN) :: scalar_1, &
3200 scalar_2
3202 REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce), &
3203 INTENT(INOUT) :: a_sc_tend
3204 REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce), &
3205 INTENT(IN) :: sc_tend
3207 REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), &
3208 INTENT(INOUT) :: a_advect_tend
3209 REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), &
3210 INTENT(IN) :: advect_tend
3212 REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), OPTIONAL :: advh_t, advz_t ! accumulating for output
3213 REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), OPTIONAL :: a_advh_t, a_advz_t ! accumulating for output
3214 REAL, DIMENSION(ims:ime, kms:kme, jms:jme ) :: h_tendency, z_tendency ! from rk_scalar_tend
3215 REAL, DIMENSION(ims:ime, kms:kme, jms:jme ) :: a_h_tendency, a_z_tendency ! from rk_scalar_tend
3217 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: a_mu_old, &
3218 a_mu_new
3219 REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN ) :: mu_old, &
3220 mu_new, &
3221 mu_base, &
3222 msftx, &
3223 msfty
3225 INTEGER :: i,j,k,im
3226 REAL :: sc_middle, msfsq
3227 REAL, DIMENSION(its:ite) :: a_muold, a_r_munew
3228 REAL, DIMENSION(its:ite) :: muold, r_munew
3230 REAL, DIMENSION(its:ite, kts:kte, jts:jte ) :: a_tendency
3231 REAL, DIMENSION(its:ite, kts:kte, jts:jte ) :: tendency
3233 REAL, DIMENSION(ims:ime, kms:kme, jms:jme, scs:sce) :: scalar_old
3235 INTEGER :: i_start,i_end,j_start,j_end,k_start,k_end
3236 INTEGER :: i_start_spc,i_end_spc,j_start_spc,j_end_spc,k_start_spc,k_end_spc
3238 !<DESCRIPTION> !
3239 ! Basic states: mu_old, mu_new, advect_tend, sc_tend, scalar_2(rk_step=1), scalar_1(rk_step/=1)
3240 !
3241 !</DESCRIPTION>
3243 ! Initilize local adjoint variables
3244 a_muold = 0.0
3245 a_r_munew = 0.0
3246 a_tendency = 0.0
3247 !
3248 ! set loop limits.
3250 i_start = its
3251 i_end = min(ite,ide-1)
3252 j_start = jts
3253 j_end = min(jte,jde-1)
3254 k_start = kts
3255 k_end = kte-1
3257 i_start_spc = i_start
3258 i_end_spc = i_end
3259 j_start_spc = j_start
3260 j_end_spc = j_end
3261 k_start_spc = k_start
3262 k_end_spc = k_end
3264 IF( config_flags%nested .or. config_flags%specified ) THEN
3265 IF( .NOT. config_flags%periodic_x)i_start = max( its,ids+spec_zone )
3266 IF( .NOT. config_flags%periodic_x)i_end = min( ite,ide-spec_zone-1 )
3267 j_start = max( jts,jds+spec_zone )
3268 j_end = min( jte,jde-spec_zone-1 )
3269 k_start = kts
3270 k_end = min( kte, kde-1 )
3271 ENDIF
3273 IF ( rk_step == 1 ) THEN
3275 DO im = sce,scs,-1
3277 ! Recalculate tendency
3278 DO j = jts, min(jte,jde-1)
3279 DO k = kts, min(kte,kde-1)
3280 DO i = its, min(ite,ide-1)
3281 tendency(i,k,j) = 0.
3282 ENDDO
3283 ENDDO
3284 ENDDO
3286 DO j = j_start,j_end
3287 DO k = k_start,k_end
3288 DO i = i_start,i_end
3289 ! scalar was coupled with my
3290 tendency(i,k,j) = advect_tend(i,k,j) * msfty(i,j)
3291 ENDDO
3292 ENDDO
3293 ENDDO
3295 DO j = j_start_spc,j_end_spc
3296 DO k = k_start_spc,k_end_spc
3297 DO i = i_start_spc,i_end_spc
3298 tendency(i,k,j) = tendency(i,k,j) + sc_tend(i,k,j,im)
3299 ENDDO
3300 ENDDO
3301 ENDDO
3303 DO j = jts, min(jte,jde-1)
3305 ! Recalculate muold and r_munew
3306 DO i = its, min(ite,ide-1)
3307 muold(i) = mu_old(i,j) + mu_base(i,j)
3308 r_munew(i) = 1./(mu_new(i,j) + mu_base(i,j))
3309 ENDDO
3311 DO k = kts, min(kte,kde-1)
3312 DO i = its, min(ite,ide-1)
3313 ! Recalculate scalar_1 (i.e. scalar_old)
3314 scalar_old(i,k,j,im) = scalar_2(i,k,j,im)
3316 a_scalar_1(i,k,j,im) = a_scalar_1(i,k,j,im) + muold(i)*r_munew(i) * a_scalar_2(i,k,j,im)
3317 a_muold(i) = a_muold(i) + scalar_old(i,k,j,im)*r_munew(i) * a_scalar_2(i,k,j,im)
3318 a_tendency(i,k,j) = a_tendency(i,k,j) + dt*r_munew(i) * a_scalar_2(i,k,j,im)
3319 a_r_munew(i) = a_r_munew(i) + (muold(i)*scalar_old(i,k,j,im)+dt*tendency(i,k,j)) * a_scalar_2(i,k,j,im)
3320 a_scalar_2(i,k,j,im) = 0.0
3322 a_scalar_2(i,k,j,im) = a_scalar_2(i,k,j,im) + a_scalar_1(i,k,j,im)
3323 a_scalar_1(i,k,j,im) = 0.0
3324 ENDDO !i
3325 ENDDO !k
3327 DO i = its, min(ite,ide-1)
3328 a_mu_new(i,j) = a_mu_new(i,j) - a_r_munew(i) / ((mu_new(i,j)+mu_base(i,j))*(mu_new(i,j)+mu_base(i,j)))
3329 a_r_munew(i) = 0.0
3331 a_mu_old(i,j) = a_mu_old(i,j) + a_muold(i)
3332 a_muold(i) = 0.0
3333 ENDDO
3335 ENDDO !j
3337 DO j = j_start_spc,j_end_spc
3338 DO k = k_start_spc,k_end_spc
3339 DO i = i_start_spc,i_end_spc
3340 a_sc_tend(i,k,j,im) = a_sc_tend(i,k,j,im) + a_tendency(i,k,j)
3341 ENDDO
3342 ENDDO
3343 ENDDO
3345 DO j = j_start,j_end
3346 DO k = k_start,k_end
3347 DO i = i_start,i_end
3348 ! scalar was coupled with my
3349 a_advect_tend(i,k,j) = a_advect_tend(i,k,j) + msfty(i,j) * a_tendency(i,k,j)
3350 a_tendency(i,k,j) = 0.0
3351 ENDDO
3352 ENDDO
3353 ENDDO
3355 DO j = jts, min(jte,jde-1)
3356 DO k = kts, min(kte,kde-1)
3357 DO i = its, min(ite,ide-1)
3358 a_tendency(i,k,j) = 0.
3359 ENDDO
3360 ENDDO
3361 ENDDO
3363 ENDDO !im
3365 ELSE
3367 DO im = sce, scs, -1
3369 ! Recalculate tendency
3370 DO j = jts, min(jte,jde-1)
3371 DO k = kts, min(kte,kde-1)
3372 DO i = its, min(ite,ide-1)
3373 tendency(i,k,j) = 0.
3374 ENDDO
3375 ENDDO
3376 ENDDO
3378 DO j = j_start,j_end
3379 DO k = k_start,k_end
3380 DO i = i_start,i_end
3381 ! scalar was coupled with my
3382 tendency(i,k,j) = advect_tend(i,k,j) * msfty(i,j)
3383 ENDDO
3384 ENDDO
3385 ENDDO
3387 DO j = j_start_spc,j_end_spc
3388 DO k = k_start_spc,k_end_spc
3389 DO i = i_start_spc,i_end_spc
3390 tendency(i,k,j) = tendency(i,k,j) + sc_tend(i,k,j,im)
3391 ENDDO
3392 ENDDO
3393 ENDDO
3395 DO j = jts, min(jte,jde-1)
3397 ! Recalculate muold and r_munew
3398 DO i = its, min(ite,ide-1)
3399 muold(i) = mu_old(i,j) + mu_base(i,j)
3400 r_munew(i) = 1./(mu_new(i,j) + mu_base(i,j))
3401 ENDDO
3403 ! This is separated from the k/i-loop above for better performance
3404 IF ( PRESENT(advh_t) .AND. PRESENT(advz_t) .AND. PRESENT(a_advh_t) .AND. PRESENT(a_advz_t) ) THEN
3405 IF (tenddec.and.rk_step.eq.config_flags%rk_ord) THEN
3406 DO k = kts, min(kte,kde-1)
3407 DO i = its, min(ite,ide-1)
3409 a_h_tendency(i,k,j) = a_h_tendency(i,k,j) + dt*msfty(i,j)*r_munew(i)*a_advh_t(i,k,j)
3410 a_r_munew(i) = a_r_munew(i) + (dt*h_tendency(i,k,j)* msfty(i,j))*a_advh_t(i,k,j)
3411 a_z_tendency(i,k,j) = a_z_tendency(i,k,j) + dt*msfty(i,j)*r_munew(i)*a_advz_t(i,k,j)
3412 a_r_munew(i) = a_r_munew(i) + (dt*z_tendency(i,k,j)* msfty(i,j))*a_advz_t(i,k,j)
3414 ENDDO
3415 ENDDO
3416 END IF
3417 END IF
3419 DO k = kts, min(kte,kde-1)
3420 DO i = its, min(ite,ide-1)
3422 a_scalar_1(i,k,j,im) = a_scalar_1(i,k,j,im) + muold(i)*r_munew(i) * a_scalar_2(i,k,j,im)
3423 a_muold(i) = a_muold(i) + scalar_1(i,k,j,im)*r_munew(i) * a_scalar_2(i,k,j,im)
3424 a_tendency(i,k,j) = a_tendency(i,k,j) + dt*r_munew(i) * a_scalar_2(i,k,j,im)
3425 a_r_munew(i) = a_r_munew(i) + (muold(i)*scalar_1(i,k,j,im)+dt*tendency(i,k,j)) * a_scalar_2(i,k,j,im)
3427 a_scalar_2(i,k,j,im) = 0.0
3429 ENDDO
3430 ENDDO
3432 DO i = its, min(ite,ide-1)
3433 a_mu_new(i,j) = a_mu_new(i,j) - a_r_munew(i) / ((mu_new(i,j)+mu_base(i,j))*(mu_new(i,j)+mu_base(i,j)))
3434 a_r_munew(i) = 0.0
3436 a_mu_old(i,j) = a_mu_old(i,j) + a_muold(i)
3437 a_muold(i) = 0.0
3438 ENDDO
3440 ENDDO !j
3442 DO j = j_start_spc,j_end_spc
3443 DO k = k_start_spc,k_end_spc
3444 DO i = i_start_spc,i_end_spc
3445 a_sc_tend(i,k,j,im) = a_sc_tend(i,k,j,im) + a_tendency(i,k,j)
3446 ENDDO
3447 ENDDO
3448 ENDDO
3450 DO j = j_start,j_end
3451 DO k = k_start,k_end
3452 DO i = i_start,i_end
3453 ! scalar was coupled with my
3454 a_advect_tend(i,k,j) = a_advect_tend(i,k,j) + msfty(i,j) * a_tendency(i,k,j)
3455 a_tendency(i,k,j) = 0.0
3456 ENDDO
3457 ENDDO
3458 ENDDO
3460 DO j = jts, min(jte,jde-1)
3461 DO k = kts, min(kte,kde-1)
3462 DO i = its, min(ite,ide-1)
3463 a_tendency(i,k,j) = 0.
3464 ENDDO
3465 ENDDO
3466 ENDDO
3468 ENDDO !im
3470 END IF
3472 END SUBROUTINE a_rk_update_scalar
3474 !-------------------------------------------------------------------------------
3476 SUBROUTINE a_rk_update_scalar_pd(scs,sce,scalar,a_scalar,sc_tend,a_sc_tend, &
3477 mu_old,a_mu_old,mu_new,a_mu_new,mu_base,rk_step,dt,spec_zone, &
3478 config_flags,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
3480 !PART I: DECLARATION OF VARIABLES
3482 IMPLICIT NONE
3484 INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
3485 TYPE(grid_config_rec_type) :: config_flags
3486 INTEGER :: scs,sce,rk_step,spec_zone
3487 INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
3488 REAL :: dt
3489 REAL,DIMENSION(ims:ime,kms:kme,jms:jme,scs:sce) :: scalar,a_scalar,sc_tend,a_sc_tend
3490 REAL,DIMENSION(ims:ime,jms:jme) :: mu_old,a_mu_old,mu_new,a_mu_new,mu_base
3491 INTEGER :: i,j,k,im
3492 REAL :: sc_middle,sfsq
3493 REAL,DIMENSION(its:ite) :: muold,a_muold,r_munew,a_r_munew
3494 REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: tendency,a_tendency
3495 INTEGER :: i_start,i_end,j_start,j_end,k_start,k_end
3496 INTEGER :: i_start_spc,i_end_spc,j_start_spc,j_end_spc,k_start_spc,k_end_spc
3498 REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3
3499 REAL,ALLOCATABLE,DIMENSION(:,:) :: Tmpv300
3500 REAL,DIMENSION(its:min(ite, ide-1),jts:min(jte, jde-1)) :: Tmpv301
3501 REAL,DIMENSION(its:min(ite, ide-1),kts:min(kte, kde-1),jts:min(jte, jde-1)) :: Tmpv400
3503 !PART II: CALCULATIONS OF B. S. TRAJECTORY
3505 !LPB[0]
3507 i_start = its
3508 i_end = min(ite,ide-1)
3509 j_start = jts
3510 j_end = min(jte,jde-1)
3511 k_start = kts
3512 k_end = kte-1
3514 i_start_spc = i_start
3515 i_end_spc = i_end
3516 j_start_spc = j_start
3517 j_end_spc = j_end
3518 k_start_spc = k_start
3519 k_end_spc = k_end
3521 !LPB[1]
3522 IF( config_flags%nested .or. config_flags%specified ) THEN
3523 IF( .NOT. config_flags%periodic_x)i_start = max( its,ids+spec_zone )
3524 IF( .NOT. config_flags%periodic_x)i_end = min( ite,ide-spec_zone-1 )
3525 j_start = max( jts,jds+spec_zone )
3526 j_end = min( jte,jde-spec_zone-1 )
3527 k_start = kts
3528 k_end = min( kte, kde-1 )
3529 ENDIF
3531 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
3533 a_muold =0.
3534 a_r_munew =0.
3536 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
3538 !LPB[2]
3539 DO im =sce, scs, -1
3541 tendency(its:min(ite,ide-1),kts:min(kte,kde-1),jts:min(jte,jde-1)) =0.
3543 tendency(i_start_spc:i_end_spc,k_start_spc:k_end_spc,j_start_spc:j_end_spc) =tendency&
3544 (i_start_spc:i_end_spc,k_start_spc:k_end_spc,j_start_spc:j_end_spc) +sc_tend&
3545 (i_start_spc:i_end_spc,k_start_spc:k_end_spc,j_start_spc:j_end_spc,im)
3547 sc_tend(i_start_spc:i_end_spc,k_start_spc:k_end_spc,j_start_spc:j_end_spc,im) =0.
3549 ALLOCATE (Tmpv300(its:min(ite, ide-1),jts:min(jte, jde-1)))
3551 DO j =jts, min(jte, jde-1)
3552 DO i =its, min(ite, ide-1)
3553 Tmpv300(i,j) =mu_old(i,j) +mu_base(i,j)
3554 ENDDO
3556 DO k =kts, min(kte, kde-1)
3557 DO i =its, min(ite, ide-1)
3558 Tmpv400(i,k,j) =Tmpv300(i,j)*scalar(i,k,j,im)+dt*tendency(i,k,j)
3559 ENDDO
3560 ENDDO
3561 ENDDO
3563 DO j =min(jte, jde-1), jts, -1
3565 DO k =kts, min(kte, kde-1)
3566 DO i =its, min(ite, ide-1)
3567 a_r_munew(i) =a_r_munew(i) +Tmpv400(i,k,j)*a_scalar(i,k,j,im)
3568 a_Tmpv1 = a_scalar(i,k,j,im)/(mu_new(i,j)+mu_base(i,j))
3569 a_tendency(i,k,j) =dt*a_Tmpv1
3570 a_muold(i) =a_muold(i) +scalar(i,k,j,im)*a_Tmpv1
3571 a_scalar(i,k,j,im) =Tmpv300(i,j)*a_Tmpv1
3572 ENDDO
3573 ENDDO
3575 DO i =its, min(ite, ide-1)
3576 a_mu_new(i,j) =a_mu_new(i,j)-a_r_munew(i)/(mu_new(i,j)+mu_base(i,j))/(mu_new(i,j)+mu_base(i,j))
3577 ENDDO
3579 a_r_munew(its:min(ite,ide-1)) =0.0
3580 a_mu_old(its:min(ite,ide-1),j) =a_mu_old(its:min(ite,ide-1),j) +a_muold(its:min(ite,ide-1))
3581 a_muold(its:min(ite,ide-1)) =0.0
3583 ENDDO
3585 a_sc_tend(i_start_spc:i_end_spc,k_start_spc:k_end_spc,j_start_spc:j_end_spc,im) =a_tendency(&
3586 i_start_spc:i_end_spc,k_start_spc:k_end_spc,j_start_spc:j_end_spc)
3588 ENDDO
3590 DEALLOCATE (Tmpv300)
3592 END SUBROUTINE a_rk_update_scalar_pd
3594 !------------------------------------------------------------
3596 ! Generated by TAPENADE (INRIA, Tropics team)
3597 ! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
3598 !
3599 ! Differentiation of calculate_phy_tend in reverse (adjoint) mode:
3600 ! gradient of useful results: rthndgdten rublten rqvndgdten
3601 ! rthraten rqccuten rthcuten rqicuten rvndgdten
3602 ! rqscuten rqrshten rqvshten rucuten rvshten rqvblten
3603 ! rvblten rqcshten rthshten rqgshten rqishten rqcblten
3604 ! rthblten rqrcuten rqiblten rqsshten rqvcuten rvcuten
3605 ! rushten muu muv rundgdten mu
3606 ! with respect to varying inputs: rthndgdten rublten rqvndgdten
3607 ! rthraten rqccuten rthcuten rqicuten rvndgdten
3608 ! rqscuten rqrshten rqvshten rucuten rvshten rqvblten
3609 ! rvblten rqcshten rthshten rqgshten rqishten rqcblten
3610 ! rthblten rqrcuten rqiblten rqsshten rqvcuten rvcuten
3611 ! rushten muu muv rundgdten mu
3612 ! RW status of diff variables: rthndgdten:in-out rublten:in-out
3613 ! rqvndgdten:in-out rthraten:in-out rqccuten:in-out
3614 ! rthcuten:in-out rqicuten:in-out rvndgdten:in-out
3615 ! rqscuten:in-out rqrshten:in-out rqvshten:in-out
3616 ! rucuten:in-out rvshten:in-out rqvblten:in-out
3617 ! rvblten:in-out rqcshten:in-out rthshten:in-out
3618 ! rqgshten:in-out rqishten:in-out rqcblten:in-out
3619 ! rthblten:in-out rqrcuten:in-out rqiblten:in-out
3620 ! rqsshten:in-out rqvcuten:in-out rvcuten:in-out
3621 ! rushten:in-out muu:incr muv:incr rundgdten:in-out
3622 ! mu:incr
3623 SUBROUTINE A_CALCULATE_PHY_TEND(config_flags, mu, mub, muu, muub, muv, &
3624 & muvb, pi3d, rthraten, rthratenb, rublten, rubltenb, rvblten, rvbltenb&
3625 & , rthblten, rthbltenb, rqvblten, rqvbltenb, rqcblten, rqcbltenb, &
3626 & rqiblten, rqibltenb, rucuten, rucutenb, rvcuten, rvcutenb, rthcuten, &
3627 & rthcutenb, rqvcuten, rqvcutenb, rqccuten, rqccutenb, rqrcuten, &
3628 & rqrcutenb, rqicuten, rqicutenb, rqscuten, rqscutenb, rushten, rushtenb&
3629 & , rvshten, rvshtenb, rthshten, rthshtenb, rqvshten, rqvshtenb, &
3630 & rqcshten, rqcshtenb, rqrshten, rqrshtenb, rqishten, rqishtenb, &
3631 & rqsshten, rqsshtenb, rqgshten, rqgshtenb, rundgdten, rundgdtenb, &
3632 & rvndgdten, rvndgdtenb, rthndgdten, rthndgdtenb, rqvndgdten, &
3633 & rqvndgdtenb, rmundgdten, ids, ide, jds, jde, kds, kde, ims, ime, jms, &
3634 & jme, kms, kme, its, ite, jts, jte, kts, kte)
3635 IMPLICIT NONE
3636 TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
3637 INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
3638 & jme, kms, kme, its, ite, jts, jte, kts, kte
3639 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: pi3d
3640 REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, muu, muv
3641 REAL, DIMENSION(ims:ime, jms:jme) :: mub, muub, muvb
3642 ! radiation
3643 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthraten
3644 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rthratenb
3645 ! cumulus
3646 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rucuten, &
3647 & rvcuten, rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, &
3648 & rushten, rvshten, rthshten, rqvshten, rqcshten, rqrshten, rqishten, &
3649 & rqsshten, rqgshten
3650 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rucutenb, rvcutenb, &
3651 & rthcutenb, rqvcutenb, rqccutenb, rqrcutenb, rqicutenb, rqscutenb, &
3652 & rushtenb, rvshtenb, rthshtenb, rqvshtenb, rqcshtenb, rqrshtenb, &
3653 & rqishtenb, rqsshtenb, rqgshtenb
3654 ! pbl
3655 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rublten, &
3656 & rvblten, rthblten, rqvblten, rqcblten, rqiblten
3657 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rubltenb, rvbltenb, &
3658 & rthbltenb, rqvbltenb, rqcbltenb, rqibltenb
3659 ! fdda
3660 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rundgdten&
3661 & , rvndgdten, rthndgdten, rqvndgdten
3662 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rundgdtenb, rvndgdtenb, &
3663 & rthndgdtenb, rqvndgdtenb
3664 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rmundgdten
3665 INTEGER :: i, k, j
3666 INTEGER :: itf, ktf, jtf, itsu, jtsv
3667 INTEGER :: branch
3668 IF (ite .GT. ide - 1) THEN
3669 itf = ide - 1
3670 ELSE
3671 itf = ite
3672 END IF
3673 IF (jte .GT. jde - 1) THEN
3674 jtf = jde - 1
3675 ELSE
3676 jtf = jte
3677 END IF
3678 IF (kte .GT. kde - 1) THEN
3679 ktf = kde - 1
3680 ELSE
3681 ktf = kte
3682 END IF
3683 IF (its .LT. ids + 1) THEN
3684 itsu = ids + 1
3685 ELSE
3686 itsu = its
3687 END IF
3688 IF (jts .LT. jds + 1) THEN
3689 jtsv = jds + 1
3690 ELSE
3691 jtsv = jts
3692 END IF
3693 ! radiation
3694 IF (config_flags%ra_lw_physics .GT. 0 .OR. config_flags%ra_sw_physics &
3695 & .GT. 0) THEN
3696 CALL PUSHCONTROL1B(0)
3697 ELSE
3698 CALL PUSHCONTROL1B(1)
3699 END IF
3700 ! cumulus
3701 IF (config_flags%cu_physics .GT. 0) THEN
3702 IF (p_qc .GE. param_first_scalar) THEN
3703 CALL PUSHCONTROL1B(0)
3704 ELSE
3705 CALL PUSHCONTROL1B(1)
3706 END IF
3707 IF (p_qr .GE. param_first_scalar) THEN
3708 CALL PUSHCONTROL1B(0)
3709 ELSE
3710 CALL PUSHCONTROL1B(1)
3711 END IF
3712 IF (p_qi .GE. param_first_scalar) THEN
3713 CALL PUSHCONTROL1B(0)
3714 ELSE
3715 CALL PUSHCONTROL1B(1)
3716 END IF
3717 IF (p_qs .GE. param_first_scalar) THEN
3718 CALL PUSHCONTROL2B(0)
3719 ELSE
3720 CALL PUSHCONTROL2B(1)
3721 END IF
3722 ELSE
3723 CALL PUSHCONTROL2B(2)
3724 END IF
3725 ! shallow cumulus
3726 IF (config_flags%shcu_physics .GT. 0) THEN
3727 IF (p_qc .GE. param_first_scalar) THEN
3728 CALL PUSHCONTROL1B(0)
3729 ELSE
3730 CALL PUSHCONTROL1B(1)
3731 END IF
3732 IF (p_qr .GE. param_first_scalar) THEN
3733 CALL PUSHCONTROL1B(0)
3734 ELSE
3735 CALL PUSHCONTROL1B(1)
3736 END IF
3737 IF (p_qi .GE. param_first_scalar) THEN
3738 CALL PUSHCONTROL1B(0)
3739 ELSE
3740 CALL PUSHCONTROL1B(1)
3741 END IF
3742 IF (p_qs .GE. param_first_scalar) THEN
3743 CALL PUSHCONTROL1B(0)
3744 ELSE
3745 CALL PUSHCONTROL1B(1)
3746 END IF
3747 IF (p_qg .GE. param_first_scalar) THEN
3748 CALL PUSHCONTROL2B(0)
3749 ELSE
3750 CALL PUSHCONTROL2B(1)
3751 END IF
3752 ELSE
3753 CALL PUSHCONTROL2B(2)
3754 END IF
3755 ! pbl
3756 IF (config_flags%bl_pbl_physics .GT. 0) THEN
3757 IF (p_qv .GE. param_first_scalar) THEN
3758 CALL PUSHCONTROL1B(0)
3759 ELSE
3760 CALL PUSHCONTROL1B(1)
3761 END IF
3762 IF (p_qc .GE. param_first_scalar) THEN
3763 CALL PUSHCONTROL1B(0)
3764 ELSE
3765 CALL PUSHCONTROL1B(1)
3766 END IF
3767 IF (p_qi .GE. param_first_scalar) THEN
3768 CALL PUSHCONTROL2B(0)
3769 ELSE
3770 CALL PUSHCONTROL2B(1)
3771 END IF
3772 ELSE
3773 CALL PUSHCONTROL2B(2)
3774 END IF
3775 ! fdda
3776 ! note fdda u and v tendencies are staggered, also only interior points have muu/muv,
3777 ! so only couple those
3778 IF (config_flags%grid_fdda .GT. 0) THEN
3779 ! RMUNDGDTEN(I,J) - no coupling
3780 ! if( i == itf/2 .AND. j == jtf/2 .AND. k == ktf/2 ) &
3781 ! write(*,'(a,3i6,e15.5)') 'th after=',i,k,j, RTHNDGDTEN(I,K,J)
3782 IF (p_qv .GE. param_first_scalar) THEN
3783 DO j=jtf,jts,-1
3784 DO k=ktf,kts,-1
3785 DO i=itf,its,-1
3786 mub(i, j) = mub(i, j) + rqvndgdten(i, k, j)*rqvndgdtenb(i, k&
3787 & , j)
3788 rqvndgdtenb(i, k, j) = mu(i, j)*rqvndgdtenb(i, k, j)
3789 END DO
3790 END DO
3791 END DO
3792 END IF
3793 DO j=jtf,jts,-1
3794 DO k=ktf,kts,-1
3795 DO i=itf,its,-1
3796 mub(i, j) = mub(i, j) + rthndgdten(i, k, j)*rthndgdtenb(i, k, &
3797 & j)
3798 rthndgdtenb(i, k, j) = mu(i, j)*rthndgdtenb(i, k, j)
3799 END DO
3800 END DO
3801 END DO
3802 DO j=jtf,jtsv,-1
3803 DO k=ktf,kts,-1
3804 DO i=itf,its,-1
3805 muvb(i, j) = muvb(i, j) + rvndgdten(i, k, j)*rvndgdtenb(i, k, &
3806 & j)
3807 rvndgdtenb(i, k, j) = muv(i, j)*rvndgdtenb(i, k, j)
3808 END DO
3809 END DO
3810 END DO
3811 DO j=jtf,jts,-1
3812 DO k=ktf,kts,-1
3813 DO i=itf,itsu,-1
3814 muub(i, j) = muub(i, j) + rundgdten(i, k, j)*rundgdtenb(i, k, &
3815 & j)
3816 rundgdtenb(i, k, j) = muu(i, j)*rundgdtenb(i, k, j)
3817 END DO
3818 END DO
3819 END DO
3820 END IF
3821 CALL POPCONTROL2B(branch)
3822 IF (branch .EQ. 0) THEN
3823 DO j=jtf,jts,-1
3824 DO k=ktf,kts,-1
3825 DO i=itf,its,-1
3826 mub(i, j) = mub(i, j) + rqiblten(i, k, j)*rqibltenb(i, k, j)
3827 rqibltenb(i, k, j) = mu(i, j)*rqibltenb(i, k, j)
3828 END DO
3829 END DO
3830 END DO
3831 ELSE IF (branch .NE. 1) THEN
3832 GOTO 100
3833 END IF
3834 CALL POPCONTROL1B(branch)
3835 IF (branch .EQ. 0) THEN
3836 DO j=jtf,jts,-1
3837 DO k=ktf,kts,-1
3838 DO i=itf,its,-1
3839 mub(i, j) = mub(i, j) + rqcblten(i, k, j)*rqcbltenb(i, k, j)
3840 rqcbltenb(i, k, j) = mu(i, j)*rqcbltenb(i, k, j)
3841 END DO
3842 END DO
3843 END DO
3844 END IF
3845 CALL POPCONTROL1B(branch)
3846 IF (branch .EQ. 0) THEN
3847 DO j=jtf,jts,-1
3848 DO k=ktf,kts,-1
3849 DO i=itf,its,-1
3850 mub(i, j) = mub(i, j) + rqvblten(i, k, j)*rqvbltenb(i, k, j)
3851 rqvbltenb(i, k, j) = mu(i, j)*rqvbltenb(i, k, j)
3852 END DO
3853 END DO
3854 END DO
3855 END IF
3856 DO j=jtf,jts,-1
3857 DO k=ktf,kts,-1
3858 DO i=itf,its,-1
3859 mub(i, j) = mub(i, j) + rvblten(i, k, j)*rvbltenb(i, k, j) + &
3860 & rublten(i, k, j)*rubltenb(i, k, j) + rthblten(i, k, j)*&
3861 & rthbltenb(i, k, j)
3862 rthbltenb(i, k, j) = mu(i, j)*rthbltenb(i, k, j)
3863 rvbltenb(i, k, j) = mu(i, j)*rvbltenb(i, k, j)
3864 rubltenb(i, k, j) = mu(i, j)*rubltenb(i, k, j)
3865 END DO
3866 END DO
3867 END DO
3868 100 CALL POPCONTROL2B(branch)
3869 IF (branch .EQ. 0) THEN
3870 DO j=jtf,jts,-1
3871 DO i=itf,its,-1
3872 DO k=ktf,kts,-1
3873 mub(i, j) = mub(i, j) + rqgshten(i, k, j)*rqgshtenb(i, k, j)
3874 rqgshtenb(i, k, j) = mu(i, j)*rqgshtenb(i, k, j)
3875 END DO
3876 END DO
3877 END DO
3878 ELSE IF (branch .NE. 1) THEN
3879 GOTO 110
3880 END IF
3881 CALL POPCONTROL1B(branch)
3882 IF (branch .EQ. 0) THEN
3883 DO j=jtf,jts,-1
3884 DO i=itf,its,-1
3885 DO k=ktf,kts,-1
3886 mub(i, j) = mub(i, j) + rqsshten(i, k, j)*rqsshtenb(i, k, j)
3887 rqsshtenb(i, k, j) = mu(i, j)*rqsshtenb(i, k, j)
3888 END DO
3889 END DO
3890 END DO
3891 END IF
3892 CALL POPCONTROL1B(branch)
3893 IF (branch .EQ. 0) THEN
3894 DO j=jtf,jts,-1
3895 DO i=itf,its,-1
3896 DO k=ktf,kts,-1
3897 mub(i, j) = mub(i, j) + rqishten(i, k, j)*rqishtenb(i, k, j)
3898 rqishtenb(i, k, j) = mu(i, j)*rqishtenb(i, k, j)
3899 END DO
3900 END DO
3901 END DO
3902 END IF
3903 CALL POPCONTROL1B(branch)
3904 IF (branch .EQ. 0) THEN
3905 DO j=jtf,jts,-1
3906 DO i=itf,its,-1
3907 DO k=ktf,kts,-1
3908 mub(i, j) = mub(i, j) + rqrshten(i, k, j)*rqrshtenb(i, k, j)
3909 rqrshtenb(i, k, j) = mu(i, j)*rqrshtenb(i, k, j)
3910 END DO
3911 END DO
3912 END DO
3913 END IF
3914 CALL POPCONTROL1B(branch)
3915 IF (branch .EQ. 0) THEN
3916 DO j=jtf,jts,-1
3917 DO i=itf,its,-1
3918 DO k=ktf,kts,-1
3919 mub(i, j) = mub(i, j) + rqcshten(i, k, j)*rqcshtenb(i, k, j)
3920 rqcshtenb(i, k, j) = mu(i, j)*rqcshtenb(i, k, j)
3921 END DO
3922 END DO
3923 END DO
3924 END IF
3925 DO j=jtf,jts,-1
3926 DO i=itf,its,-1
3927 DO k=ktf,kts,-1
3928 mub(i, j) = mub(i, j) + rthshten(i, k, j)*rthshtenb(i, k, j) + &
3929 & rushten(i, k, j)*rushtenb(i, k, j) + rvshten(i, k, j)*rvshtenb&
3930 & (i, k, j) + rqvshten(i, k, j)*rqvshtenb(i, k, j)
3931 rqvshtenb(i, k, j) = mu(i, j)*rqvshtenb(i, k, j)
3932 rthshtenb(i, k, j) = mu(i, j)*rthshtenb(i, k, j)
3933 rvshtenb(i, k, j) = mu(i, j)*rvshtenb(i, k, j)
3934 rushtenb(i, k, j) = mu(i, j)*rushtenb(i, k, j)
3935 END DO
3936 END DO
3937 END DO
3938 110 CALL POPCONTROL2B(branch)
3939 IF (branch .EQ. 0) THEN
3940 DO j=jtf,jts,-1
3941 DO i=itf,its,-1
3942 DO k=ktf,kts,-1
3943 mub(i, j) = mub(i, j) + rqscuten(i, k, j)*rqscutenb(i, k, j)
3944 rqscutenb(i, k, j) = mu(i, j)*rqscutenb(i, k, j)
3945 END DO
3946 END DO
3947 END DO
3948 ELSE IF (branch .NE. 1) THEN
3949 GOTO 120
3950 END IF
3951 CALL POPCONTROL1B(branch)
3952 IF (branch .EQ. 0) THEN
3953 DO j=jtf,jts,-1
3954 DO i=itf,its,-1
3955 DO k=ktf,kts,-1
3956 mub(i, j) = mub(i, j) + rqicuten(i, k, j)*rqicutenb(i, k, j)
3957 rqicutenb(i, k, j) = mu(i, j)*rqicutenb(i, k, j)
3958 END DO
3959 END DO
3960 END DO
3961 END IF
3962 CALL POPCONTROL1B(branch)
3963 IF (branch .EQ. 0) THEN
3964 DO j=jtf,jts,-1
3965 DO i=itf,its,-1
3966 DO k=ktf,kts,-1
3967 mub(i, j) = mub(i, j) + rqrcuten(i, k, j)*rqrcutenb(i, k, j)
3968 rqrcutenb(i, k, j) = mu(i, j)*rqrcutenb(i, k, j)
3969 END DO
3970 END DO
3971 END DO
3972 END IF
3973 CALL POPCONTROL1B(branch)
3974 IF (branch .EQ. 0) THEN
3975 DO j=jtf,jts,-1
3976 DO i=itf,its,-1
3977 DO k=ktf,kts,-1
3978 mub(i, j) = mub(i, j) + rqccuten(i, k, j)*rqccutenb(i, k, j)
3979 rqccutenb(i, k, j) = mu(i, j)*rqccutenb(i, k, j)
3980 END DO
3981 END DO
3982 END DO
3983 END IF
3984 DO j=jtf,jts,-1
3985 DO i=itf,its,-1
3986 DO k=ktf,kts,-1
3987 mub(i, j) = mub(i, j) + rthcuten(i, k, j)*rthcutenb(i, k, j) + &
3988 & rucuten(i, k, j)*rucutenb(i, k, j) + rvcuten(i, k, j)*rvcutenb&
3989 & (i, k, j) + rqvcuten(i, k, j)*rqvcutenb(i, k, j)
3990 rqvcutenb(i, k, j) = mu(i, j)*rqvcutenb(i, k, j)
3991 rthcutenb(i, k, j) = mu(i, j)*rthcutenb(i, k, j)
3992 rvcutenb(i, k, j) = mu(i, j)*rvcutenb(i, k, j)
3993 rucutenb(i, k, j) = mu(i, j)*rucutenb(i, k, j)
3994 END DO
3995 END DO
3996 END DO
3997 120 CALL POPCONTROL1B(branch)
3998 IF (branch .EQ. 0) THEN
3999 DO j=jtf,jts,-1
4000 DO k=ktf,kts,-1
4001 DO i=itf,its,-1
4002 mub(i, j) = mub(i, j) + rthraten(i, k, j)*rthratenb(i, k, j)
4003 rthratenb(i, k, j) = mu(i, j)*rthratenb(i, k, j)
4004 END DO
4005 END DO
4006 END DO
4007 END IF
4008 END SUBROUTINE A_CALCULATE_PHY_TEND
4010 !-----------------------------------------------------------
4012 SUBROUTINE a_init_zero_tendency(a_ru_tendf, &
4013 a_rv_tendf, &
4014 a_rw_tendf, &
4015 a_ph_tendf, &
4016 a_t_tendf, &
4017 a_tke_tendf, &
4018 a_mu_tendf, &
4019 a_moist_tendf, &
4020 ! NPan - 05/26/10 {
4021 ! Uncomment the corresponding args when chem or tracer is needed.
4022 ! a_chem_tendf, &
4023 a_scalar_tendf, &
4024 a_tracer_tendf, &
4025 ! NPan }
4026 n_tracer, &
4027 n_moist,n_chem,n_scalar,rk_step, &
4028 ids, ide, jds, jde, kds, kde, &
4029 ims, ime, jms, jme, kms, kme, &
4030 its, ite, jts, jte, kts, kte )
4031 !-----------------------------------------------------------------------
4032 IMPLICIT NONE
4033 !-----------------------------------------------------------------------
4035 INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
4036 ims, ime, jms, jme, kms, kme, &
4037 its, ite, jts, jte, kts, kte
4039 INTEGER , INTENT(IN ) :: n_moist,n_chem,n_scalar,n_tracer,rk_step
4041 REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: &
4042 a_ru_tendf, &
4043 a_rv_tendf, &
4044 a_rw_tendf, &
4045 a_ph_tendf, &
4046 a_t_tendf, &
4047 a_tke_tendf
4049 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: a_mu_tendf
4051 REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist),INTENT(INOUT)::&
4052 a_moist_tendf
4054 ! NPan - 05/26/10 {
4055 ! Uncomment the corresponding definations when chem is needed.
4056 ! REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_chem ),INTENT(INOUT)::&
4057 ! a_chem_tendf
4058 REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_tracer ),INTENT(INOUT)::&
4059 a_tracer_tendf
4060 REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_scalar ),INTENT(INOUT)::&
4061 a_scalar_tendf
4062 ! NPan }
4064 ! LOCAL VARS
4066 INTEGER :: im, ic, is
4068 !<DESCRIPTION>
4069 !
4070 ! init_zero_tendency
4071 ! sets tendency arrays to zero for all prognostic variables.
4072 !
4073 !</DESCRIPTION>
4076 CALL a_zero_tend ( a_ru_tendf, &
4077 ids, ide, jds, jde, kds, kde, &
4078 ims, ime, jms, jme, kms, kme, &
4079 its, ite, jts, jte, kts, kte )
4081 CALL a_zero_tend ( a_rv_tendf, &
4082 ids, ide, jds, jde, kds, kde, &
4083 ims, ime, jms, jme, kms, kme, &
4084 its, ite, jts, jte, kts, kte )
4086 CALL a_zero_tend ( a_rw_tendf, &
4087 ids, ide, jds, jde, kds, kde, &
4088 ims, ime, jms, jme, kms, kme, &
4089 its, ite, jts, jte, kts, kte )
4091 CALL a_zero_tend ( a_ph_tendf, &
4092 ids, ide, jds, jde, kds, kde, &
4093 ims, ime, jms, jme, kms, kme, &
4094 its, ite, jts, jte, kts, kte )
4096 CALL a_zero_tend ( a_t_tendf, &
4097 ids, ide, jds, jde, kds, kde, &
4098 ims, ime, jms, jme, kms, kme, &
4099 its, ite, jts, jte, kts, kte )
4101 CALL a_zero_tend ( a_tke_tendf, &
4102 ids, ide, jds, jde, kds, kde, &
4103 ims, ime, jms, jme, kms, kme, &
4104 its, ite, jts, jte, kts, kte )
4106 CALL a_zero_tend2d ( a_mu_tendf, &
4107 ids, ide, jds, jde, kds, kds, &
4108 ims, ime, jms, jme, kms, kms, &
4109 its, ite, jts, jte, kts, kts )
4111 ! DO im=PARAM_FIRST_SCALAR,n_moist
4112 DO im=1,n_moist ! make sure first one is zero too
4113 CALL a_zero_tend ( a_moist_tendf(ims,kms,jms,im), &
4114 ids, ide, jds, jde, kds, kde, &
4115 ims, ime, jms, jme, kms, kme, &
4116 its, ite, jts, jte, kts, kte )
4117 ENDDO
4119 ! NPan - 05/26/10 {
4120 ! Uncomment the corresponding statements when chem is needed.
4121 !! DO ic=PARAM_FIRST_SCALAR,n_chem
4122 ! DO ic=1,n_chem !! make sure first one is zero too
4123 ! CALL a_zero_tend ( a_chem_tendf(ims,kms,jms,ic), &
4124 ! ids, ide, jds, jde, kds, kde, &
4125 ! ims, ime, jms, jme, kms, kme, &
4126 ! its, ite, jts, jte, kts, kte )
4127 ! ENDDO
4129 ! DO ic=PARAM_FIRST_SCALAR,n_tracer
4130 DO ic=1,n_tracer !! make sure first one is zero too
4131 CALL a_zero_tend ( a_tracer_tendf(ims,kms,jms,ic), &
4132 ids, ide, jds, jde, kds, kde, &
4133 ims, ime, jms, jme, kms, kme, &
4134 its, ite, jts, jte, kts, kte )
4135 ENDDO
4137 ! DO ic=PARAM_FIRST_SCALAR,n_scalar
4138 DO ic=1,n_scalar ! make sure first one is zero too
4139 CALL a_zero_tend ( a_scalar_tendf(ims,kms,jms,ic), &
4140 ids, ide, jds, jde, kds, kde, &
4141 ims, ime, jms, jme, kms, kme, &
4142 its, ite, jts, jte, kts, kte )
4143 ENDDO
4144 ! NPan }
4146 END SUBROUTINE a_init_zero_tendency
4148 !-----------------------------------------------------------------------
4150 ! Revised by Ning Pan, 2010-08-03
4151 ! SUBROUTINE a_bound_tke(tke,a_tke,tke_upper_bound,a_tke_upper_bound,ids,ide,jds, &
4152 SUBROUTINE a_bound_tke(tke,a_tke,tke_upper_bound,ids,ide,jds, &
4153 jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
4155 !PART I: DECLARATION OF VARIABLES
4157 IMPLICIT NONE
4159 INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
4160 INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
4161 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tke,a_tke
4162 ! Revised by Ning Pan, 2010-08-03
4163 ! REAL :: tke_upper_bound,a_tke_upper_bound
4164 REAL :: tke_upper_bound
4165 INTEGER :: i,k,j
4167 REAL :: a_Tmpv1,Tmpv001
4169 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
4171 !LPB[0]
4172 DO j =min(jte, jde-1), jts, -1
4174 ! DO k =kts, kte-1
4175 ! DO i =its, min(ite, ide-1)
4176 ! Tmpv001 =min(tke_upper_bound, max(tke(i,k,j), 0.))
4177 ! tke(i,k,j) =Tmpv001
4179 ! ENDDO
4180 ! ENDDO
4182 DO k =kte-1, kts, -1
4183 DO i =min(ite, ide-1), its, -1
4184 a_Tmpv1 =a_tke(i,k,j)
4185 a_tke(i,k,j) =0.0
4186 ! Remarked by Ning Pan, 2010-08-03
4187 ! a_tke_upper_bound =a_tke_upper_bound +(1.0 -sign(1.0, tke_upper_bound -max( &
4188 ! tke(i,k,j), 0.)))*0.5*1.0*a_Tmpv1
4189 a_tke(i,k,j) =a_tke(i,k,j) +(1.0 +sign(1.0, tke_upper_bound -max(tke(i,k,j) &
4190 , 0.)))*0.5*(1.0 +(1.0)*sign(1.0, tke(i,k,j) -0.))*0.5*a_Tmpv1
4191 ENDDO
4192 ENDDO
4194 ENDDO
4196 END SUBROUTINE a_bound_tke
4199 END MODULE a_module_em