module_diffusion_em_ad.F
References to this file elsewhere.
1 ! DISCLAIMER
2 !
3 ! This file was generated by TAF version 1.7.18
4 !
5 ! FASTOPT DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED,
6 ! INCLUDING (WITHOUT LIMITATION) ALL IMPLIED WARRANTIES OF
7 ! MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE, WITH
8 ! RESPECT TO THE SOFTWARE AND USER PROGRAMS. IN NO EVENT
9 ! SHALL FASTOPT BE LIABLE FOR ANY LOST OR ANTICIPATED PROF-
10 ! ITS, OR ANY INDIRECT, INCIDENTAL, EXEMPLARY, SPECIAL, OR
11 ! CONSEQUENTIAL DAMAGES, WHETHER OR NOT FASTOPT WAS ADVISED
12 ! OF THE POSSIBILITY OF SUCH DAMAGES.
13 !
14 ! Haftungsbeschraenkung
15 ! FastOpt gibt ausdruecklich keine Gewaehr, explizit oder indirekt,
16 ! bezueglich der Brauchbarkeit der Software fuer einen bestimmten
17 ! Zweck. Unter keinen Umstaenden ist FastOpt haftbar fuer
18 ! irgendeinen Verlust oder nicht eintretenden erwarteten Gewinn und
19 ! allen indirekten, zufaelligen, exemplarischen oder speziellen
20 ! Schaeden oder Folgeschaeden unabhaengig von einer eventuellen
21 ! Mitteilung darueber an FastOpt.
22 !
23 module a_module_diffusion_em
24 !******************************************************************
25 !******************************************************************
26 !** This routine was generated by Automatic differentiation. **
27 !** FastOpt: Transformation of Algorithm in Fortran, TAF 1.7.18 **
28 !******************************************************************
29 !******************************************************************
30 !==============================================
31 ! referencing used modules
32 !==============================================
33 use module_configure
34 use module_bc
35 use a_module_bc
36 use module_state_description
37 use module_big_step_utilities_em
38 use a_module_big_step_utilities_em
39 use module_model_constants
40 use module_wrf_error
41 use module_diffusion_em
42
43 !==============================================
44 ! all entries are defined explicitly
45 !==============================================
46 implicit none
47
48 contains
49 subroutine a_cal_dampkm( xkmhd, a_xkmhd, dx, dt, dampcoef, rdz, rdzw, zdamp, ide, jde, kde, ims, ime, jms, jme, kms, kme, its, ite,&
50 & jts, jte, kts, kte )
51 !******************************************************************
52 !******************************************************************
53 !** This routine was generated by Automatic differentiation. **
54 !** FastOpt: Transformation of Algorithm in Fortran, TAF 1.7.18 **
55 !******************************************************************
56 !******************************************************************
57 !==============================================
58 ! all entries are defined explicitly
59 !==============================================
60 implicit none
61
62 !==============================================
63 ! declare arguments
64 !==============================================
65 integer, intent(in) :: ime
66 integer, intent(in) :: ims
67 integer, intent(in) :: jme
68 integer, intent(in) :: jms
69 integer, intent(in) :: kme
70 integer, intent(in) :: kms
71 real, intent(inout) :: a_xkmhd(ims:ime,kms:kme,jms:jme)
72 real, intent(in) :: dampcoef
73 real, intent(in) :: dt
74 real, intent(in) :: dx
75 integer, intent(in) :: ide
76 integer, intent(in) :: ite
77 integer, intent(in) :: its
78 integer, intent(in) :: jde
79 integer, intent(in) :: jte
80 integer, intent(in) :: jts
81 integer, intent(in) :: kde
82 integer, intent(in) :: kte
83 integer, intent(in) :: kts
84 real, intent(in) :: rdz(ims:ime,kms:kme,jms:jme)
85 real, intent(in) :: rdzw(ims:ime,kms:kme,jms:jme)
86 real, intent(inout) :: xkmhd(ims:ime,kms:kme,jms:jme)
87 real, intent(in) :: zdamp
88
89 !==============================================
90 ! declare local variables
91 !==============================================
92 real dampk(its:ite,kts:kte,jts:jte)
93 real degrad90
94 real deltaz(its:ite)
95 real dz
96 integer i
97 integer i_end
98 integer i_start
99 integer j
100 integer j_end
101 integer j_start
102 integer k
103 real kmmax
104 integer ktf
105 integer ktfm1
106 real tmp
107
108 !----------------------------------------------
109 ! ROUTINE BODY
110 !----------------------------------------------
111 ktf = min(kte,kde-1)
112 ! recompute : ktf
113 ktfm1 = ktf-1
114 ! recompute : ktfm1
115 i_start = its
116 ! recompute : i_start
117 i_end = min(ite,ide-1)
118 ! recompute : i_end
119 j_start = jts
120 ! recompute : j_start
121 j_end = min(jte,jde-1)
122 ! recompute : j_end
123 kmmax = dx*dx/dt
124 ! recompute : kmmax
125 degrad90 = degrad*90.
126 ! recompute : degrad90
127 do j = j_start, j_end
128 k = ktf
129 do i = i_start, i_end
130 dz = 1./rdzw(i,k,j)
131 deltaz(i) = 0.5*dz
132 tmp = min(deltaz(i)/zdamp,1.)
133 dampk(i,k,j) = cos(degrad90*tmp)*kmmax*dampcoef
134 end do
135 do k = ktfm1, kts, -1
136 do i = i_start, i_end
137 dz = 1./rdz(i,k,j)
138 deltaz(i) = deltaz(i)+dz
139 tmp = min(deltaz(i)/zdamp,1.)
140 dampk(i,k,j) = cos(degrad90*tmp)*kmmax*dampcoef
141 end do
142 end do
143 end do
144 ! recompute : dampk
145 do j = j_start, j_end
146 do k = kts, ktf
147 do i = i_start, i_end
148 a_xkmhd(i,k,j) = a_xkmhd(i,k,j)*(0.5+sign(0.5,xkmhd(i,k,j)-dampk(i,k,j)))
149 end do
150 end do
151 end do
152
153 end subroutine a_cal_dampkm
154
155
156 subroutine a_calc_l_scale( tke, bn2, a_bn2, l_scale, a_l_scale, i_start, i_end, ktf, j_start, j_end, dx, dy, rdzw, ims, ime, jms, &
157 &jme, kms, kme, its, ite, jts, jte, kts, kte )
158 !******************************************************************
159 !******************************************************************
160 !** This routine was generated by Automatic differentiation. **
161 !** FastOpt: Transformation of Algorithm in Fortran, TAF 1.7.18 **
162 !******************************************************************
163 !******************************************************************
164 !==============================================
165 ! all entries are defined explicitly
166 !==============================================
167 implicit none
168
169 !==============================================
170 ! declare arguments
171 !==============================================
172 integer, intent(in) :: ime
173 integer, intent(in) :: ims
174 integer, intent(in) :: jme
175 integer, intent(in) :: jms
176 integer, intent(in) :: kme
177 integer, intent(in) :: kms
178 real, intent(inout) :: a_bn2(ims:ime,kms:kme,jms:jme)
179 integer, intent(in) :: ite
180 integer, intent(in) :: its
181 integer, intent(in) :: jte
182 integer, intent(in) :: jts
183 integer, intent(in) :: kte
184 integer, intent(in) :: kts
185 real, intent(inout) :: a_l_scale(its:ite,kts:kte,jts:jte)
186 real, intent(in) :: bn2(ims:ime,kms:kme,jms:jme)
187 real, intent(in) :: dx
188 real, intent(in) :: dy
189 integer, intent(in) :: i_end
190 integer, intent(in) :: i_start
191 integer, intent(in) :: j_end
192 integer, intent(in) :: j_start
193 integer, intent(in) :: ktf
194 real, intent(out) :: l_scale(its:ite,kts:kte,jts:jte)
195 real, intent(in) :: rdzw(ims:ime,kms:kme,jms:jme)
196 real, intent(in) :: tke(ims:ime,kms:kme,jms:jme)
197
198 !==============================================
199 ! declare local variables
200 !==============================================
201 real deltas
202 integer i
203 integer j
204 integer k
205 real tmp
206
207 !----------------------------------------------
208 ! ROUTINE BODY
209 !----------------------------------------------
210 do j = j_start, j_end
211 do k = kts, ktf
212 do i = i_start, i_end
213 deltas = (dx*dy/rdzw(i,k,j))**0.33333333
214 ! recompute : deltas
215 l_scale(i,k,j) = deltas
216 if (bn2(i,k,j) .gt. 1.e-6) then
217 tmp = sqrt(max(tke(i,k,j),1.e-6))
218 ! recompute : tmp
219 l_scale(i,k,j) = 0.76*tmp/sqrt(bn2(i,k,j))
220 ! recompute : l_scale
221 l_scale(i,k,j) = min(l_scale(i,k,j),deltas)
222 ! recompute : l_scale
223 a_l_scale(i,k,j) = a_l_scale(i,k,j)*(0.5+sign(0.5,l_scale(i,k,j)-0.001*deltas))
224 ! recdepend vars : bn2,i,j,k,tmp
225 ! recompute pos : ASSIGN_STMT module_diffusion_em.f90:1870
226 ! recompute vars : l_scale
227 l_scale(i,k,j) = 0.76*tmp/sqrt(bn2(i,k,j))
228 ! recompute vars : l_scale
229 a_l_scale(i,k,j) = a_l_scale(i,k,j)*(0.5+sign(0.5,deltas-l_scale(i,k,j)))
230 a_bn2(i,k,j) = a_bn2(i,k,j)-a_l_scale(i,k,j)*(0.76*tmp*(1./(2.*sqrt(bn2(i,k,j))))/(sqrt(bn2(i,k,j))*sqrt(bn2(i,k,j))))
231 a_l_scale(i,k,j) = 0.
232 endif
233 a_l_scale(i,k,j) = 0.
234 end do
235 end do
236 end do
237
238 end subroutine a_calc_l_scale
239
240
241 subroutine a_calculate_km_kh( config_flags, dt, dampcoef, zdamp, damp_opt, xkmh, xkmhd, a_xkmhd, xkmv, xkhh, xkhv, bn2, a_bn2, &
242 &khdif, div, defor11, defor22, defor33, defor12, defor13, defor23, tke, p8w, a_p8w, t8w, a_t8w, theta, a_theta, t, a_t, p, a_p, &
243 &moist, a_moist, dn, dnw, dx, dy, rdz, rdzw, n_moist, cf1, cf2, cf3, kh_tke_upper_bound, ids, ide, jds, jde, kde, ims, ime, jms, &
244 &jme, kms, kme, its, ite, jts, jte, kts, kte )
245 !******************************************************************
246 !******************************************************************
247 !** This routine was generated by Automatic differentiation. **
248 !** FastOpt: Transformation of Algorithm in Fortran, TAF 1.7.18 **
249 !******************************************************************
250 !******************************************************************
251 !==============================================
252 ! all entries are defined explicitly
253 !==============================================
254 implicit none
255
256 !==============================================
257 ! declare arguments
258 !==============================================
259 integer, intent(in) :: ime
260 integer, intent(in) :: ims
261 integer, intent(in) :: jme
262 integer, intent(in) :: jms
263 integer, intent(in) :: kme
264 integer, intent(in) :: kms
265 real, intent(inout) :: a_bn2(ims:ime,kms:kme,jms:jme)
266 integer, intent(in) :: n_moist
267 real, intent(inout) :: a_moist(ims:ime,kms:kme,jms:jme,n_moist)
268 real, intent(inout) :: a_p(ims:ime,kms:kme,jms:jme)
269 real, intent(inout) :: a_p8w(ims:ime,kms:kme,jms:jme)
270 real, intent(inout) :: a_t(ims:ime,kms:kme,jms:jme)
271 real, intent(inout) :: a_t8w(ims:ime,kms:kme,jms:jme)
272 real, intent(inout) :: a_theta(ims:ime,kms:kme,jms:jme)
273 real, intent(inout) :: a_xkmhd(ims:ime,kms:kme,jms:jme)
274 real, intent(inout) :: bn2(ims:ime,kms:kme,jms:jme)
275 real, intent(in) :: cf1
276 real, intent(in) :: cf2
277 real, intent(in) :: cf3
278 type (grid_config_rec_type), intent(in) :: config_flags
279 integer, intent(in) :: damp_opt
280 real, intent(in) :: dampcoef
281 real, intent(in) :: defor11(ims:ime,kms:kme,jms:jme)
282 real, intent(in) :: defor12(ims:ime,kms:kme,jms:jme)
283 real, intent(in) :: defor13(ims:ime,kms:kme,jms:jme)
284 real, intent(in) :: defor22(ims:ime,kms:kme,jms:jme)
285 real, intent(in) :: defor23(ims:ime,kms:kme,jms:jme)
286 real, intent(in) :: defor33(ims:ime,kms:kme,jms:jme)
287 real, intent(in) :: div(ims:ime,kms:kme,jms:jme)
288 real, intent(in) :: dn(kms:kme)
289 real, intent(in) :: dnw(kms:kme)
290 real, intent(in) :: dt
291 real, intent(in) :: dx
292 real, intent(in) :: dy
293 integer, intent(in) :: ide
294 integer, intent(in) :: ids
295 integer, intent(in) :: ite
296 integer, intent(in) :: its
297 integer, intent(in) :: jde
298 integer, intent(in) :: jds
299 integer, intent(in) :: jte
300 integer, intent(in) :: jts
301 integer, intent(in) :: kde
302 real, intent(in) :: kh_tke_upper_bound
303 real, intent(in) :: khdif
304 integer, intent(in) :: kte
305 integer, intent(in) :: kts
306 real, intent(inout) :: moist(ims:ime,kms:kme,jms:jme,n_moist)
307 real, intent(in) :: p(ims:ime,kms:kme,jms:jme)
308 real, intent(in) :: p8w(ims:ime,kms:kme,jms:jme)
309 real, intent(in) :: rdz(ims:ime,kms:kme,jms:jme)
310 real, intent(in) :: rdzw(ims:ime,kms:kme,jms:jme)
311 real, intent(in) :: t(ims:ime,kms:kme,jms:jme)
312 real, intent(in) :: t8w(ims:ime,kms:kme,jms:jme)
313 real, intent(in) :: theta(ims:ime,kms:kme,jms:jme)
314 real, intent(inout) :: tke(ims:ime,kms:kme,jms:jme)
315 real, intent(inout) :: xkhh(ims:ime,kms:kme,jms:jme)
316 real, intent(inout) :: xkhv(ims:ime,kms:kme,jms:jme)
317 real, intent(inout) :: xkmh(ims:ime,kms:kme,jms:jme)
318 real, intent(inout) :: xkmhd(ims:ime,kms:kme,jms:jme)
319 real, intent(inout) :: xkmv(ims:ime,kms:kme,jms:jme)
320 real, intent(in) :: zdamp
321
322 !==============================================
323 ! declare local variables
324 !==============================================
325 real a_xkmhh(1+ime-ims,1+kme-kms,1+jme-jms)
326 real a_xkmhi(1+ime-ims,1+kme-kms,1+jme-jms)
327 real a_xkmhj(1+ime-ims,1+kme-kms,1+jme-jms)
328 real cr_len
329 integer kds
330 real kv_tke_upper_bound
331 real kvdif
332 logical warm_rain
333
334 !----------------------------------------------
335 ! RESET LOCAL ADJOINT VARIABLES
336 !----------------------------------------------
337 a_xkmhh(:,:,:) = 0.
338 a_xkmhi(:,:,:) = 0.
339 a_xkmhj(:,:,:) = 0.
340
341 !----------------------------------------------
342 ! ROUTINE BODY
343 !----------------------------------------------
344 call calculate_n2( config_flags,bn2,moist,theta,t,p,p8w,t8w,dnw,dn,rdz,rdzw,n_moist,cf1,cf2,cf3,warm_rain,ids,ide,jds,jde,kds,kde,&
345 &ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte )
346 ! recompute : bn2
347 km_coeg: select case ( config_flags%km_opt )
348 case (1) km_coeg
349 call isotropic_km( config_flags,xkmh,xkmhd,xkmv,xkhh,xkhv,khdif,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,&
350 &jts,jte,kts,kte )
351 case (2) km_coeg
352 call tke_km( config_flags,xkmh,xkmhd,xkmv,xkhh,xkhv,bn2,tke,p8w,t8w,theta,rdz,rdzw,dx,dy,cr_len,kh_tke_upper_bound,&
353 &kv_tke_upper_bound,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte )
354 case (3) km_coeg
355 call smag_km( config_flags,xkmh,xkmhd,xkmv,xkhh,xkhv,bn2,div,defor11,defor22,defor33,defor12,defor13,defor23,rdzw,dx,dy,cr_len,&
356 &ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte )
357 case (4) km_coeg
358 call smag2d_km( config_flags,xkmh,xkmhd,xkmv,xkhh,xkhv,defor11,defor22,defor12,rdzw,dx,dy,ids,ide,jds,jde,kds,kde,ims,ime,jms,&
359 &jme,kms,kme,its,ite,jts,jte,kts,kte )
360 end select km_coeg
361 ! recompute : xkmhd
362 if (damp_opt .eq. 1) then
363 call a_cal_dampkm( xkmhd,a_xkmhd,dx,dt,dampcoef,rdz,rdzw,zdamp,ide,jde,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte )
364 endif
365 a_km_coef: select case ( config_flags%km_opt )
366 case (1) a_km_coef
367 call a_isotropic_km( a_xkmhd,ide,jde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte )
368 case (2) a_km_coef
369 call a_tke_km( config_flags,xkmh,a_xkmhh,a_xkmhd,bn2,a_bn2,tke,rdzw,dx,dy,kh_tke_upper_bound,ids,ide,jds,jde,kde,ims,ime,jms,jme,&
370 &kms,kme,its,ite,jts,jte,kts,kte )
371 case (3) a_km_coef
372 call a_smag_km( config_flags,xkmh,a_xkmhi,a_xkmhd,bn2,a_bn2,defor11,defor22,defor33,defor12,defor13,defor23,rdzw,dx,dy,ids,ide,&
373 &jds,jde,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte )
374 case (4) a_km_coef
375 call a_smag2d_km( config_flags,xkmh,a_xkmhj,a_xkmhd,defor11,defor22,defor12,dx,dy,ids,ide,jds,jde,kde,ims,ime,jms,jme,kms,kme,&
376 &its,ite,jts,jte,kts,kte )
377 end select a_km_coef
378 call a_calculate_n2( config_flags,a_bn2,moist,a_moist,theta,a_theta,t,a_t,p,a_p,p8w,a_p8w,t8w,a_t8w,rdz,rdzw,n_moist,cf1,cf2,cf3,&
379 &ids,ide,jds,jde,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte )
380
381 end subroutine a_calculate_km_kh
382
383
384 subroutine a_calculate_n2( config_flags, a_bn2, moist, a_moist, theta, a_theta, t, a_t, p, a_p, p8w, a_p8w, t8w, a_t8w, rdz, rdzw, &
385 &n_moist, cf1, cf2, cf3, ids, ide, jds, jde, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte )
386 !******************************************************************
387 !******************************************************************
388 !** This routine was generated by Automatic differentiation. **
389 !** FastOpt: Transformation of Algorithm in Fortran, TAF 1.7.18 **
390 !******************************************************************
391 !******************************************************************
392 !==============================================
393 ! all entries are defined explicitly
394 !==============================================
395 implicit none
396
397 !==============================================
398 ! declare arguments
399 !==============================================
400 integer, intent(in) :: ime
401 integer, intent(in) :: ims
402 integer, intent(in) :: jme
403 integer, intent(in) :: jms
404 integer, intent(in) :: kme
405 integer, intent(in) :: kms
406 real, intent(inout) :: a_bn2(ims:ime,kms:kme,jms:jme)
407 integer, intent(in) :: n_moist
408 real, intent(inout) :: a_moist(ims:ime,kms:kme,jms:jme,n_moist)
409 real, intent(inout) :: a_p(ims:ime,kms:kme,jms:jme)
410 real, intent(inout) :: a_p8w(ims:ime,kms:kme,jms:jme)
411 real, intent(inout) :: a_t(ims:ime,kms:kme,jms:jme)
412 real, intent(inout) :: a_t8w(ims:ime,kms:kme,jms:jme)
413 real, intent(inout) :: a_theta(ims:ime,kms:kme,jms:jme)
414 real, intent(in) :: cf1
415 real, intent(in) :: cf2
416 real, intent(in) :: cf3
417 type (grid_config_rec_type), intent(in) :: config_flags
418 integer, intent(in) :: ide
419 integer, intent(in) :: ids
420 integer, intent(in) :: ite
421 integer, intent(in) :: its
422 integer, intent(in) :: jde
423 integer, intent(in) :: jds
424 integer, intent(in) :: jte
425 integer, intent(in) :: jts
426 integer, intent(in) :: kde
427 integer, intent(in) :: kte
428 integer, intent(in) :: kts
429 real, intent(inout) :: moist(ims:ime,kms:kme,jms:jme,n_moist)
430 real, intent(in) :: p(ims:ime,kms:kme,jms:jme)
431 real, intent(in) :: p8w(ims:ime,kms:kme,jms:jme)
432 real, intent(in) :: rdz(ims:ime,kms:kme,jms:jme)
433 real, intent(in) :: rdzw(ims:ime,kms:kme,jms:jme)
434 real, intent(in) :: t(ims:ime,kms:kme,jms:jme)
435 real, intent(in) :: t8w(ims:ime,kms:kme,jms:jme)
436 real, intent(in) :: theta(ims:ime,kms:kme,jms:jme)
437
438 !==============================================
439 ! declare local variables
440 !==============================================
441 real a_coefa
442 real a_es
443 real a_qctmp(its:ite,kts:kte,jts:jte)
444 real a_qvs(its:ite,kts:kte,jts:jte)
445 real a_qvsfc
446 real a_tc
447 real a_thetaem1
448 real a_thetaep1
449 real a_thetaesfc
450 real a_thetasfc
451 real a_tmp1(its:ite,kts:kte,jts:jte)
452 real a_tmp1sfc(its:ite,jts:jte)
453 real a_xlvqv
454 real coefa
455 real es
456 integer i
457 integer i_end
458 integer i_start
459 integer ispe
460 integer j
461 integer j_end
462 integer j_start
463 integer k
464 integer ktf
465 real qc_cr
466 real qctmp(its:ite,kts:kte,jts:jte)
467 real qvs(its:ite,kts:kte,jts:jte)
468 real qvsfc
469 real tc
470 real thetaem1
471 real thetaep1
472 real thetaesfc
473 real thetasfc
474 real tmpdz
475 real xlvqv
476
477 !----------------------------------------------
478 ! RESET LOCAL ADJOINT VARIABLES
479 !----------------------------------------------
480 a_coefa = 0.
481 a_es = 0.
482 a_qctmp(:,:,:) = 0.
483 a_qvs(:,:,:) = 0.
484 a_qvsfc = 0.
485 a_tc = 0.
486 a_thetaem1 = 0.
487 a_thetaep1 = 0.
488 a_thetaesfc = 0.
489 a_thetasfc = 0.
490 a_tmp1(:,:,:) = 0.
491 a_tmp1sfc(:,:) = 0.
492 a_xlvqv = 0.
493
494 !----------------------------------------------
495 ! ROUTINE BODY
496 !----------------------------------------------
497 qc_cr = 0.00001
498 ! recompute : qc_cr
499 ktf = min(kte,kde-1)
500 ! recompute : ktf
501 i_start = its
502 ! recompute : i_start
503 i_end = min(ite,ide-1)
504 ! recompute : i_end
505 j_start = jts
506 ! recompute : j_start
507 j_end = min(jte,jde-1)
508 ! recompute : j_end
509 if (config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) then
510 i_start = max(ids+1,its)
511 endif
512 ! recompute : i_start
513 if (config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) then
514 i_end = min(ide-2,ite)
515 endif
516 ! recompute : i_end
517 if (config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) then
518 j_start = max(jds+1,jts)
519 endif
520 ! recompute : j_start
521 if (config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) then
522 j_end = min(jde-2,jte)
523 endif
524 ! recompute : j_end
525 if (p_qc .gt. param_first_scalar) then
526 do j = j_start, j_end
527 do k = kts, ktf
528 do i = i_start, i_end
529 qctmp(i,k,j) = moist(i,k,j,p_qc)
530 end do
531 end do
532 end do
533 else
534 do j = j_start, j_end
535 do k = kts, ktf
536 do i = i_start, i_end
537 qctmp(i,k,j) = 0.
538 end do
539 end do
540 end do
541 endif
542 ! recompute : qctmp
543 do j = j_start, j_end
544 do k = kts, ktf
545 do i = i_start, i_end
546 tc = t(i,k,j)-svpt0
547 es = 1000.*svp1*exp(svp2*tc/(t(i,k,j)-svp3))
548 qvs(i,k,j) = ep_2*es/(p(i,k,j)-es)
549 end do
550 end do
551 end do
552 ! recompute : qvs
553 k = kts
554 ! recompute : k
555 do j = j_start, j_end
556 do i = i_start, i_end
557 a_bn2(i,ktf-1,j) = a_bn2(i,ktf-1,j)+a_bn2(i,ktf,j)
558 a_bn2(i,ktf,j) = 0.
559 end do
560 end do
561 do j = j_start, j_end
562 a_coefa = 0.
563 a_qvsfc = 0.
564 a_thetaep1 = 0.
565 a_thetaesfc = 0.
566 a_thetasfc = 0.
567 a_xlvqv = 0.
568 do i = i_start, i_end
569 a_coefa = 0.
570 a_qvsfc = 0.
571 a_thetaep1 = 0.
572 a_thetaesfc = 0.
573 a_thetasfc = 0.
574 a_xlvqv = 0.
575 tmpdz = 1./rdz(i,k+1,j)+0.5/rdzw(i,k,j)
576 ! recompute : tmpdz
577 thetasfc = t8w(i,kts,j)/(p8w(i,k,j)/p1000mb)**(r_d/cp)
578 ! recompute : thetasfc
579 if (moist(i,k,j,p_qv) .ge. qvs(i,k,j) .or. qctmp(i,k,j) .ge. qc_cr) then
580 qvsfc = cf1*qvs(i,1,j)+cf2*qvs(i,2,j)+cf3*qvs(i,3,j)
581 ! recompute : qvsfc
582 xlvqv = xlv*moist(i,k,j,p_qv)
583 ! recompute : xlvqv
584 coefa = (1.+xlvqv/r_d/t(i,k,j))/(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))/theta(i,k,j)
585 ! recompute : coefa
586 thetaep1 = theta(i,k+1,j)*(1.+xlv*qvs(i,k+1,j)/cp/t(i,k+1,j))
587 ! recompute : thetaep1
588 thetaesfc = thetasfc*(1.+xlv*qvsfc/cp/t8w(i,kts,j))
589 ! recompute : thetaesfc
590 a_coefa = a_coefa+a_bn2(i,k,j)*g*((thetaep1-thetaesfc)/tmpdz)
591 a_thetaep1 = a_thetaep1+a_bn2(i,k,j)*g*(coefa/tmpdz)
592 a_thetaesfc = a_thetaesfc-a_bn2(i,k,j)*g*(coefa/tmpdz)
593 a_tmp1(i,k+1,j) = a_tmp1(i,k+1,j)-a_bn2(i,k,j)*(g/tmpdz)
594 a_tmp1sfc(i,j) = a_tmp1sfc(i,j)+a_bn2(i,k,j)*(g/tmpdz)
595 a_bn2(i,k,j) = 0.
596 a_qvsfc = a_qvsfc+a_thetaesfc*thetasfc*(xlv/cp/t8w(i,kts,j))
597 a_t8w(i,kts,j) = a_t8w(i,kts,j)-a_thetaesfc*thetasfc*(xlv*qvsfc/cp/(t8w(i,kts,j)*t8w(i,kts,j)))
598 a_thetasfc = a_thetasfc+a_thetaesfc*(1+xlv*qvsfc/cp/t8w(i,kts,j))
599 a_thetaesfc = 0.
600 a_qvs(i,k+1,j) = a_qvs(i,k+1,j)+a_thetaep1*theta(i,k+1,j)*(xlv/cp/t(i,k+1,j))
601 a_t(i,k+1,j) = a_t(i,k+1,j)-a_thetaep1*theta(i,k+1,j)*(xlv*qvs(i,k+1,j)/cp/(t(i,k+1,j)*t(i,k+1,j)))
602 a_theta(i,k+1,j) = a_theta(i,k+1,j)+a_thetaep1*(1+xlv*qvs(i,k+1,j)/cp/t(i,k+1,j))
603 a_thetaep1 = 0.
604 a_t(i,k,j) = a_t(i,k,j)+a_coefa*(((-(xlvqv/r_d/(t(i,k,j)*t(i,k,j))/(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))))+(1.+xlvqv/r_d/&
605 &t(i,k,j))*(xlv*xlvqv/cp/r_v/(t(i,k,j)*t(i,k,j))/t(i,k,j)+xlv*xlvqv/cp/r_v/t(i,k,j)/(t(i,k,j)*t(i,k,j)))/((1.+xlv*xlvqv/cp/&
606 &r_v/t(i,k,j)/t(i,k,j))*(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))))/theta(i,k,j))
607 a_theta(i,k,j) = a_theta(i,k,j)-a_coefa*((1.+xlvqv/r_d/t(i,k,j))/(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))/(theta(i,k,j)*&
608 &theta(i,k,j)))
609 a_xlvqv = a_xlvqv+a_coefa*((1/r_d/t(i,k,j)/(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))-(1.+xlvqv/r_d/t(i,k,j))*(xlv/cp/r_v/t(i,k,&
610 &j)/t(i,k,j))/((1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))*(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))))/theta(i,k,j))
611 a_coefa = 0.
612 a_moist(i,k,j,p_qv) = a_moist(i,k,j,p_qv)+a_xlvqv*xlv
613 a_xlvqv = 0.
614 a_qvs(i,3,j) = a_qvs(i,3,j)+a_qvsfc*cf3
615 a_qvs(i,2,j) = a_qvs(i,2,j)+a_qvsfc*cf2
616 a_qvs(i,1,j) = a_qvs(i,1,j)+a_qvsfc*cf1
617 a_qvsfc = 0.
618 else
619 tmpdz = 1./rdzw(i,k,j)
620 ! recompute : tmpdz
621 a_moist(i,k+1,j,p_qv) = a_moist(i,k+1,j,p_qv)+a_bn2(i,k,j)*g*(1.61/tmpdz)
622 a_qvsfc = a_qvsfc+a_bn2(i,k,j)*g*((-1.61)/tmpdz)
623 a_theta(i,k+1,j) = a_theta(i,k+1,j)+a_bn2(i,k,j)*g*(1/theta(i,k,j)/tmpdz)
624 a_theta(i,k,j) = a_theta(i,k,j)+a_bn2(i,k,j)*g*(((-1)/theta(i,k,j)-(theta(i,k+1,j)-theta(i,k,j))/(theta(i,k,j)*theta(i,k,j)))&
625 &/tmpdz)
626 a_tmp1(i,k+1,j) = a_tmp1(i,k+1,j)-a_bn2(i,k,j)*(g/tmpdz)
627 a_tmp1sfc(i,j) = a_tmp1sfc(i,j)+a_bn2(i,k,j)*(g/tmpdz)
628 a_bn2(i,k,j) = 0.
629 a_moist(i,3,j,p_qv) = a_moist(i,3,j,p_qv)+a_qvsfc*cf3
630 a_moist(i,2,j,p_qv) = a_moist(i,2,j,p_qv)+a_qvsfc*cf2
631 a_moist(i,1,j,p_qv) = a_moist(i,1,j,p_qv)+a_qvsfc*cf1
632 a_qvsfc = 0.
633 endif
634 a_p8w(i,k,j) = a_p8w(i,k,j)-a_thetasfc*(t8w(i,kts,j)/p1000mb*r_d/cp*(p8w(i,k,j)/p1000mb)**(r_d/cp-1)/((p8w(i,k,j)/p1000mb)**&
635 &(r_d/cp)*(p8w(i,k,j)/p1000mb)**(r_d/cp)))
636 a_t8w(i,kts,j) = a_t8w(i,kts,j)+a_thetasfc/(p8w(i,k,j)/p1000mb)**(r_d/cp)
637 a_thetasfc = 0.
638 end do
639 end do
640 do j = j_start, j_end
641 a_coefa = 0.
642 a_thetaem1 = 0.
643 a_thetaep1 = 0.
644 a_xlvqv = 0.
645 do k = kts+1, ktf-1
646 a_coefa = 0.
647 a_thetaem1 = 0.
648 a_thetaep1 = 0.
649 a_xlvqv = 0.
650 do i = i_start, i_end
651 a_coefa = 0.
652 a_thetaem1 = 0.
653 a_thetaep1 = 0.
654 a_xlvqv = 0.
655 tmpdz = 1./rdz(i,k,j)+1./rdz(i,k+1,j)
656 ! recompute : tmpdz
657 if (moist(i,k,j,p_qv) .ge. qvs(i,k,j) .or. qctmp(i,k,j) .ge. qc_cr) then
658 xlvqv = xlv*moist(i,k,j,p_qv)
659 ! recompute : xlvqv
660 coefa = (1.+xlvqv/r_d/t(i,k,j))/(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))/theta(i,k,j)
661 ! recompute : coefa
662 thetaep1 = theta(i,k+1,j)*(1.+xlv*qvs(i,k+1,j)/cp/t(i,k+1,j))
663 ! recompute : thetaep1
664 thetaem1 = theta(i,k-1,j)*(1.+xlv*qvs(i,k-1,j)/cp/t(i,k-1,j))
665 ! recompute : thetaem1
666 a_coefa = a_coefa+a_bn2(i,k,j)*g*((thetaep1-thetaem1)/tmpdz)
667 a_thetaem1 = a_thetaem1-a_bn2(i,k,j)*g*(coefa/tmpdz)
668 a_thetaep1 = a_thetaep1+a_bn2(i,k,j)*g*(coefa/tmpdz)
669 a_tmp1(i,k-1,j) = a_tmp1(i,k-1,j)+a_bn2(i,k,j)*(g/tmpdz)
670 a_tmp1(i,k+1,j) = a_tmp1(i,k+1,j)-a_bn2(i,k,j)*(g/tmpdz)
671 a_bn2(i,k,j) = 0.
672 a_qvs(i,k-1,j) = a_qvs(i,k-1,j)+a_thetaem1*theta(i,k-1,j)*(xlv/cp/t(i,k-1,j))
673 a_t(i,k-1,j) = a_t(i,k-1,j)-a_thetaem1*theta(i,k-1,j)*(xlv*qvs(i,k-1,j)/cp/(t(i,k-1,j)*t(i,k-1,j)))
674 a_theta(i,k-1,j) = a_theta(i,k-1,j)+a_thetaem1*(1+xlv*qvs(i,k-1,j)/cp/t(i,k-1,j))
675 a_thetaem1 = 0.
676 a_qvs(i,k+1,j) = a_qvs(i,k+1,j)+a_thetaep1*theta(i,k+1,j)*(xlv/cp/t(i,k+1,j))
677 a_t(i,k+1,j) = a_t(i,k+1,j)-a_thetaep1*theta(i,k+1,j)*(xlv*qvs(i,k+1,j)/cp/(t(i,k+1,j)*t(i,k+1,j)))
678 a_theta(i,k+1,j) = a_theta(i,k+1,j)+a_thetaep1*(1+xlv*qvs(i,k+1,j)/cp/t(i,k+1,j))
679 a_thetaep1 = 0.
680 a_t(i,k,j) = a_t(i,k,j)+a_coefa*(((-(xlvqv/r_d/(t(i,k,j)*t(i,k,j))/(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))))+(1.+xlvqv/r_d/&
681 &t(i,k,j))*(xlv*xlvqv/cp/r_v/(t(i,k,j)*t(i,k,j))/t(i,k,j)+xlv*xlvqv/cp/r_v/t(i,k,j)/(t(i,k,j)*t(i,k,j)))/((1.+xlv*xlvqv/cp/&
682 &r_v/t(i,k,j)/t(i,k,j))*(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))))/theta(i,k,j))
683 a_theta(i,k,j) = a_theta(i,k,j)-a_coefa*((1.+xlvqv/r_d/t(i,k,j))/(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))/(theta(i,k,j)*&
684 &theta(i,k,j)))
685 a_xlvqv = a_xlvqv+a_coefa*((1/r_d/t(i,k,j)/(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))-(1.+xlvqv/r_d/t(i,k,j))*(xlv/cp/r_v/t(i,&
686 &k,j)/t(i,k,j))/((1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))*(1.+xlv*xlvqv/cp/r_v/t(i,k,j)/t(i,k,j))))/theta(i,k,j))
687 a_coefa = 0.
688 a_moist(i,k,j,p_qv) = a_moist(i,k,j,p_qv)+a_xlvqv*xlv
689 a_xlvqv = 0.
690 else
691 a_moist(i,k-1,j,p_qv) = a_moist(i,k-1,j,p_qv)+a_bn2(i,k,j)*g*((-1.61)/tmpdz)
692 a_moist(i,k+1,j,p_qv) = a_moist(i,k+1,j,p_qv)+a_bn2(i,k,j)*g*(1.61/tmpdz)
693 a_theta(i,k-1,j) = a_theta(i,k-1,j)+a_bn2(i,k,j)*g*((-1)/theta(i,k,j)/tmpdz)
694 a_theta(i,k+1,j) = a_theta(i,k+1,j)+a_bn2(i,k,j)*g*(1/theta(i,k,j)/tmpdz)
695 a_theta(i,k,j) = a_theta(i,k,j)-a_bn2(i,k,j)*g*((theta(i,k+1,j)-theta(i,k-1,j))/(theta(i,k,j)*theta(i,k,j))/tmpdz)
696 a_tmp1(i,k-1,j) = a_tmp1(i,k-1,j)+a_bn2(i,k,j)*(g/tmpdz)
697 a_tmp1(i,k+1,j) = a_tmp1(i,k+1,j)-a_bn2(i,k,j)*(g/tmpdz)
698 a_bn2(i,k,j) = 0.
699 endif
700 end do
701 end do
702 end do
703 do j = j_start, j_end
704 a_es = 0.
705 a_tc = 0.
706 do k = kts, ktf
707 a_es = 0.
708 a_tc = 0.
709 do i = i_start, i_end
710 a_es = 0.
711 a_tc = 0.
712 tc = t(i,k,j)-svpt0
713 ! recompute : tc
714 es = 1000.*svp1*exp(svp2*tc/(t(i,k,j)-svp3))
715 ! recompute : es
716 a_es = a_es+a_qvs(i,k,j)*(ep_2/(p(i,k,j)-es)+ep_2*es/((p(i,k,j)-es)*(p(i,k,j)-es)))
717 a_p(i,k,j) = a_p(i,k,j)-a_qvs(i,k,j)*(ep_2*es/((p(i,k,j)-es)*(p(i,k,j)-es)))
718 a_qvs(i,k,j) = 0.
719 a_t(i,k,j) = a_t(i,k,j)-1000.*a_es*svp1*(svp2*tc/((t(i,k,j)-svp3)*(t(i,k,j)-svp3)))*exp(svp2*tc/(t(i,k,j)-svp3))
720 a_tc = a_tc+1000.*a_es*svp1*(svp2/(t(i,k,j)-svp3))*exp(svp2*tc/(t(i,k,j)-svp3))
721 a_es = 0.
722 a_t(i,k,j) = a_t(i,k,j)+a_tc
723 a_tc = 0.
724 end do
725 end do
726 end do
727 do ispe = n_moist, param_first_scalar, -1
728 if (ispe .eq. p_qv .or. ispe .eq. p_qc .or. ispe .eq. p_qi) then
729 do j = j_start, j_end
730 do i = i_start, i_end
731 a_moist(i,3,j,ispe) = a_moist(i,3,j,ispe)+a_tmp1sfc(i,j)*cf3
732 a_moist(i,2,j,ispe) = a_moist(i,2,j,ispe)+a_tmp1sfc(i,j)*cf2
733 a_moist(i,1,j,ispe) = a_moist(i,1,j,ispe)+a_tmp1sfc(i,j)*cf1
734 end do
735 end do
736 do j = j_start, j_end
737 do k = kts, ktf
738 do i = i_start, i_end
739 a_moist(i,k,j,ispe) = a_moist(i,k,j,ispe)+a_tmp1(i,k,j)
740 end do
741 end do
742 end do
743 endif
744 end do
745 if (p_qc .gt. param_first_scalar) then
746 do j = j_start, j_end
747 do k = kts, ktf
748 do i = i_start, i_end
749 a_moist(i,k,j,p_qc) = a_moist(i,k,j,p_qc)+a_qctmp(i,k,j)
750 a_qctmp(i,k,j) = 0.
751 end do
752 end do
753 end do
754 endif
755
756 end subroutine a_calculate_n2
757
758
759 subroutine a_isotropic_km( a_xkmhd, ide, jde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte )
760 !******************************************************************
761 !******************************************************************
762 !** This routine was generated by Automatic differentiation. **
763 !** FastOpt: Transformation of Algorithm in Fortran, TAF 1.7.18 **
764 !******************************************************************
765 !******************************************************************
766 !==============================================
767 ! all entries are defined explicitly
768 !==============================================
769 implicit none
770
771 !==============================================
772 ! declare arguments
773 !==============================================
774 integer, intent(in) :: ime
775 integer, intent(in) :: ims
776 integer, intent(in) :: jme
777 integer, intent(in) :: jms
778 integer, intent(in) :: kme
779 integer, intent(in) :: kms
780 real, intent(inout) :: a_xkmhd(ims:ime,kms:kme,jms:jme)
781 integer, intent(in) :: ide
782 integer, intent(in) :: ite
783 integer, intent(in) :: its
784 integer, intent(in) :: jde
785 integer, intent(in) :: jte
786 integer, intent(in) :: jts
787 integer, intent(in) :: kte
788 integer, intent(in) :: kts
789
790 !==============================================
791 ! declare local variables
792 !==============================================
793 integer i
794 integer i_end
795 integer i_start
796 integer j
797 integer j_end
798 integer j_start
799 integer k
800 integer ktf
801
802 !----------------------------------------------
803 ! ROUTINE BODY
804 !----------------------------------------------
805 ktf = kte
806 ! recompute : ktf
807 i_start = its
808 ! recompute : i_start
809 i_end = min(ite,ide-1)
810 ! recompute : i_end
811 j_start = jts
812 ! recompute : j_start
813 j_end = min(jte,jde-1)
814 ! recompute : j_end
815 do j = j_start, j_end
816 do k = kts, ktf
817 do i = i_start, i_end
818 a_xkmhd(i,k,j) = 0.
819 end do
820 end do
821 end do
822
823 end subroutine a_isotropic_km
824
825
826 subroutine a_smag2d_km( config_flags, xkmh, a_xkmh, a_xkmhd, defor11, defor22, defor12, dx, dy, ids, ide, jds, jde, kde, ims, ime, &
827 &jms, jme, kms, kme, its, ite, jts, jte, kts, kte )
828 !******************************************************************
829 !******************************************************************
830 !** This routine was generated by Automatic differentiation. **
831 !** FastOpt: Transformation of Algorithm in Fortran, TAF 1.7.18 **
832 !******************************************************************
833 !******************************************************************
834 !==============================================
835 ! all entries are defined explicitly
836 !==============================================
837 implicit none
838
839 !==============================================
840 ! declare arguments
841 !==============================================
842 integer, intent(in) :: ime
843 integer, intent(in) :: ims
844 integer, intent(in) :: jme
845 integer, intent(in) :: jms
846 integer, intent(in) :: kme
847 integer, intent(in) :: kms
848 real, intent(inout) :: a_xkmh(ims:ime,kms:kme,jms:jme)
849 real, intent(inout) :: a_xkmhd(ims:ime,kms:kme,jms:jme)
850 type (grid_config_rec_type), intent(in) :: config_flags
851 real, intent(in) :: defor11(ims:ime,kms:kme,jms:jme)
852 real, intent(in) :: defor12(ims:ime,kms:kme,jms:jme)
853 real, intent(in) :: defor22(ims:ime,kms:kme,jms:jme)
854 real, intent(in) :: dx
855 real, intent(in) :: dy
856 integer, intent(in) :: ide
857 integer, intent(in) :: ids
858 integer, intent(in) :: ite
859 integer, intent(in) :: its
860 integer, intent(in) :: jde
861 integer, intent(in) :: jds
862 integer, intent(in) :: jte
863 integer, intent(in) :: jts
864 integer, intent(in) :: kde
865 integer, intent(in) :: kte
866 integer, intent(in) :: kts
867 real, intent(inout) :: xkmh(ims:ime,kms:kme,jms:jme)
868
869 !==============================================
870 ! declare local variables
871 !==============================================
872 real def2(its:ite,kts:kte,jts:jte)
873 integer i
874 integer i_end
875 integer i_start
876 integer j
877 integer j_end
878 integer j_start
879 integer k
880 integer ktf
881 real mlen_h
882 real tmp
883
884 !----------------------------------------------
885 ! ROUTINE BODY
886 !----------------------------------------------
887 ktf = min(kte,kde-1)
888 ! recompute : ktf
889 i_start = its
890 ! recompute : i_start
891 i_end = min(ite,ide-1)
892 ! recompute : i_end
893 j_start = jts
894 ! recompute : j_start
895 j_end = min(jte,jde-1)
896 ! recompute : j_end
897 if (config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) then
898 i_start = max(ids+1,its)
899 endif
900 ! recompute : i_start
901 if (config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) then
902 i_end = min(ide-2,ite)
903 endif
904 ! recompute : i_end
905 if (config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) then
906 j_start = max(jds+1,jts)
907 endif
908 ! recompute : j_start
909 if (config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) then
910 j_end = min(jde-2,jte)
911 endif
912 ! recompute : j_end
913 do j = j_start, j_end
914 do k = kts, ktf
915 do i = i_start, i_end
916 def2(i,k,j) = 0.25*(defor11(i,k,j)-defor22(i,k,j))**2+defor12(i,k,j)*defor12(i,k,j)
917 end do
918 end do
919 end do
920 ! recompute : def2
921 mlen_h = sqrt(dx*dy)
922 ! recompute : mlen_h
923 do j = j_start, j_end
924 do k = kts, ktf
925 do i = i_start, i_end
926 tmp = def2(i,k,j)**0.5
927 ! recompute : tmp
928 xkmh(i,k,j) = c_s*c_s*mlen_h*mlen_h*tmp
929 ! recompute : xkmh
930 a_xkmh(i,k,j) = a_xkmh(i,k,j)+a_xkmhd(i,k,j)
931 a_xkmhd(i,k,j) = 0.
932 a_xkmh(i,k,j) = a_xkmh(i,k,j)*(0.5+sign(0.5,10.*mlen_h-xkmh(i,k,j)))
933 a_xkmh(i,k,j) = 0.
934 end do
935 end do
936 end do
937
938 end subroutine a_smag2d_km
939
940
941 subroutine a_smag_km( config_flags, xkmh, a_xkmh, a_xkmhd, bn2, a_bn2, defor11, defor22, defor33, defor12, defor13, defor23, rdzw, &
942 &dx, dy, ids, ide, jds, jde, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte )
943 !******************************************************************
944 !******************************************************************
945 !** This routine was generated by Automatic differentiation. **
946 !** FastOpt: Transformation of Algorithm in Fortran, TAF 1.7.18 **
947 !******************************************************************
948 !******************************************************************
949 !==============================================
950 ! all entries are defined explicitly
951 !==============================================
952 implicit none
953
954 !==============================================
955 ! declare arguments
956 !==============================================
957 integer, intent(in) :: ime
958 integer, intent(in) :: ims
959 integer, intent(in) :: jme
960 integer, intent(in) :: jms
961 integer, intent(in) :: kme
962 integer, intent(in) :: kms
963 real, intent(inout) :: a_bn2(ims:ime,kms:kme,jms:jme)
964 real, intent(inout) :: a_xkmh(ims:ime,kms:kme,jms:jme)
965 real, intent(inout) :: a_xkmhd(ims:ime,kms:kme,jms:jme)
966 real, intent(in) :: bn2(ims:ime,kms:kme,jms:jme)
967 type (grid_config_rec_type), intent(in) :: config_flags
968 real, intent(in) :: defor11(ims:ime,kms:kme,jms:jme)
969 real, intent(in) :: defor12(ims:ime,kms:kme,jms:jme)
970 real, intent(in) :: defor13(ims:ime,kms:kme,jms:jme)
971 real, intent(in) :: defor22(ims:ime,kms:kme,jms:jme)
972 real, intent(in) :: defor23(ims:ime,kms:kme,jms:jme)
973 real, intent(in) :: defor33(ims:ime,kms:kme,jms:jme)
974 real, intent(in) :: dx
975 real, intent(in) :: dy
976 integer, intent(in) :: ide
977 integer, intent(in) :: ids
978 integer, intent(in) :: ite
979 integer, intent(in) :: its
980 integer, intent(in) :: jde
981 integer, intent(in) :: jds
982 integer, intent(in) :: jte
983 integer, intent(in) :: jts
984 integer, intent(in) :: kde
985 integer, intent(in) :: kte
986 integer, intent(in) :: kts
987 real, intent(in) :: rdzw(ims:ime,kms:kme,jms:jme)
988 real, intent(inout) :: xkmh(ims:ime,kms:kme,jms:jme)
989
990 !==============================================
991 ! declare local variables
992 !==============================================
993 real a_tmp
994 real cr_len
995 real def2(its:ite,kts:kte,jts:jte)
996 real deltas
997 integer i
998 integer i_end
999 integer i_start
1000 integer j
1001 integer j_end
1002 integer j_start
1003 integer k
1004 integer ktf
1005 real mlen_h
1006 real pr
1007 real tmp
1008
1009 !----------------------------------------------
1010 ! RESET LOCAL ADJOINT VARIABLES
1011 !----------------------------------------------
1012 a_tmp = 0.
1013
1014 !----------------------------------------------
1015 ! ROUTINE BODY
1016 !----------------------------------------------
1017 ktf = min(kte,kde-1)
1018 ! recompute : ktf
1019 i_start = its
1020 ! recompute : i_start
1021 i_end = min(ite,ide-1)
1022 ! recompute : i_end
1023 j_start = jts
1024 ! recompute : j_start
1025 j_end = min(jte,jde-1)
1026 ! recompute : j_end
1027 if (config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) then
1028 i_start = max(ids+1,its)
1029 endif
1030 ! recompute : i_start
1031 if (config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) then
1032 i_end = min(ide-2,ite)
1033 endif
1034 ! recompute : i_end
1035 if (config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) then
1036 j_start = max(jds+1,jts)
1037 endif
1038 ! recompute : j_start
1039 if (config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) then
1040 j_end = min(jde-2,jte)
1041 endif
1042 ! recompute : j_end
1043 pr = 1./3.
1044 ! recompute : pr
1045 do j = j_start, j_end
1046 do k = kts, ktf
1047 do i = i_start, i_end
1048 def2(i,k,j) = 0.5*(defor11(i,k,j)*defor11(i,k,j)+defor22(i,k,j)*defor22(i,k,j)+defor33(i,k,j)*defor33(i,k,j))
1049 end do
1050 end do
1051 end do
1052 ! recompute : def2
1053 do j = j_start, j_end
1054 do k = kts, ktf
1055 do i = i_start, i_end
1056 tmp = 0.25*(defor12(i,k,j)+defor12(i,k,j+1)+defor12(i+1,k,j)+defor12(i+1,k,j+1))
1057 def2(i,k,j) = def2(i,k,j)+0.5*tmp*tmp
1058 end do
1059 end do
1060 end do
1061 ! recompute : def2
1062 do j = j_start, j_end
1063 do k = kts, ktf
1064 do i = i_start, i_end
1065 tmp = 0.25*(defor13(i,k+1,j)+defor13(i,k,j)+defor13(i+1,k+1,j)+defor13(i+1,k,j))
1066 def2(i,k,j) = def2(i,k,j)+0.5*tmp*tmp
1067 end do
1068 end do
1069 end do
1070 ! recompute : def2
1071 do j = j_start, j_end
1072 do k = kts, ktf
1073 do i = i_start, i_end
1074 tmp = 0.25*(defor23(i,k+1,j)+defor23(i,k,j)+defor23(i,k+1,j+1)+defor23(i,k,j+1))
1075 def2(i,k,j) = def2(i,k,j)+0.5*tmp*tmp
1076 end do
1077 end do
1078 end do
1079 ! recompute : def2
1080 cr_len = dx+1.
1081 ! recompute : cr_len
1082 if (dx .gt. cr_len) then
1083 mlen_h = sqrt(dx*dy)
1084 ! recompute : mlen_h
1085 do j = j_start, j_end
1086 a_tmp = 0.
1087 do k = kts, ktf
1088 a_tmp = 0.
1089 do i = i_start, i_end
1090 a_tmp = 0.
1091 tmp = max(0.,def2(i,k,j)-bn2(i,k,j)/pr)
1092 ! recompute : tmp
1093 tmp = tmp**0.5
1094 ! recompute : tmp
1095 xkmh(i,k,j) = max(c_s*c_s*mlen_h*mlen_h*tmp,1.e-6*mlen_h*mlen_h)
1096 ! recompute : xkmh
1097 a_xkmh(i,k,j) = a_xkmh(i,k,j)+a_xkmhd(i,k,j)
1098 a_xkmhd(i,k,j) = 0.
1099 a_xkmh(i,k,j) = a_xkmh(i,k,j)*(0.5+sign(0.5,10.*mlen_h-xkmh(i,k,j)))
1100 a_tmp = a_tmp+a_xkmh(i,k,j)*(0.5+sign(0.5,c_s*c_s*mlen_h*mlen_h*tmp-1.e-6*mlen_h*mlen_h))*c_s*c_s*mlen_h*mlen_h
1101 a_xkmh(i,k,j) = 0.
1102 ! recdepend vars : bn2,def2,i,j,k,pr
1103 ! recompute pos : ASSIGN_STMT module_diffusion_em.f90:1516
1104 ! recompute vars : tmp
1105 tmp = max(0.,def2(i,k,j)-bn2(i,k,j)/pr)
1106 ! recompute vars : tmp
1107 a_tmp = 0.5*a_tmp*tmp**(-0.5)
1108 a_bn2(i,k,j) = a_bn2(i,k,j)-a_tmp*((0.5-sign(0.5,0.-(def2(i,k,j)-bn2(i,k,j)/pr)))/pr)
1109 a_tmp = 0.
1110 end do
1111 end do
1112 end do
1113 else
1114 do j = j_start, j_end
1115 a_tmp = 0.
1116 do k = kts, ktf
1117 a_tmp = 0.
1118 do i = i_start, i_end
1119 a_tmp = 0.
1120 deltas = (dx*dy/rdzw(i,k,j))**0.33333333
1121 ! recompute : deltas
1122 tmp = max(0.,def2(i,k,j)-bn2(i,k,j)/pr)
1123 ! recompute : tmp
1124 tmp = tmp**0.5
1125 ! recompute : tmp
1126 xkmh(i,k,j) = max(c_s*c_s*deltas*deltas*tmp,1.e-6*deltas*deltas)
1127 ! recompute : xkmh
1128 a_xkmh(i,k,j) = a_xkmh(i,k,j)+a_xkmhd(i,k,j)
1129 a_xkmhd(i,k,j) = 0.
1130 a_xkmh(i,k,j) = a_xkmh(i,k,j)*(0.5+sign(0.5,10.*deltas-xkmh(i,k,j)))
1131 a_tmp = a_tmp+a_xkmh(i,k,j)*(0.5+sign(0.5,c_s*c_s*deltas*deltas*tmp-1.e-6*deltas*deltas))*c_s*c_s*deltas*deltas
1132 a_xkmh(i,k,j) = 0.
1133 ! recdepend vars : bn2,def2,i,j,k,pr
1134 ! recompute pos : ASSIGN_STMT module_diffusion_em.f90:1533
1135 ! recompute vars : tmp
1136 tmp = max(0.,def2(i,k,j)-bn2(i,k,j)/pr)
1137 ! recompute vars : tmp
1138 a_tmp = 0.5*a_tmp*tmp**(-0.5)
1139 a_bn2(i,k,j) = a_bn2(i,k,j)-a_tmp*((0.5-sign(0.5,0.-(def2(i,k,j)-bn2(i,k,j)/pr)))/pr)
1140 a_tmp = 0.
1141 end do
1142 end do
1143 end do
1144 endif
1145
1146 end subroutine a_smag_km
1147
1148
1149 subroutine a_tke_km( config_flags, xkmh, a_xkmh, a_xkmhd, bn2, a_bn2, tke, rdzw, dx, dy, kh_tke_upper_bound, ids, ide, jds, jde, &
1150 &kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte )
1151 !******************************************************************
1152 !******************************************************************
1153 !** This routine was generated by Automatic differentiation. **
1154 !** FastOpt: Transformation of Algorithm in Fortran, TAF 1.7.18 **
1155 !******************************************************************
1156 !******************************************************************
1157 !==============================================
1158 ! all entries are defined explicitly
1159 !==============================================
1160 implicit none
1161
1162 !==============================================
1163 ! declare parameters
1164 !==============================================
1165 real epsilon
1166 parameter ( epsilon = 1.e-10 )
1167 real tke_seed_value
1168 parameter ( tke_seed_value = 1.e-6 )
1169
1170 !==============================================
1171 ! declare arguments
1172 !==============================================
1173 integer, intent(in) :: ime
1174 integer, intent(in) :: ims
1175 integer, intent(in) :: jme
1176 integer, intent(in) :: jms
1177 integer, intent(in) :: kme
1178 integer, intent(in) :: kms
1179 real, intent(inout) :: a_bn2(ims:ime,kms:kme,jms:jme)
1180 real, intent(inout) :: a_xkmh(ims:ime,kms:kme,jms:jme)
1181 real, intent(inout) :: a_xkmhd(ims:ime,kms:kme,jms:jme)
1182 real, intent(in) :: bn2(ims:ime,kms:kme,jms:jme)
1183 type (grid_config_rec_type), intent(in) :: config_flags
1184 real, intent(in) :: dx
1185 real, intent(in) :: dy
1186 integer, intent(in) :: ide
1187 integer, intent(in) :: ids
1188 integer, intent(in) :: ite
1189 integer, intent(in) :: its
1190 integer, intent(in) :: jde
1191 integer, intent(in) :: jds
1192 integer, intent(in) :: jte
1193 integer, intent(in) :: jts
1194 integer, intent(in) :: kde
1195 real, intent(in) :: kh_tke_upper_bound
1196 integer, intent(in) :: kte
1197 integer, intent(in) :: kts
1198 real, intent(in) :: rdzw(ims:ime,kms:kme,jms:jme)
1199 real, intent(in) :: tke(ims:ime,kms:kme,jms:jme)
1200 real, intent(inout) :: xkmh(ims:ime,kms:kme,jms:jme)
1201
1202 !==============================================
1203 ! declare local variables
1204 !==============================================
1205 real a_l_scale(its:ite,kts:kte,jts:jte)
1206 real cr_len
1207 integer i
1208 integer i_end
1209 integer i_start
1210 integer j
1211 integer j_end
1212 integer j_start
1213 integer k
1214 integer kds
1215 integer ktf
1216 real l_scale(its:ite,kts:kte,jts:jte)
1217 real mlen_h
1218 real tke_seed
1219 real tmp
1220
1221 !----------------------------------------------
1222 ! RESET LOCAL ADJOINT VARIABLES
1223 !----------------------------------------------
1224 a_l_scale(:,:,:) = 0.
1225
1226 !----------------------------------------------
1227 ! ROUTINE BODY
1228 !----------------------------------------------
1229 ktf = min(kte,kde-1)
1230 ! recompute : ktf
1231 i_start = its
1232 ! recompute : i_start
1233 i_end = min(ite,ide-1)
1234 ! recompute : i_end
1235 j_start = jts
1236 ! recompute : j_start
1237 j_end = min(jte,jde-1)
1238 ! recompute : j_end
1239 if (config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) then
1240 i_start = max(ids+1,its)
1241 endif
1242 ! recompute : i_start
1243 if (config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) then
1244 i_end = min(ide-2,ite)
1245 endif
1246 ! recompute : i_end
1247 if (config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) then
1248 j_start = max(jds+1,jts)
1249 endif
1250 ! recompute : j_start
1251 if (config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) then
1252 j_end = min(jde-2,jte)
1253 endif
1254 ! recompute : j_end
1255 tke_seed = tke_seed_value
1256 ! recompute : tke_seed
1257 if (config_flags%tke_drag_coefficient .gt. epsilon .or. config_flags%tke_heat_flux .gt. epsilon) then
1258 tke_seed = 0.
1259 endif
1260 ! recompute : tke_seed
1261 cr_len = dx+1.
1262 ! recompute : cr_len
1263 if (dx .gt. cr_len) then
1264 mlen_h = sqrt(dx*dy)
1265 ! recompute : mlen_h
1266 do j = j_start, j_end
1267 do k = kts, ktf
1268 do i = i_start, i_end
1269 tmp = sqrt(max(tke(i,k,j),tke_seed))
1270 ! recompute : tmp
1271 xkmh(i,k,j) = max(c_k*tmp*mlen_h,1.e-6*mlen_h*mlen_h)
1272 ! recompute : xkmh
1273 a_xkmh(i,k,j) = a_xkmh(i,k,j)+a_xkmhd(i,k,j)
1274 a_xkmhd(i,k,j) = 0.
1275 a_xkmh(i,k,j) = a_xkmh(i,k,j)*(0.5+sign(0.5,10.*mlen_h-xkmh(i,k,j)))
1276 a_xkmh(i,k,j) = 0.
1277 end do
1278 end do
1279 end do
1280 else
1281 call calc_l_scale( config_flags,tke,bn2,l_scale,i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,ids,ide,jds,jde,kds,kde,ims,ime,jms,&
1282 &jme,kms,kme,its,ite,jts,jte,kts,kte )
1283 ! recompute : l_scale
1284 do j = j_start, j_end
1285 do k = kts, ktf
1286 do i = i_start, i_end
1287 tmp = sqrt(max(tke(i,k,j),tke_seed))
1288 ! recompute : tmp
1289 xkmh(i,k,j) = c_k*tmp*l_scale(i,k,j)
1290 ! recompute : xkmh
1291 a_xkmh(i,k,j) = a_xkmh(i,k,j)+a_xkmhd(i,k,j)
1292 a_xkmhd(i,k,j) = 0.
1293 a_xkmh(i,k,j) = a_xkmh(i,k,j)*(0.5-sign(0.5,xkmh(i,k,j)-kh_tke_upper_bound))
1294 a_l_scale(i,k,j) = a_l_scale(i,k,j)+a_xkmh(i,k,j)*c_k*tmp
1295 a_xkmh(i,k,j) = 0.
1296 end do
1297 end do
1298 end do
1299 call a_calc_l_scale( tke,bn2,a_bn2,l_scale,a_l_scale,i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,ims,ime,jms,jme,kms,kme,its,ite,&
1300 &jts,jte,kts,kte )
1301 endif
1302
1303 end subroutine a_tke_km
1304
1305
1306 end module a_module_diffusion_em
1307
1308