module_advect_em.F
References to this file elsewhere.
1 !WRF:MODEL_LAYER:DYNAMICS
2 !
3 MODULE module_advect_em
4
5 USE module_bc
6 USE module_model_constants
7 USE module_wrf_error
8
9 CONTAINS
10
11
12 SUBROUTINE mass_flux_divergence ( field, field_old, tendency, &
13 ru, rv, rom, &
14 mut, config_flags, &
15 msfux, msfuy, msfvx, msfvy, &
16 msftx, msfty, &
17 fzm, fzp, &
18 rdx, rdy, rdzw, &
19 ids, ide, jds, jde, kds, kde, &
20 ims, ime, jms, jme, kms, kme, &
21 its, ite, jts, jte, kts, kte )
22
23 IMPLICIT NONE
24
25 ! Input data
26
27 TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
28
29 INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
30 ims, ime, jms, jme, kms, kme, &
31 its, ite, jts, jte, kts, kte
32
33 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, &
34 field_old, &
35 ru, &
36 rv, &
37 rom
38
39 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut
40 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
41
42 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, &
43 msfuy, &
44 msfvx, &
45 msfvy, &
46 msftx, &
47 msfty
48
49 REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, &
50 fzp, &
51 rdzw
52
53 REAL , INTENT(IN ) :: rdx, &
54 rdy
55
56 ! Local data
57
58 INTEGER :: i, j, k, itf, jtf, ktf
59 INTEGER :: i_start, i_end, j_start, j_end
60 INTEGER :: imin, imax, jmin, jmax
61
62 REAL :: mrdx, mrdy, ub, vb, uw, vw
63 REAL , DIMENSION(its:ite,kts:kte) :: vflux
64
65 LOGICAL :: specified
66
67 !--------------- horizontal flux
68
69 specified = .false.
70 if(config_flags%specified .or. config_flags%nested) specified = .true.
71
72 ktf=MIN(kte,kde-1)
73 i_start = its
74 i_end = MIN(ite,ide-1)
75 j_start = jts
76 j_end = MIN(jte,jde-1)
77
78 DO j = j_start, j_end
79 DO k = kts, ktf
80 DO i = i_start, i_end
81 mrdx=msftx(i,j)*rdx
82 tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 &
83 *(ru(i+1,k,j)*(field(i+1,k,j)+field(i ,k,j)) &
84 -ru(i ,k,j)*(field(i ,k,j)+field(i-1,k,j)))
85 ENDDO
86 ENDDO
87 ENDDO
88
89 DO j = j_start, j_end
90 DO k = kts, ktf
91 DO i = i_start, i_end
92 mrdy=msfty(i,j)*rdy
93 tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 &
94 *(rv(i,k,j+1)*(field(i,k,j+1)+field(i,k,j )) &
95 -rv(i,k,j )*(field(i,k,j )+field(i,k,j-1)))
96 ENDDO
97 ENDDO
98 ENDDO
99
100 !---------------- vertical flux divergence
101
102
103 DO i = i_start, i_end
104 vflux(i,kts)=0.
105 vflux(i,kte)=0.
106 ENDDO
107
108 DO j = j_start, j_end
109
110 DO k = kts+1, ktf
111 DO i = i_start, i_end
112 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
113 ENDDO
114 ENDDO
115
116 DO k = kts, ktf
117 DO i = i_start, i_end
118 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
119 ENDDO
120 ENDDO
121
122 ENDDO
123
124 END SUBROUTINE mass_flux_divergence
125
126 !-------------------------------------------------------------------------------
127
128 SUBROUTINE advect_u ( u, u_old, tendency, &
129 ru, rv, rom, &
130 mut, config_flags, &
131 msfux, msfuy, msfvx, msfvy, &
132 msftx, msfty, &
133 fzm, fzp, &
134 rdx, rdy, rdzw, &
135 ids, ide, jds, jde, kds, kde, &
136 ims, ime, jms, jme, kms, kme, &
137 its, ite, jts, jte, kts, kte )
138
139 IMPLICIT NONE
140
141 ! Input data
142
143 TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
144
145 INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
146 ims, ime, jms, jme, kms, kme, &
147 its, ite, jts, jte, kts, kte
148
149 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: u, &
150 u_old, &
151 ru, &
152 rv, &
153 rom
154
155 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut
156 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
157
158 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, &
159 msfuy, &
160 msfvx, &
161 msfvy, &
162 msftx, &
163 msfty
164
165 REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, &
166 fzp, &
167 rdzw
168
169 REAL , INTENT(IN ) :: rdx, &
170 rdy
171
172 ! Local data
173
174 INTEGER :: i, j, k, itf, jtf, ktf
175 INTEGER :: i_start, i_end, j_start, j_end
176 INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
177 INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
178 INTEGER :: jp1, jp0, jtmp
179
180 INTEGER :: horz_order, vert_order
181
182 REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
183 REAL , DIMENSION(its:ite, kts:kte) :: vflux
184
185
186 REAL, DIMENSION( its-1:ite+1, kts:kte ) :: fqx
187 REAL, DIMENSION( its:ite, kts:kte, 2) :: fqy
188
189 LOGICAL :: degrade_xs, degrade_ys
190 LOGICAL :: degrade_xe, degrade_ye
191
192 ! definition of flux operators, 3rd, 4th, 5th or 6th order
193
194 REAL :: flux3, flux4, flux5, flux6
195 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
196
197 flux4(q_im2, q_im1, q_i, q_ip1, ua) = &
198 ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
199
200 flux3(q_im2, q_im1, q_i, q_ip1, ua) = &
201 flux4(q_im2, q_im1, q_i, q_ip1, ua) + &
202 sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
203
204 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = &
205 ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) &
206 +(q_ip2+q_im3) )/60.0
207
208 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = &
209 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) &
210 -sign(1.,ua)*( &
211 (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
212
213
214 LOGICAL :: specified
215
216 specified = .false.
217 if(config_flags%specified .or. config_flags%nested) specified = .true.
218
219 ! set order for vertical and horzontal flux operators
220
221 horz_order = config_flags%h_mom_adv_order
222 vert_order = config_flags%v_mom_adv_order
223
224 ktf=MIN(kte,kde-1)
225
226 ! begin with horizontal flux divergence
227
228 horizontal_order_test : IF( horz_order == 6 ) THEN
229
230 ! determine boundary mods for flux operators
231 ! We degrade the flux operators from 3rd/4th order
232 ! to second order one gridpoint in from the boundaries for
233 ! all boundary conditions except periodic and symmetry - these
234 ! conditions have boundary zone data fill for correct application
235 ! of the higher order flux stencils
236
237 degrade_xs = .true.
238 degrade_xe = .true.
239 degrade_ys = .true.
240 degrade_ye = .true.
241
242 IF( config_flags%periodic_x .or. &
243 config_flags%symmetric_xs .or. &
244 (its > ids+2) ) degrade_xs = .false.
245 IF( config_flags%periodic_x .or. &
246 config_flags%symmetric_xe .or. &
247 (ite < ide-2) ) degrade_xe = .false.
248 IF( config_flags%periodic_y .or. &
249 config_flags%symmetric_ys .or. &
250 (jts > jds+2) ) degrade_ys = .false.
251 IF( config_flags%periodic_y .or. &
252 config_flags%symmetric_ye .or. &
253 (jte < jde-3) ) degrade_ye = .false.
254
255 !--------------- y - advection first
256
257 i_start = its
258 i_end = ite
259 IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
260 IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite)
261 IF ( config_flags%periodic_x ) i_start = its
262 IF ( config_flags%periodic_x ) i_end = ite
263
264 j_start = jts
265 j_end = MIN(jte,jde-1)
266
267 ! higher order flux has a 5 or 7 point stencil, so compute
268 ! bounds so we can switch to second order flux close to the boundary
269
270 j_start_f = j_start
271 j_end_f = j_end+1
272
273 IF(degrade_ys) then
274 j_start = MAX(jts,jds+1)
275 j_start_f = jds+3
276 ENDIF
277
278 IF(degrade_ye) then
279 j_end = MIN(jte,jde-2)
280 j_end_f = jde-3
281 ENDIF
282
283 IF(config_flags%polar) j_end = MIN(jte,jde-1)
284
285 ! compute fluxes, 5th or 6th order
286
287 jp1 = 2
288 jp0 = 1
289
290 j_loop_y_flux_6 : DO j = j_start, j_end+1
291
292 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
293
294 DO k=kts,ktf
295 DO i = i_start, i_end
296 vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
297 fqy( i, k, jp1 ) = vel*flux6( &
298 u(i,k,j-3), u(i,k,j-2), u(i,k,j-1), &
299 u(i,k,j ), u(i,k,j+1), u(i,k,j+2), vel )
300 ENDDO
301 ENDDO
302
303 ! we must be close to some boundary where we need to reduce the order of the stencil
304
305 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
306
307 DO k=kts,ktf
308 DO i = i_start, i_end
309 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) &
310 *(u(i,k,j)+u(i,k,j-1))
311 ENDDO
312 ENDDO
313
314 ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary
315
316 DO k=kts,ktf
317 DO i = i_start, i_end
318 vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
319 fqy( i, k, jp1 ) = vel*flux4( &
320 u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
321 ENDDO
322 ENDDO
323
324 ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary
325
326 DO k=kts,ktf
327 DO i = i_start, i_end
328 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) &
329 *(u(i,k,j)+u(i,k,j-1))
330 ENDDO
331 ENDDO
332
333 ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary
334
335 DO k=kts,ktf
336 DO i = i_start, i_end
337 vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
338 fqy( i, k, jp1 ) = vel*flux4( &
339 u(i,k,j-2),u(i,k,j-1), &
340 u(i,k,j),u(i,k,j+1),vel )
341 ENDDO
342 ENDDO
343
344 END IF
345
346 !stopped
347
348 ! y flux-divergence into tendency
349
350 ! Comments for polar boundary condition
351 ! Flow is only from one side for points next to poles
352 ! S. pole at j=jds, N. pole at j=jde for v-stagger points
353 ! Tendencies affected are held at j=jds and j=jde-1 (non-stagger)
354 ! jp0 will always hold the flux from the south, and
355 ! jp1 will hold the flux from the north.
356 !
357 ! When j=jds+1 we are 1 in from S. pole, and jp1 contains fqy(jds+1), jp0 has fqy(jds)
358 ! tendency(j-1) = - mx/dy * (u rho v (jds+1)/mx - u rho v (jds)/mx)
359 ! v(jds) = 0
360 ! tendency(j-1) = - mx/dy * (u rho v (jds+1)/mx) = - mx/dy * fqy(jp1)
361 !
362 ! When j=jde-1 we are 1 in from N. pole, and jp1 contains fqy(jde-1), jp0 has fqy(jde-2)
363 ! tendency(j-1) = - mx/dy * (u rho v (jde)/mx - u rho v (jde-1)/mx)
364 ! v(jde) = 0
365 ! tendency(j-1) = + mx/dy * (u rho v (jde-1)/mx) = + mx/dy * fqy(jp0)
366
367 ! (j > j_start) will miss the u(,,jds) tendency
368 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
369 DO k=kts,ktf
370 DO i = i_start, i_end
371 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
372 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
373 END DO
374 END DO
375 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
376 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
377 DO k=kts,ktf
378 DO i = i_start, i_end
379 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
380 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
381 END DO
382 END DO
383 ELSE ! normal code
384
385 IF(j > j_start) THEN
386
387 DO k=kts,ktf
388 DO i = i_start, i_end
389 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
390 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
391 ENDDO
392 ENDDO
393
394 ENDIF
395
396 END IF
397
398
399 jtmp = jp1
400 jp1 = jp0
401 jp0 = jtmp
402
403 ENDDO j_loop_y_flux_6
404
405 ! next, x - flux divergence
406
407 i_start = its
408 i_end = ite
409
410 j_start = jts
411 j_end = MIN(jte,jde-1)
412
413 ! higher order flux has a 5 or 7 point stencil, so compute
414 ! bounds so we can switch to second order flux close to the boundary
415
416 i_start_f = i_start
417 i_end_f = i_end+1
418
419 IF(degrade_xs) then
420 i_start = MAX(ids+1,its)
421 i_start_f = ids+3
422 ENDIF
423
424 IF(degrade_xe) then
425 i_end = MIN(ide-1,ite)
426 i_end_f = ide-2
427 ENDIF
428
429 ! compute fluxes
430
431 DO j = j_start, j_end
432
433 ! 5th or 6th order flux
434
435 DO k=kts,ktf
436 DO i = i_start_f, i_end_f
437 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
438 fqx( i,k ) = vel*flux6( u(i-3,k,j), u(i-2,k,j), &
439 u(i-1,k,j), u(i ,k,j), &
440 u(i+1,k,j), u(i+2,k,j), &
441 vel )
442 ENDDO
443 ENDDO
444
445 ! lower order fluxes close to boundaries (if not periodic or symmetric)
446 ! specified uses upstream normal wind at boundaries
447
448 IF( degrade_xs ) THEN
449
450 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
451 i = ids+1
452 DO k=kts,ktf
453 ub = u(i-1,k,j)
454 IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
455 fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
456 *(u(i,k,j)+ub)
457 ENDDO
458 END IF
459
460 i = ids+2
461 DO k=kts,ktf
462 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
463 fqx( i, k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j), &
464 u(i ,k,j), u(i+1,k,j), &
465 vel )
466 ENDDO
467
468 ENDIF
469
470 IF( degrade_xe ) THEN
471
472 IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
473 i = ide
474 DO k=kts,ktf
475 ub = u(i,k,j)
476 IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
477 fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
478 *(u(i-1,k,j)+ub)
479 ENDDO
480 ENDIF
481
482 DO k=kts,ktf
483 i = ide-1
484 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
485 fqx( i,k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j), &
486 u(i ,k,j), u(i+1,k,j), &
487 vel )
488 ENDDO
489
490 ENDIF
491
492 ! x flux-divergence into tendency
493
494 DO k=kts,ktf
495 DO i = i_start, i_end
496 mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
497 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
498 ENDDO
499 ENDDO
500
501 ENDDO
502
503 ELSE IF( horz_order == 5 ) THEN
504
505 ! 5th order horizontal flux calculation
506 ! This code is EXACTLY the same as the 6th order code
507 ! EXCEPT the 5th order and 3rd operators are used in
508 ! place of the 6th and 4th order operators
509
510 ! determine boundary mods for flux operators
511 ! We degrade the flux operators from 3rd/4th order
512 ! to second order one gridpoint in from the boundaries for
513 ! all boundary conditions except periodic and symmetry - these
514 ! conditions have boundary zone data fill for correct application
515 ! of the higher order flux stencils
516
517 degrade_xs = .true.
518 degrade_xe = .true.
519 degrade_ys = .true.
520 degrade_ye = .true.
521
522 IF( config_flags%periodic_x .or. &
523 config_flags%symmetric_xs .or. &
524 (its > ids+2) ) degrade_xs = .false.
525 IF( config_flags%periodic_x .or. &
526 config_flags%symmetric_xe .or. &
527 (ite < ide-2) ) degrade_xe = .false.
528 IF( config_flags%periodic_y .or. &
529 config_flags%symmetric_ys .or. &
530 (jts > jds+2) ) degrade_ys = .false.
531 IF( config_flags%periodic_y .or. &
532 config_flags%symmetric_ye .or. &
533 (jte < jde-3) ) degrade_ye = .false.
534
535 !--------------- y - advection first
536
537 i_start = its
538 i_end = ite
539 IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
540 IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite)
541 IF ( config_flags%periodic_x ) i_start = its
542 IF ( config_flags%periodic_x ) i_end = ite
543
544 j_start = jts
545 j_end = MIN(jte,jde-1)
546
547 ! higher order flux has a 5 or 7 point stencil, so compute
548 ! bounds so we can switch to second order flux close to the boundary
549
550 j_start_f = j_start
551 j_end_f = j_end+1
552
553 IF(degrade_ys) then
554 j_start = MAX(jts,jds+1)
555 j_start_f = jds+3
556 ENDIF
557
558 IF(degrade_ye) then
559 j_end = MIN(jte,jde-2)
560 j_end_f = jde-3
561 ENDIF
562
563 IF(config_flags%polar) j_end = MIN(jte,jde-1)
564
565 ! compute fluxes, 5th or 6th order
566
567 jp1 = 2
568 jp0 = 1
569
570 j_loop_y_flux_5 : DO j = j_start, j_end+1
571
572 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
573
574 DO k=kts,ktf
575 DO i = i_start, i_end
576 vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
577 fqy( i, k, jp1 ) = vel*flux5( &
578 u(i,k,j-3), u(i,k,j-2), u(i,k,j-1), &
579 u(i,k,j ), u(i,k,j+1), u(i,k,j+2), vel )
580 ENDDO
581 ENDDO
582
583 ! we must be close to some boundary where we need to reduce the order of the stencil
584
585 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
586
587 DO k=kts,ktf
588 DO i = i_start, i_end
589 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) &
590 *(u(i,k,j)+u(i,k,j-1))
591 ENDDO
592 ENDDO
593
594 ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary
595
596 DO k=kts,ktf
597 DO i = i_start, i_end
598 vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
599 fqy( i, k, jp1 ) = vel*flux3( &
600 u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
601 ENDDO
602 ENDDO
603
604 ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary
605
606 DO k=kts,ktf
607 DO i = i_start, i_end
608 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) &
609 *(u(i,k,j)+u(i,k,j-1))
610 ENDDO
611 ENDDO
612
613 ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary
614
615 DO k=kts,ktf
616 DO i = i_start, i_end
617 vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
618 fqy( i, k, jp1 ) = vel*flux3( &
619 u(i,k,j-2),u(i,k,j-1), &
620 u(i,k,j),u(i,k,j+1),vel )
621 ENDDO
622 ENDDO
623
624 END IF
625
626 ! y flux-divergence into tendency
627
628 ! (j > j_start) will miss the u(,,jds) tendency
629 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
630 DO k=kts,ktf
631 DO i = i_start, i_end
632 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
633 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
634 END DO
635 END DO
636 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
637 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
638 DO k=kts,ktf
639 DO i = i_start, i_end
640 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
641 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
642 END DO
643 END DO
644 ELSE ! normal code
645
646 IF(j > j_start) THEN
647
648 DO k=kts,ktf
649 DO i = i_start, i_end
650 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
651 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
652 ENDDO
653 ENDDO
654
655 ENDIF
656
657 END IF
658
659
660 jtmp = jp1
661 jp1 = jp0
662 jp0 = jtmp
663
664 ENDDO j_loop_y_flux_5
665
666 ! next, x - flux divergence
667
668 i_start = its
669 i_end = ite
670
671 j_start = jts
672 j_end = MIN(jte,jde-1)
673
674 ! higher order flux has a 5 or 7 point stencil, so compute
675 ! bounds so we can switch to second order flux close to the boundary
676
677 i_start_f = i_start
678 i_end_f = i_end+1
679
680 IF(degrade_xs) then
681 i_start = MAX(ids+1,its)
682 i_start_f = ids+3
683 ENDIF
684
685 IF(degrade_xe) then
686 i_end = MIN(ide-1,ite)
687 i_end_f = ide-2
688 ENDIF
689
690 ! compute fluxes
691
692 DO j = j_start, j_end
693
694 ! 5th or 6th order flux
695
696 DO k=kts,ktf
697 DO i = i_start_f, i_end_f
698 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
699 fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j), &
700 u(i-1,k,j), u(i ,k,j), &
701 u(i+1,k,j), u(i+2,k,j), &
702 vel )
703 ENDDO
704 ENDDO
705
706 ! lower order fluxes close to boundaries (if not periodic or symmetric)
707 ! specified uses upstream normal wind at boundaries
708
709 IF( degrade_xs ) THEN
710
711 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
712 i = ids+1
713 DO k=kts,ktf
714 ub = u(i-1,k,j)
715 IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
716 fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
717 *(u(i,k,j)+ub)
718 ENDDO
719 END IF
720
721 i = ids+2
722 DO k=kts,ktf
723 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
724 fqx( i, k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), &
725 u(i ,k,j), u(i+1,k,j), &
726 vel )
727 ENDDO
728
729 ENDIF
730
731 IF( degrade_xe ) THEN
732
733 IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
734 i = ide
735 DO k=kts,ktf
736 ub = u(i,k,j)
737 IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
738 fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
739 *(u(i-1,k,j)+ub)
740 ENDDO
741 ENDIF
742
743 DO k=kts,ktf
744 i = ide-1
745 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
746 fqx( i,k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), &
747 u(i ,k,j), u(i+1,k,j), &
748 vel )
749 ENDDO
750
751 ENDIF
752
753 ! x flux-divergence into tendency
754
755 DO k=kts,ktf
756 DO i = i_start, i_end
757 mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
758 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
759 ENDDO
760 ENDDO
761
762 ENDDO
763
764 ELSE IF( horz_order == 4 ) THEN
765
766 ! determine boundary mods for flux operators
767 ! We degrade the flux operators from 3rd/4th order
768 ! to second order one gridpoint in from the boundaries for
769 ! all boundary conditions except periodic and symmetry - these
770 ! conditions have boundary zone data fill for correct application
771 ! of the higher order flux stencils
772
773 degrade_xs = .true.
774 degrade_xe = .true.
775 degrade_ys = .true.
776 degrade_ye = .true.
777
778 IF( config_flags%periodic_x .or. &
779 config_flags%symmetric_xs .or. &
780 (its > ids+1) ) degrade_xs = .false.
781 IF( config_flags%periodic_x .or. &
782 config_flags%symmetric_xe .or. &
783 (ite < ide-1) ) degrade_xe = .false.
784 IF( config_flags%periodic_y .or. &
785 config_flags%symmetric_ys .or. &
786 (jts > jds+1) ) degrade_ys = .false.
787 IF( config_flags%periodic_y .or. &
788 config_flags%symmetric_ye .or. &
789 (jte < jde-2) ) degrade_ye = .false.
790
791 !--------------- x - advection first
792
793 i_start = its
794 i_end = ite
795 j_start = jts
796 j_end = MIN(jte,jde-1)
797
798 ! 3rd or 4th order flux has a 5 point stencil, so compute
799 ! bounds so we can switch to second order flux close to the boundary
800
801 i_start_f = i_start
802 i_end_f = i_end+1
803
804 IF(degrade_xs) then
805 i_start = ids+1
806 i_start_f = i_start+1
807 ENDIF
808
809 IF(degrade_xe) then
810 i_end = ide-1
811 i_end_f = ide-1
812 ENDIF
813
814 ! compute fluxes
815
816 DO j = j_start, j_end
817
818 DO k=kts,ktf
819 DO i = i_start_f, i_end_f
820 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
821 fqx( i, k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j), &
822 u(i ,k,j), u(i+1,k,j), vel )
823 ENDDO
824 ENDDO
825
826 ! second order flux close to boundaries (if not periodic or symmetric)
827 ! specified uses upstream normal wind at boundaries
828
829 IF( degrade_xs ) THEN
830 i = i_start
831 DO k=kts,ktf
832 ub = u(i-1,k,j)
833 IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
834 fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
835 *(u(i,k,j)+ub)
836 ENDDO
837 ENDIF
838
839 IF( degrade_xe ) THEN
840 i = i_end+1
841 DO k=kts,ktf
842 ub = u(i,k,j)
843 IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
844 fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
845 *(u(i-1,k,j)+ub)
846 ENDDO
847 ENDIF
848
849 ! x flux-divergence into tendency
850
851 DO k=kts,ktf
852 DO i = i_start, i_end
853 mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
854 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
855 ENDDO
856 ENDDO
857
858 ENDDO
859
860 ! y flux divergence
861
862 i_start = its
863 i_end = ite
864 IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
865 IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite)
866 IF ( config_flags%periodic_x ) i_start = its
867 IF ( config_flags%periodic_x ) i_end = ite
868
869 j_start = jts
870 j_end = MIN(jte,jde-1)
871
872 ! 3rd or 4th order flux has a 5 point stencil, so compute
873 ! bounds so we can switch to second order flux close to the boundary
874
875 j_start_f = j_start
876 j_end_f = j_end+1
877
878 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
879 IF(degrade_ys) then
880 j_start = jds+1
881 j_start_f = j_start+1
882 ENDIF
883
884 IF(degrade_ye) then
885 j_end = jde-2
886 j_end_f = jde-2
887 ENDIF
888
889 IF(config_flags%polar) j_end = MIN(jte,jde-1)
890
891 ! j flux loop for v flux of u momentum
892
893 jp1 = 2
894 jp0 = 1
895
896 DO j = j_start, j_end+1
897
898 IF ( (j < j_start_f) .and. degrade_ys) THEN
899 DO k = kts, ktf
900 DO i = i_start, i_end
901 fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start)) &
902 *(u(i,k,j_start)+u(i,k,j_start-1))
903 ENDDO
904 ENDDO
905 ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
906 DO k = kts, ktf
907 DO i = i_start, i_end
908 ! Assumes j>j_end_f is ONLY j_end+1 ...
909 ! fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1)) &
910 ! *(u(i,k,j_end+1)+u(i,k,j_end))
911 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) &
912 *(u(i,k,j)+u(i,k,j-1))
913 ENDDO
914 ENDDO
915 ELSE
916 ! 3rd or 4th order flux
917 DO k = kts, ktf
918 DO i = i_start, i_end
919 vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
920 fqy( i, k, jp1 ) = vel*flux4( u(i,k,j-2), u(i,k,j-1), &
921 u(i,k,j ), u(i,k,j+1), &
922 vel )
923 ENDDO
924 ENDDO
925
926 END IF
927
928 ! y flux-divergence into tendency
929
930 ! (j > j_start) will miss the u(,,jds) tendency
931 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
932 DO k=kts,ktf
933 DO i = i_start, i_end
934 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
935 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
936 END DO
937 END DO
938 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
939 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
940 DO k=kts,ktf
941 DO i = i_start, i_end
942 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
943 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
944 END DO
945 END DO
946 ELSE ! normal code
947
948 IF (j > j_start) THEN
949
950 DO k=kts,ktf
951 DO i = i_start, i_end
952 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
953 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
954 ENDDO
955 ENDDO
956
957 END IF
958
959 END IF
960
961 jtmp = jp1
962 jp1 = jp0
963 jp0 = jtmp
964
965 ENDDO
966
967 ELSE IF ( horz_order == 3 ) THEN
968
969 ! As with the 5th and 6th order flux chioces, the 3rd and 4th order
970 ! code is EXACTLY the same EXCEPT for the flux operator.
971
972 ! determine boundary mods for flux operators
973 ! We degrade the flux operators from 3rd/4th order
974 ! to second order one gridpoint in from the boundaries for
975 ! all boundary conditions except periodic and symmetry - these
976 ! conditions have boundary zone data fill for correct application
977 ! of the higher order flux stencils
978
979 degrade_xs = .true.
980 degrade_xe = .true.
981 degrade_ys = .true.
982 degrade_ye = .true.
983
984 IF( config_flags%periodic_x .or. &
985 config_flags%symmetric_xs .or. &
986 (its > ids+1) ) degrade_xs = .false.
987 IF( config_flags%periodic_x .or. &
988 config_flags%symmetric_xe .or. &
989 (ite < ide-1) ) degrade_xe = .false.
990 IF( config_flags%periodic_y .or. &
991 config_flags%symmetric_ys .or. &
992 (jts > jds+1) ) degrade_ys = .false.
993 IF( config_flags%periodic_y .or. &
994 config_flags%symmetric_ye .or. &
995 (jte < jde-2) ) degrade_ye = .false.
996
997 !--------------- x - advection first
998
999 i_start = its
1000 i_end = ite
1001 j_start = jts
1002 j_end = MIN(jte,jde-1)
1003
1004 ! 3rd or 4th order flux has a 5 point stencil, so compute
1005 ! bounds so we can switch to second order flux close to the boundary
1006
1007 i_start_f = i_start
1008 i_end_f = i_end+1
1009
1010 IF(degrade_xs) then
1011 i_start = ids+1
1012 i_start_f = i_start+1
1013 ENDIF
1014
1015 IF(degrade_xe) then
1016 i_end = ide-1
1017 i_end_f = ide-1
1018 ENDIF
1019
1020 ! compute fluxes
1021
1022 DO j = j_start, j_end
1023
1024 DO k=kts,ktf
1025 DO i = i_start_f, i_end_f
1026 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
1027 fqx( i, k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), &
1028 u(i ,k,j), u(i+1,k,j), vel )
1029 ENDDO
1030 ENDDO
1031
1032 ! second order flux close to boundaries (if not periodic or symmetric)
1033 ! specified uses upstream normal wind at boundaries
1034
1035 IF( degrade_xs ) THEN
1036 i = i_start
1037 DO k=kts,ktf
1038 ub = u(i-1,k,j)
1039 IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
1040 fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
1041 *(u(i,k,j)+ub)
1042 ENDDO
1043 ENDIF
1044
1045 IF( degrade_xe ) THEN
1046 i = i_end+1
1047 DO k=kts,ktf
1048 ub = u(i,k,j)
1049 IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
1050 fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
1051 *(u(i-1,k,j)+ub)
1052 ENDDO
1053 ENDIF
1054
1055 ! x flux-divergence into tendency
1056
1057 DO k=kts,ktf
1058 DO i = i_start, i_end
1059 mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
1060 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
1061 ENDDO
1062 ENDDO
1063 ENDDO
1064
1065 ! y flux divergence
1066
1067 i_start = its
1068 i_end = ite
1069 IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
1070 IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite)
1071 IF ( config_flags%periodic_x ) i_start = its
1072 IF ( config_flags%periodic_x ) i_end = ite
1073
1074 j_start = jts
1075 j_end = MIN(jte,jde-1)
1076
1077 ! 3rd or 4th order flux has a 5 point stencil, so compute
1078 ! bounds so we can switch to second order flux close to the boundary
1079
1080 j_start_f = j_start
1081 j_end_f = j_end+1
1082
1083 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
1084 IF(degrade_ys) then
1085 j_start = jds+1
1086 j_start_f = j_start+1
1087 ENDIF
1088
1089 IF(degrade_ye) then
1090 j_end = jde-2
1091 j_end_f = jde-2
1092 ENDIF
1093
1094 IF(config_flags%polar) j_end = MIN(jte,jde-1)
1095
1096 ! j flux loop for v flux of u momentum
1097
1098 jp1 = 2
1099 jp0 = 1
1100
1101 DO j = j_start, j_end+1
1102
1103 IF ( (j < j_start_f) .and. degrade_ys) THEN
1104 DO k = kts, ktf
1105 DO i = i_start, i_end
1106 fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start)) &
1107 *(u(i,k,j_start)+u(i,k,j_start-1))
1108 ENDDO
1109 ENDDO
1110 ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
1111 DO k = kts, ktf
1112 DO i = i_start, i_end
1113 ! Assumes j>j_end_f is ONLY j_end+1 ...
1114 ! fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1)) &
1115 ! *(u(i,k,j_end+1)+u(i,k,j_end))
1116 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) &
1117 *(u(i,k,j)+u(i,k,j-1))
1118 ENDDO
1119 ENDDO
1120 ELSE
1121 ! 3rd or 4th order flux
1122 DO k = kts, ktf
1123 DO i = i_start, i_end
1124 vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
1125 fqy( i, k, jp1 ) = vel*flux3( u(i,k,j-2), u(i,k,j-1), &
1126 u(i,k,j ), u(i,k,j+1), &
1127 vel )
1128 ENDDO
1129 ENDDO
1130
1131 END IF
1132
1133 ! y flux-divergence into tendency
1134
1135 ! (j > j_start) will miss the u(,,jds) tendency
1136 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
1137 DO k=kts,ktf
1138 DO i = i_start, i_end
1139 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
1140 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
1141 END DO
1142 END DO
1143 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
1144 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
1145 DO k=kts,ktf
1146 DO i = i_start, i_end
1147 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
1148 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
1149 END DO
1150 END DO
1151 ELSE ! normal code
1152
1153 IF (j > j_start) THEN
1154
1155 DO k=kts,ktf
1156 DO i = i_start, i_end
1157 mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
1158 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
1159 ENDDO
1160 ENDDO
1161
1162 END IF
1163
1164 END IF
1165
1166 jtmp = jp1
1167 jp1 = jp0
1168 jp0 = jtmp
1169
1170 ENDDO
1171
1172 ELSE IF ( horz_order == 2 ) THEN
1173
1174 i_start = its
1175 i_end = ite
1176 j_start = jts
1177 j_end = MIN(jte,jde-1)
1178
1179 IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
1180 IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite)
1181 IF ( specified ) i_start = MAX(ids+2,its)
1182 IF ( specified ) i_end = MIN(ide-2,ite)
1183 IF ( config_flags%periodic_x ) i_start = its
1184 IF ( config_flags%periodic_x ) i_end = ite
1185
1186 DO j = j_start, j_end
1187 DO k=kts,ktf
1188 DO i = i_start, i_end
1189 mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
1190 tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1191 *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) &
1192 -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j)))
1193 ENDDO
1194 ENDDO
1195 ENDDO
1196
1197 IF ( specified .AND. its .LE. ids+1 .AND. .NOT. config_flags%periodic_x ) THEN
1198 DO j = j_start, j_end
1199 DO k=kts,ktf
1200 i = ids+1
1201 mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
1202 ub = u(i-1,k,j)
1203 IF (u(i,k,j) .LT. 0.) ub = u(i,k,j)
1204 tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1205 *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) &
1206 -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+ub))
1207 ENDDO
1208 ENDDO
1209 ENDIF
1210 IF ( specified .AND. ite .GE. ide-1 .AND. .NOT. config_flags%periodic_x ) THEN
1211 DO j = j_start, j_end
1212 DO k=kts,ktf
1213 i = ide-1
1214 mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
1215 ub = u(i+1,k,j)
1216 IF (u(i,k,j) .GT. 0.) ub = u(i,k,j)
1217 tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1218 *((ru(i+1,k,j)+ru(i,k,j))*(ub+u(i,k,j)) &
1219 -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j)))
1220 ENDDO
1221 ENDDO
1222 ENDIF
1223
1224 IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
1225 IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-2,jte)
1226
1227 DO j = j_start, j_end
1228 DO k=kts,ktf
1229 DO i = i_start, i_end
1230 mrdy=msfux(i,j)*rdy ! ADT eqn 44, 1st term on RHS
1231 ! Comments for polar boundary condition
1232 ! Flow is only from one side for points next to poles
1233 IF ( (config_flags%polar) .AND. (j == jds) ) THEN
1234 tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 &
1235 *(rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j))
1236 ELSE IF ( (config_flags%polar) .AND. (j == jde-1) ) THEN
1237 tendency(i,k,j)=tendency(i,k,j)+mrdy*0.25 &
1238 *(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1))
1239 ELSE ! Normal code
1240 tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 &
1241 *((rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j)) &
1242 -(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1)))
1243 ENDIF
1244 ENDDO
1245 ENDDO
1246 ENDDO
1247
1248 ELSE IF ( horz_order == 0 ) THEN
1249
1250 ! Just in case we want to turn horizontal advection off, we can do it
1251
1252 ELSE
1253
1254 WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a: h_order not known ',horz_order
1255 CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1256
1257 ENDIF horizontal_order_test
1258
1259 ! radiative lateral boundary condition in x for normal velocity (u)
1260
1261 IF ( (config_flags%open_xs) .and. its == ids ) THEN
1262
1263 j_start = jts
1264 j_end = MIN(jte,jde-1)
1265
1266 DO j = j_start, j_end
1267 DO k = kts, ktf
1268 ub = MIN(ru(its,k,j)-cb*mut(its,j), 0.)
1269 tendency(its,k,j) = tendency(its,k,j) &
1270 - rdx*ub*(u_old(its+1,k,j) - u_old(its,k,j))
1271 ENDDO
1272 ENDDO
1273
1274 ENDIF
1275
1276 IF ( (config_flags%open_xe) .and. ite == ide ) THEN
1277
1278 j_start = jts
1279 j_end = MIN(jte,jde-1)
1280
1281 DO j = j_start, j_end
1282 DO k = kts, ktf
1283 ub = MAX(ru(ite,k,j)+cb*mut(ite-1,j), 0.)
1284 tendency(ite,k,j) = tendency(ite,k,j) &
1285 - rdx*ub*(u_old(ite,k,j) - u_old(ite-1,k,j))
1286 ENDDO
1287 ENDDO
1288
1289 ENDIF
1290
1291 ! pick up the rest of the horizontal radiation boundary conditions.
1292 ! (these are the computations that don't require 'cb')
1293 ! first, set to index ranges
1294
1295 i_start = its
1296 i_end = MIN(ite,ide)
1297 imin = ids
1298 imax = ide-1
1299
1300 IF (config_flags%open_xs) THEN
1301 i_start = MAX(ids+1, its)
1302 imin = ids
1303 ENDIF
1304 IF (config_flags%open_xe) THEN
1305 i_end = MIN(ite,ide-1)
1306 imax = ide-1
1307 ENDIF
1308
1309 IF( (config_flags%open_ys) .and. (jts == jds)) THEN
1310
1311 DO i = i_start, i_end
1312
1313 mrdy=msfux(i,jts)*rdy ! ADT eqn 44, 2nd term on RHS
1314 ip = MIN( imax, i )
1315 im = MAX( imin, i-1 )
1316
1317 DO k=kts,ktf
1318
1319 vw = 0.5*(rv(ip,k,jts)+rv(im,k,jts))
1320 vb = MIN( vw, 0. )
1321 dvm = rv(ip,k,jts+1)-rv(ip,k,jts)
1322 dvp = rv(im,k,jts+1)-rv(im,k,jts)
1323 tendency(i,k,jts)=tendency(i,k,jts)-mrdy*( &
1324 vb*(u_old(i,k,jts+1)-u_old(i,k,jts)) &
1325 +0.5*u(i,k,jts)*(dvm+dvp))
1326 ENDDO
1327 ENDDO
1328
1329 ENDIF
1330
1331 IF( (config_flags%open_ye) .and. (jte == jde)) THEN
1332
1333 DO i = i_start, i_end
1334
1335 mrdy=msfux(i,jte-1)*rdy ! ADT eqn 44, 2nd term on RHS
1336 ip = MIN( imax, i )
1337 im = MAX( imin, i-1 )
1338
1339 DO k=kts,ktf
1340
1341 vw = 0.5*(rv(ip,k,jte)+rv(im,k,jte))
1342 vb = MAX( vw, 0. )
1343 dvm = rv(ip,k,jte)-rv(ip,k,jte-1)
1344 dvp = rv(im,k,jte)-rv(im,k,jte-1)
1345 tendency(i,k,jte-1)=tendency(i,k,jte-1)-mrdy*( &
1346 vb*(u_old(i,k,jte-1)-u_old(i,k,jte-2)) &
1347 +0.5*u(i,k,jte-1)*(dvm+dvp))
1348 ENDDO
1349 ENDDO
1350
1351 ENDIF
1352
1353 !-------------------- vertical advection
1354 ! ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
1355 ! Here we have: - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
1356 ! Since 'my' (map scale factor in y-direction) isn't a function of z,
1357 ! this is what we need, so leave unchanged in advect_u
1358
1359 i_start = its
1360 i_end = ite
1361 j_start = jts
1362 j_end = min(jte,jde-1)
1363
1364 ! IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
1365 ! IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite)
1366
1367 IF ( config_flags%open_ys .or. specified ) i_start = MAX(ids+1,its)
1368 IF ( config_flags%open_ye .or. specified ) i_end = MIN(ide-1,ite)
1369 IF ( config_flags%periodic_x ) i_start = its
1370 IF ( config_flags%periodic_x ) i_end = ite
1371
1372 DO i = i_start, i_end
1373 vflux(i,kts)=0.
1374 vflux(i,kte)=0.
1375 ENDDO
1376
1377 vert_order_test : IF (vert_order == 6) THEN
1378
1379 DO j = j_start, j_end
1380
1381 DO k=kts+3,ktf-2
1382 DO i = i_start, i_end
1383 vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1384 vflux(i,k) = vel*flux6( &
1385 u(i,k-3,j), u(i,k-2,j), u(i,k-1,j), &
1386 u(i,k ,j), u(i,k+1,j), u(i,k+2,j), -vel )
1387 ENDDO
1388 ENDDO
1389
1390 DO i = i_start, i_end
1391
1392 k=kts+1
1393 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1394 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1395 k = kts+2
1396 vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1397 vflux(i,k) = vel*flux4( &
1398 u(i,k-2,j), u(i,k-1,j), &
1399 u(i,k ,j), u(i,k+1,j), -vel )
1400 k = ktf-1
1401 vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1402 vflux(i,k) = vel*flux4( &
1403 u(i,k-2,j), u(i,k-1,j), &
1404 u(i,k ,j), u(i,k+1,j), -vel )
1405 k=ktf
1406 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1407 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1408
1409 ENDDO
1410 DO k=kts,ktf
1411 DO i = i_start, i_end
1412 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1413 ENDDO
1414 ENDDO
1415 ENDDO
1416
1417 ELSE IF (vert_order == 5) THEN
1418
1419 DO j = j_start, j_end
1420
1421 DO k=kts+3,ktf-2
1422 DO i = i_start, i_end
1423 vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1424 vflux(i,k) = vel*flux5( &
1425 u(i,k-3,j), u(i,k-2,j), u(i,k-1,j), &
1426 u(i,k ,j), u(i,k+1,j), u(i,k+2,j), -vel )
1427 ENDDO
1428 ENDDO
1429
1430 DO i = i_start, i_end
1431
1432 k=kts+1
1433 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1434 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1435 k = kts+2
1436 vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1437 vflux(i,k) = vel*flux3( &
1438 u(i,k-2,j), u(i,k-1,j), &
1439 u(i,k ,j), u(i,k+1,j), -vel )
1440 k = ktf-1
1441 vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1442 vflux(i,k) = vel*flux3( &
1443 u(i,k-2,j), u(i,k-1,j), &
1444 u(i,k ,j), u(i,k+1,j), -vel )
1445 k=ktf
1446 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1447 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1448
1449 ENDDO
1450 DO k=kts,ktf
1451 DO i = i_start, i_end
1452 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1453 ENDDO
1454 ENDDO
1455 ENDDO
1456
1457 ELSE IF (vert_order == 4) THEN
1458
1459 DO j = j_start, j_end
1460
1461 DO k=kts+2,ktf-1
1462 DO i = i_start, i_end
1463 vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1464 vflux(i,k) = vel*flux4( &
1465 u(i,k-2,j), u(i,k-1,j), &
1466 u(i,k ,j), u(i,k+1,j), -vel )
1467 ENDDO
1468 ENDDO
1469
1470 DO i = i_start, i_end
1471
1472 k=kts+1
1473 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1474 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1475 k=ktf
1476 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1477 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1478
1479 ENDDO
1480 DO k=kts,ktf
1481 DO i = i_start, i_end
1482 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1483 ENDDO
1484 ENDDO
1485 ENDDO
1486
1487 ELSE IF (vert_order == 3) THEN
1488
1489 DO j = j_start, j_end
1490
1491 DO k=kts+2,ktf-1
1492 DO i = i_start, i_end
1493 vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1494 vflux(i,k) = vel*flux3( &
1495 u(i,k-2,j), u(i,k-1,j), &
1496 u(i,k ,j), u(i,k+1,j), -vel )
1497 ENDDO
1498 ENDDO
1499
1500 DO i = i_start, i_end
1501
1502 k=kts+1
1503 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1504 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1505 k=ktf
1506 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1507 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1508
1509 ENDDO
1510 DO k=kts,ktf
1511 DO i = i_start, i_end
1512 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1513 ENDDO
1514 ENDDO
1515 ENDDO
1516
1517 ELSE IF (vert_order == 2) THEN
1518
1519 DO j = j_start, j_end
1520 DO k=kts+1,ktf
1521 DO i = i_start, i_end
1522 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1523 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1524 ENDDO
1525 ENDDO
1526
1527
1528 DO k=kts,ktf
1529 DO i = i_start, i_end
1530 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1531 ENDDO
1532 ENDDO
1533
1534 ENDDO
1535
1536 ELSE
1537
1538 WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a: v_order not known ',vert_order
1539 CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1540
1541 ENDIF vert_order_test
1542
1543 END SUBROUTINE advect_u
1544
1545 !-------------------------------------------------------------------------------
1546
1547 SUBROUTINE advect_v ( v, v_old, tendency, &
1548 ru, rv, rom, &
1549 mut, config_flags, &
1550 msfux, msfuy, msfvx, msfvy, &
1551 msftx, msfty, &
1552 fzm, fzp, &
1553 rdx, rdy, rdzw, &
1554 ids, ide, jds, jde, kds, kde, &
1555 ims, ime, jms, jme, kms, kme, &
1556 its, ite, jts, jte, kts, kte )
1557
1558 IMPLICIT NONE
1559
1560 ! Input data
1561
1562 TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
1563
1564 INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
1565 ims, ime, jms, jme, kms, kme, &
1566 its, ite, jts, jte, kts, kte
1567
1568 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: v, &
1569 v_old, &
1570 ru, &
1571 rv, &
1572 rom
1573
1574 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut
1575 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
1576
1577 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, &
1578 msfuy, &
1579 msfvx, &
1580 msfvy, &
1581 msftx, &
1582 msfty
1583
1584 REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, &
1585 fzp, &
1586 rdzw
1587
1588 REAL , INTENT(IN ) :: rdx, &
1589 rdy
1590
1591 ! Local data
1592
1593 INTEGER :: i, j, k, itf, jtf, ktf
1594 INTEGER :: i_start, i_end, j_start, j_end
1595 INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
1596 INTEGER :: jmin, jmax, jp, jm, imin, imax
1597
1598 REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
1599 REAL , DIMENSION(its:ite, kts:kte) :: vflux
1600
1601
1602 REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx
1603 REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy
1604
1605 INTEGER :: horz_order
1606 INTEGER :: vert_order
1607
1608 LOGICAL :: degrade_xs, degrade_ys
1609 LOGICAL :: degrade_xe, degrade_ye
1610
1611 INTEGER :: jp1, jp0, jtmp
1612
1613
1614 ! definition of flux operators, 3rd, 4th, 5th or 6th order
1615
1616 REAL :: flux3, flux4, flux5, flux6
1617 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
1618
1619 flux4(q_im2, q_im1, q_i, q_ip1, ua) = &
1620 ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
1621
1622 flux3(q_im2, q_im1, q_i, q_ip1, ua) = &
1623 flux4(q_im2, q_im1, q_i, q_ip1, ua) + &
1624 sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
1625
1626 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = &
1627 ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) &
1628 +(q_ip2+q_im3) )/60.0
1629
1630 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = &
1631 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) &
1632 -sign(1.,ua)*( &
1633 (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
1634
1635
1636
1637 LOGICAL :: specified
1638
1639 specified = .false.
1640 if(config_flags%specified .or. config_flags%nested) specified = .true.
1641
1642 ! set order for the advection schemes
1643
1644 ktf=MIN(kte,kde-1)
1645 horz_order = config_flags%h_mom_adv_order
1646 vert_order = config_flags%v_mom_adv_order
1647
1648
1649 ! here is the choice of flux operators
1650
1651
1652 horizontal_order_test : IF( horz_order == 6 ) THEN
1653
1654 ! determine boundary mods for flux operators
1655 ! We degrade the flux operators from 3rd/4th order
1656 ! to second order one gridpoint in from the boundaries for
1657 ! all boundary conditions except periodic and symmetry - these
1658 ! conditions have boundary zone data fill for correct application
1659 ! of the higher order flux stencils
1660
1661 degrade_xs = .true.
1662 degrade_xe = .true.
1663 degrade_ys = .true.
1664 degrade_ye = .true.
1665
1666 IF( config_flags%periodic_x .or. &
1667 config_flags%symmetric_xs .or. &
1668 (its > ids+2) ) degrade_xs = .false.
1669 IF( config_flags%periodic_x .or. &
1670 config_flags%symmetric_xe .or. &
1671 (ite < ide-3) ) degrade_xe = .false.
1672 IF( config_flags%periodic_y .or. &
1673 config_flags%symmetric_ys .or. &
1674 (jts > jds+2) ) degrade_ys = .false.
1675 IF( config_flags%periodic_y .or. &
1676 config_flags%symmetric_ye .or. &
1677 (jte < jde-2) ) degrade_ye = .false.
1678
1679 !--------------- y - advection first
1680
1681 ktf=MIN(kte,kde-1)
1682
1683 i_start = its
1684 i_end = MIN(ite,ide-1)
1685 j_start = jts
1686 j_end = jte
1687
1688 ! higher order flux has a 5 or 7 point stencil, so compute
1689 ! bounds so we can switch to second order flux close to the boundary
1690
1691 j_start_f = j_start
1692 j_end_f = j_end+1
1693
1694 IF(degrade_ys) then
1695 j_start = MAX(jts,jds+1)
1696 j_start_f = jds+3
1697 ENDIF
1698
1699 IF(degrade_ye) then
1700 j_end = MIN(jte,jde-1)
1701 j_end_f = jde-2
1702 ENDIF
1703
1704 ! compute fluxes, 5th or 6th order
1705
1706 jp1 = 2
1707 jp0 = 1
1708
1709 j_loop_y_flux_6 : DO j = j_start, j_end+1
1710
1711 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
1712
1713 DO k=kts,ktf
1714 DO i = i_start, i_end
1715 vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1716 fqy( i, k, jp1 ) = vel*flux6( &
1717 v(i,k,j-3), v(i,k,j-2), v(i,k,j-1), &
1718 v(i,k,j ), v(i,k,j+1), v(i,k,j+2), vel )
1719 ENDDO
1720 ENDDO
1721
1722 ! we must be close to some boundary where we need to reduce the order of the stencil
1723 ! specified uses upstream normal wind at boundaries
1724
1725 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
1726
1727 DO k=kts,ktf
1728 DO i = i_start, i_end
1729 vb = v(i,k,j-1)
1730 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
1731 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) &
1732 *(v(i,k,j)+vb)
1733 ENDDO
1734 ENDDO
1735
1736 ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary
1737
1738 DO k=kts,ktf
1739 DO i = i_start, i_end
1740 vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1741 fqy( i, k, jp1 ) = vel*flux4( &
1742 v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1743 ENDDO
1744 ENDDO
1745
1746
1747 ELSE IF ( j == jde ) THEN ! 2nd order flux next to north boundary
1748
1749 DO k=kts,ktf
1750 DO i = i_start, i_end
1751 vb = v(i,k,j)
1752 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
1753 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) &
1754 *(vb+v(i,k,j-1))
1755 ENDDO
1756 ENDDO
1757
1758 ELSE IF ( j == jde-1 ) THEN ! 3rd or 4th order flux 2 in from north boundary
1759
1760 DO k=kts,ktf
1761 DO i = i_start, i_end
1762 vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1763 fqy( i, k, jp1 ) = vel*flux4( &
1764 v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1765 ENDDO
1766 ENDDO
1767
1768 END IF
1769
1770 ! y flux-divergence into tendency
1771
1772 ! Comments on polar boundary conditions
1773 ! No advection over the poles means tendencies (held from jds [S. pole]
1774 ! to jde [N pole], i.e., on v grid) must be zero at poles
1775 ! [tendency(jds) and tendency(jde)=0]
1776 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
1777 DO k=kts,ktf
1778 DO i = i_start, i_end
1779 tendency(i,k,j-1) = 0.
1780 END DO
1781 END DO
1782 ! If j_end were set to jde in a special if statement apart from
1783 ! degrade_ye, then we would hit the next conditional. But since
1784 ! we want the tendency to be zero anyway, not looping to jde+1
1785 ! will produce the same effect.
1786 ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
1787 DO k=kts,ktf
1788 DO i = i_start, i_end
1789 tendency(i,k,j-1) = 0.
1790 END DO
1791 END DO
1792 ELSE ! Normal code
1793
1794 IF(j > j_start) THEN
1795
1796 DO k=kts,ktf
1797 DO i = i_start, i_end
1798 mrdy=msfvy(i,j-1)*rdy ! ADT eqn 45, 2nd term on RHS
1799 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
1800 ENDDO
1801 ENDDO
1802
1803 ENDIF
1804
1805 END IF
1806
1807 jtmp = jp1
1808 jp1 = jp0
1809 jp0 = jtmp
1810
1811 ENDDO j_loop_y_flux_6
1812
1813 ! next, x - flux divergence
1814
1815 i_start = its
1816 i_end = MIN(ite,ide-1)
1817
1818 j_start = jts
1819 j_end = jte
1820 ! Polar boundary conditions are like open or specified
1821 IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
1822 IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte)
1823
1824 ! higher order flux has a 5 or 7 point stencil, so compute
1825 ! bounds so we can switch to second order flux close to the boundary
1826
1827 i_start_f = i_start
1828 i_end_f = i_end+1
1829
1830 IF(degrade_xs) then
1831 i_start = MAX(ids+1,its)
1832 i_start_f = i_start+2
1833 ENDIF
1834
1835 IF(degrade_xe) then
1836 i_end = MIN(ide-2,ite)
1837 i_end_f = ide-3
1838 ENDIF
1839
1840 ! compute fluxes
1841
1842 DO j = j_start, j_end
1843
1844 ! 5th or 6th order flux
1845
1846 DO k=kts,ktf
1847 DO i = i_start_f, i_end_f
1848 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1849 fqx( i, k ) = vel*flux6( v(i-3,k,j), v(i-2,k,j), &
1850 v(i-1,k,j), v(i ,k,j), &
1851 v(i+1,k,j), v(i+2,k,j), &
1852 vel )
1853 ENDDO
1854 ENDDO
1855
1856 ! lower order fluxes close to boundaries (if not periodic or symmetric)
1857
1858 IF( degrade_xs ) THEN
1859
1860 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
1861 i = ids+1
1862 DO k=kts,ktf
1863 fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
1864 *(v(i,k,j)+v(i-1,k,j))
1865 ENDDO
1866 ENDIF
1867
1868 i = ids+2
1869 DO k=kts,ktf
1870 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1871 fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j), &
1872 v(i ,k,j), v(i+1,k,j), &
1873 vel )
1874 ENDDO
1875
1876 ENDIF
1877
1878 IF( degrade_xe ) THEN
1879
1880 IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
1881 i = ide-1
1882 DO k=kts,ktf
1883 fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) &
1884 *(v(i_end+1,k,j)+v(i_end,k,j))
1885 ENDDO
1886 ENDIF
1887
1888 i = ide-2
1889 DO k=kts,ktf
1890 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1891 fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j), &
1892 v(i ,k,j), v(i+1,k,j), &
1893 vel )
1894 ENDDO
1895
1896 ENDIF
1897
1898 ! x flux-divergence into tendency
1899
1900 DO k=kts,ktf
1901 DO i = i_start, i_end
1902 mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS
1903 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
1904 ENDDO
1905 ENDDO
1906
1907 ENDDO
1908
1909 ELSE IF( horz_order == 5 ) THEN
1910
1911 ! 5th order horizontal flux calculation
1912 ! This code is EXACTLY the same as the 6th order code
1913 ! EXCEPT the 5th order and 3rd operators are used in
1914 ! place of the 6th and 4th order operators
1915
1916 ! determine boundary mods for flux operators
1917 ! We degrade the flux operators from 3rd/4th order
1918 ! to second order one gridpoint in from the boundaries for
1919 ! all boundary conditions except periodic and symmetry - these
1920 ! conditions have boundary zone data fill for correct application
1921 ! of the higher order flux stencils
1922
1923 degrade_xs = .true.
1924 degrade_xe = .true.
1925 degrade_ys = .true.
1926 degrade_ye = .true.
1927
1928 IF( config_flags%periodic_x .or. &
1929 config_flags%symmetric_xs .or. &
1930 (its > ids+2) ) degrade_xs = .false.
1931 IF( config_flags%periodic_x .or. &
1932 config_flags%symmetric_xe .or. &
1933 (ite < ide-3) ) degrade_xe = .false.
1934 IF( config_flags%periodic_y .or. &
1935 config_flags%symmetric_ys .or. &
1936 (jts > jds+2) ) degrade_ys = .false.
1937 IF( config_flags%periodic_y .or. &
1938 config_flags%symmetric_ye .or. &
1939 (jte < jde-2) ) degrade_ye = .false.
1940
1941 !--------------- y - advection first
1942
1943 i_start = its
1944 i_end = MIN(ite,ide-1)
1945 j_start = jts
1946 j_end = jte
1947
1948 ! higher order flux has a 5 or 7 point stencil, so compute
1949 ! bounds so we can switch to second order flux close to the boundary
1950
1951 j_start_f = j_start
1952 j_end_f = j_end+1
1953
1954 IF(degrade_ys) then
1955 j_start = MAX(jts,jds+1)
1956 j_start_f = jds+3
1957 ENDIF
1958
1959 IF(degrade_ye) then
1960 j_end = MIN(jte,jde-1)
1961 j_end_f = jde-2
1962 ENDIF
1963
1964 ! compute fluxes, 5th or 6th order
1965
1966 jp1 = 2
1967 jp0 = 1
1968
1969 j_loop_y_flux_5 : DO j = j_start, j_end+1
1970
1971 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
1972
1973 DO k=kts,ktf
1974 DO i = i_start, i_end
1975 vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1976 fqy( i, k, jp1 ) = vel*flux5( &
1977 v(i,k,j-3), v(i,k,j-2), v(i,k,j-1), &
1978 v(i,k,j ), v(i,k,j+1), v(i,k,j+2), vel )
1979 ENDDO
1980 ENDDO
1981
1982 ! we must be close to some boundary where we need to reduce the order of the stencil
1983 ! specified uses upstream normal wind at boundaries
1984
1985 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
1986
1987 DO k=kts,ktf
1988 DO i = i_start, i_end
1989 vb = v(i,k,j-1)
1990 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
1991 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) &
1992 *(v(i,k,j)+vb)
1993 ENDDO
1994 ENDDO
1995
1996 ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary
1997
1998 DO k=kts,ktf
1999 DO i = i_start, i_end
2000 vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2001 fqy( i, k, jp1 ) = vel*flux3( &
2002 v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
2003 ENDDO
2004 ENDDO
2005
2006
2007 ELSE IF ( j == jde ) THEN ! 2nd order flux next to north boundary
2008
2009 DO k=kts,ktf
2010 DO i = i_start, i_end
2011 vb = v(i,k,j)
2012 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2013 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) &
2014 *(vb+v(i,k,j-1))
2015 ENDDO
2016 ENDDO
2017
2018 ELSE IF ( j == jde-1 ) THEN ! 3rd or 4th order flux 2 in from north boundary
2019
2020 DO k=kts,ktf
2021 DO i = i_start, i_end
2022 vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2023 fqy( i, k, jp1 ) = vel*flux3( &
2024 v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
2025 ENDDO
2026 ENDDO
2027
2028 END IF
2029
2030 ! y flux-divergence into tendency
2031
2032 ! Comments on polar boundary conditions
2033 ! No advection over the poles means tendencies (held from jds [S. pole]
2034 ! to jde [N pole], i.e., on v grid) must be zero at poles
2035 ! [tendency(jds) and tendency(jde)=0]
2036 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2037 DO k=kts,ktf
2038 DO i = i_start, i_end
2039 tendency(i,k,j-1) = 0.
2040 END DO
2041 END DO
2042 ! If j_end were set to jde in a special if statement apart from
2043 ! degrade_ye, then we would hit the next conditional. But since
2044 ! we want the tendency to be zero anyway, not looping to jde+1
2045 ! will produce the same effect.
2046 ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2047 DO k=kts,ktf
2048 DO i = i_start, i_end
2049 tendency(i,k,j-1) = 0.
2050 END DO
2051 END DO
2052 ELSE ! Normal code
2053
2054 IF(j > j_start) THEN
2055
2056 DO k=kts,ktf
2057 DO i = i_start, i_end
2058 mrdy=msfvy(i,j-1)*rdy ! ADT eqn 45, 2nd term on RHS
2059 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2060 ENDDO
2061 ENDDO
2062
2063 ENDIF
2064
2065 END IF
2066
2067 jtmp = jp1
2068 jp1 = jp0
2069 jp0 = jtmp
2070
2071 ENDDO j_loop_y_flux_5
2072
2073 ! next, x - flux divergence
2074
2075 i_start = its
2076 i_end = MIN(ite,ide-1)
2077
2078 j_start = jts
2079 j_end = jte
2080 ! Polar boundary conditions are like open or specified
2081 IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2082 IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte)
2083
2084 ! higher order flux has a 5 or 7 point stencil, so compute
2085 ! bounds so we can switch to second order flux close to the boundary
2086
2087 i_start_f = i_start
2088 i_end_f = i_end+1
2089
2090 IF(degrade_xs) then
2091 i_start = MAX(ids+1,its)
2092 i_start_f = i_start+2
2093 ENDIF
2094
2095 IF(degrade_xe) then
2096 i_end = MIN(ide-2,ite)
2097 i_end_f = ide-3
2098 ENDIF
2099
2100 ! compute fluxes
2101
2102 DO j = j_start, j_end
2103
2104 ! 5th or 6th order flux
2105
2106 DO k=kts,ktf
2107 DO i = i_start_f, i_end_f
2108 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2109 fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j), &
2110 v(i-1,k,j), v(i ,k,j), &
2111 v(i+1,k,j), v(i+2,k,j), &
2112 vel )
2113 ENDDO
2114 ENDDO
2115
2116 ! lower order fluxes close to boundaries (if not periodic or symmetric)
2117
2118 IF( degrade_xs ) THEN
2119
2120 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
2121 i = ids+1
2122 DO k=kts,ktf
2123 fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
2124 *(v(i,k,j)+v(i-1,k,j))
2125 ENDDO
2126 ENDIF
2127
2128 i = ids+2
2129 DO k=kts,ktf
2130 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2131 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), &
2132 v(i ,k,j), v(i+1,k,j), &
2133 vel )
2134 ENDDO
2135
2136 ENDIF
2137
2138 IF( degrade_xe ) THEN
2139
2140 IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
2141 i = ide-1
2142 DO k=kts,ktf
2143 fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) &
2144 *(v(i_end+1,k,j)+v(i_end,k,j))
2145 ENDDO
2146 ENDIF
2147
2148 i = ide-2
2149 DO k=kts,ktf
2150 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2151 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), &
2152 v(i ,k,j), v(i+1,k,j), &
2153 vel )
2154 ENDDO
2155
2156 ENDIF
2157
2158 ! x flux-divergence into tendency
2159
2160 DO k=kts,ktf
2161 DO i = i_start, i_end
2162 mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS
2163 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2164 ENDDO
2165 ENDDO
2166
2167 ENDDO
2168
2169 ELSE IF( horz_order == 4 ) THEN
2170
2171 ! determine boundary mods for flux operators
2172 ! We degrade the flux operators from 3rd/4th order
2173 ! to second order one gridpoint in from the boundaries for
2174 ! all boundary conditions except periodic and symmetry - these
2175 ! conditions have boundary zone data fill for correct application
2176 ! of the higher order flux stencils
2177
2178 degrade_xs = .true.
2179 degrade_xe = .true.
2180 degrade_ys = .true.
2181 degrade_ye = .true.
2182
2183 IF( config_flags%periodic_x .or. &
2184 config_flags%symmetric_xs .or. &
2185 (its > ids+1) ) degrade_xs = .false.
2186 IF( config_flags%periodic_x .or. &
2187 config_flags%symmetric_xe .or. &
2188 (ite < ide-2) ) degrade_xe = .false.
2189 IF( config_flags%periodic_y .or. &
2190 config_flags%symmetric_ys .or. &
2191 (jts > jds+1) ) degrade_ys = .false.
2192 IF( config_flags%periodic_y .or. &
2193 config_flags%symmetric_ye .or. &
2194 (jte < jde-1) ) degrade_ye = .false.
2195
2196 !--------------- y - advection first
2197
2198
2199 ktf=MIN(kte,kde-1)
2200
2201 i_start = its
2202 i_end = MIN(ite,ide-1)
2203 j_start = jts
2204 j_end = jte
2205
2206 ! 3rd or 4th order flux has a 5 point stencil, so compute
2207 ! bounds so we can switch to second order flux close to the boundary
2208
2209 j_start_f = j_start
2210 j_end_f = j_end+1
2211
2212 !CJM May not work with tiling because defined in terms of domain dims
2213 IF(degrade_ys) then
2214 j_start = jds+1
2215 j_start_f = j_start+1
2216 ENDIF
2217
2218 IF(degrade_ye) then
2219 j_end = jde-1
2220 j_end_f = jde-1
2221 ENDIF
2222
2223 ! compute fluxes
2224 ! specified uses upstream normal wind at boundaries
2225
2226 jp0 = 1
2227 jp1 = 2
2228
2229 DO j = j_start, j_end+1
2230
2231 IF ((j == j_start) .and. degrade_ys) THEN
2232 DO k = kts,ktf
2233 DO i = i_start, i_end
2234 vb = v(i,k,j-1)
2235 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
2236 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) &
2237 *(v(i,k,j)+vb)
2238 ENDDO
2239 ENDDO
2240 ELSE IF ((j == j_end+1) .and. degrade_ye) THEN
2241 DO k = kts, ktf
2242 DO i = i_start, i_end
2243 vb = v(i,k,j)
2244 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2245 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) &
2246 *(vb+v(i,k,j-1))
2247 ENDDO
2248 ENDDO
2249 ELSE
2250 DO k = kts, ktf
2251 DO i = i_start, i_end
2252 vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2253 fqy( i,k,jp1 ) = vel*flux4( v(i,k,j-2), v(i,k,j-1), &
2254 v(i,k,j ), v(i,k,j+1), &
2255 vel )
2256 ENDDO
2257 ENDDO
2258 END IF
2259
2260 ! Comments on polar boundary conditions
2261 ! No advection over the poles means tendencies (held from jds [S. pole]
2262 ! to jde [N pole], i.e., on v grid) must be zero at poles
2263 ! [tendency(jds) and tendency(jde)=0]
2264 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2265 DO k=kts,ktf
2266 DO i = i_start, i_end
2267 tendency(i,k,j-1) = 0.
2268 END DO
2269 END DO
2270 ! If j_end were set to jde in a special if statement apart from
2271 ! degrade_ye, then we would hit the next conditional. But since
2272 ! we want the tendency to be zero anyway, not looping to jde+1
2273 ! will produce the same effect.
2274 ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2275 DO k=kts,ktf
2276 DO i = i_start, i_end
2277 tendency(i,k,j-1) = 0.
2278 END DO
2279 END DO
2280 ELSE ! Normal code
2281
2282 IF( j > j_start) THEN
2283 DO k = kts, ktf
2284 DO i = i_start, i_end
2285 mrdy=msfvy(i,j-1)*rdy ! ADT eqn 45, 2nd term on RHS
2286 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2287 ENDDO
2288 ENDDO
2289
2290 END IF
2291
2292 END IF
2293
2294 jtmp = jp1
2295 jp1 = jp0
2296 jp0 = jtmp
2297
2298 ENDDO
2299
2300 ! next, x - flux divergence
2301
2302
2303 i_start = its
2304 i_end = MIN(ite,ide-1)
2305
2306 j_start = jts
2307 j_end = jte
2308 ! Polar boundary conditions are like open or specified
2309 IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2310 IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte)
2311
2312 ! 3rd or 4th order flux has a 5 point stencil, so compute
2313 ! bounds so we can switch to second order flux close to the boundary
2314
2315 i_start_f = i_start
2316 i_end_f = i_end+1
2317
2318 IF(degrade_xs) then
2319 i_start = ids+1
2320 i_start_f = i_start+1
2321 ENDIF
2322
2323 IF(degrade_xe) then
2324 i_end = ide-2
2325 i_end_f = ide-2
2326 ENDIF
2327
2328 ! compute fluxes
2329
2330 DO j = j_start, j_end
2331
2332 ! 3rd or 4th order flux
2333
2334 DO k=kts,ktf
2335 DO i = i_start_f, i_end_f
2336 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2337 fqx( i, k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j), &
2338 v(i ,k,j), v(i+1,k,j), &
2339 vel )
2340 ENDDO
2341 ENDDO
2342
2343 ! second order flux close to boundaries (if not periodic or symmetric)
2344
2345 IF( degrade_xs ) THEN
2346 DO k=kts,ktf
2347 fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) &
2348 *(v(i_start,k,j)+v(i_start-1,k,j))
2349 ENDDO
2350 ENDIF
2351
2352 IF( degrade_xe ) THEN
2353 DO k=kts,ktf
2354 fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) &
2355 *(v(i_end+1,k,j)+v(i_end,k,j))
2356 ENDDO
2357 ENDIF
2358
2359 ! x flux-divergence into tendency
2360
2361 DO k=kts,ktf
2362 DO i = i_start, i_end
2363 mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS
2364 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2365 ENDDO
2366 ENDDO
2367
2368 ENDDO
2369
2370 ELSE IF( horz_order == 3 ) THEN
2371
2372 ! determine boundary mods for flux operators
2373 ! We degrade the flux operators from 3rd/4th order
2374 ! to second order one gridpoint in from the boundaries for
2375 ! all boundary conditions except periodic and symmetry - these
2376 ! conditions have boundary zone data fill for correct application
2377 ! of the higher order flux stencils
2378
2379 degrade_xs = .true.
2380 degrade_xe = .true.
2381 degrade_ys = .true.
2382 degrade_ye = .true.
2383
2384 IF( config_flags%periodic_x .or. &
2385 config_flags%symmetric_xs .or. &
2386 (its > ids+1) ) degrade_xs = .false.
2387 IF( config_flags%periodic_x .or. &
2388 config_flags%symmetric_xe .or. &
2389 (ite < ide-2) ) degrade_xe = .false.
2390 IF( config_flags%periodic_y .or. &
2391 config_flags%symmetric_ys .or. &
2392 (jts > jds+1) ) degrade_ys = .false.
2393 IF( config_flags%periodic_y .or. &
2394 config_flags%symmetric_ye .or. &
2395 (jte < jde-1) ) degrade_ye = .false.
2396
2397 !--------------- y - advection first
2398
2399
2400 ktf=MIN(kte,kde-1)
2401
2402 i_start = its
2403 i_end = MIN(ite,ide-1)
2404 j_start = jts
2405 j_end = jte
2406
2407 ! 3rd or 4th order flux has a 5 point stencil, so compute
2408 ! bounds so we can switch to second order flux close to the boundary
2409
2410 j_start_f = j_start
2411 j_end_f = j_end+1
2412
2413 !CJM May not work with tiling because defined in terms of domain dims
2414 IF(degrade_ys) then
2415 j_start = jds+1
2416 j_start_f = j_start+1
2417 ENDIF
2418
2419 IF(degrade_ye) then
2420 j_end = jde-1
2421 j_end_f = jde-1
2422 ENDIF
2423
2424 ! compute fluxes
2425 ! specified uses upstream normal wind at boundaries
2426
2427 jp0 = 1
2428 jp1 = 2
2429
2430 DO j = j_start, j_end+1
2431
2432 IF ((j == j_start) .and. degrade_ys) THEN
2433 DO k = kts,ktf
2434 DO i = i_start, i_end
2435 vb = v(i,k,j-1)
2436 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
2437 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) &
2438 *(v(i,k,j)+vb)
2439 ENDDO
2440 ENDDO
2441 ELSE IF ((j == j_end+1) .and. degrade_ye) THEN
2442 DO k = kts, ktf
2443 DO i = i_start, i_end
2444 vb = v(i,k,j)
2445 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2446 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) &
2447 *(vb+v(i,k,j-1))
2448 ENDDO
2449 ENDDO
2450 ELSE
2451 DO k = kts, ktf
2452 DO i = i_start, i_end
2453 vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2454 fqy( i,k,jp1 ) = vel*flux3( v(i,k,j-2), v(i,k,j-1), &
2455 v(i,k,j ), v(i,k,j+1), &
2456 vel )
2457 ENDDO
2458 ENDDO
2459 END IF
2460
2461 ! Comments on polar boundary conditions
2462 ! No advection over the poles means tendencies (held from jds [S. pole]
2463 ! to jde [N pole], i.e., on v grid) must be zero at poles
2464 ! [tendency(jds) and tendency(jde)=0]
2465 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2466 DO k=kts,ktf
2467 DO i = i_start, i_end
2468 tendency(i,k,j-1) = 0.
2469 END DO
2470 END DO
2471 ! If j_end were set to jde in a special if statement apart from
2472 ! degrade_ye, then we would hit the next conditional. But since
2473 ! we want the tendency to be zero anyway, not looping to jde+1
2474 ! will produce the same effect.
2475 ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2476 DO k=kts,ktf
2477 DO i = i_start, i_end
2478 tendency(i,k,j-1) = 0.
2479 END DO
2480 END DO
2481 ELSE ! Normal code
2482
2483 IF( j > j_start) THEN
2484 DO k = kts, ktf
2485 DO i = i_start, i_end
2486 mrdy=msfvy(i,j-1)*rdy ! ADT eqn 45, 2nd term on RHS
2487 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2488 ENDDO
2489 ENDDO
2490
2491 END IF
2492
2493 END IF
2494
2495 jtmp = jp1
2496 jp1 = jp0
2497 jp0 = jtmp
2498
2499 ENDDO
2500
2501 ! next, x - flux divergence
2502
2503
2504 i_start = its
2505 i_end = MIN(ite,ide-1)
2506
2507 j_start = jts
2508 j_end = jte
2509 ! Polar boundary conditions are like open or specified
2510 IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2511 IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte)
2512
2513 ! 3rd or 4th order flux has a 5 point stencil, so compute
2514 ! bounds so we can switch to second order flux close to the boundary
2515
2516 i_start_f = i_start
2517 i_end_f = i_end+1
2518
2519 IF(degrade_xs) then
2520 i_start = ids+1
2521 i_start_f = i_start+1
2522 ENDIF
2523
2524 IF(degrade_xe) then
2525 i_end = ide-2
2526 i_end_f = ide-2
2527 ENDIF
2528
2529 ! compute fluxes
2530
2531 DO j = j_start, j_end
2532
2533 ! 3rd or 4th order flux
2534
2535 DO k=kts,ktf
2536 DO i = i_start_f, i_end_f
2537 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2538 fqx( i, k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), &
2539 v(i ,k,j), v(i+1,k,j), &
2540 vel )
2541 ENDDO
2542 ENDDO
2543
2544 ! second order flux close to boundaries (if not periodic or symmetric)
2545
2546 IF( degrade_xs ) THEN
2547 DO k=kts,ktf
2548 fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) &
2549 *(v(i_start,k,j)+v(i_start-1,k,j))
2550 ENDDO
2551 ENDIF
2552
2553 IF( degrade_xe ) THEN
2554 DO k=kts,ktf
2555 fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) &
2556 *(v(i_end+1,k,j)+v(i_end,k,j))
2557 ENDDO
2558 ENDIF
2559
2560 ! x flux-divergence into tendency
2561
2562 DO k=kts,ktf
2563 DO i = i_start, i_end
2564 mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS
2565 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2566 ENDDO
2567 ENDDO
2568
2569 ENDDO
2570
2571 ELSE IF( horz_order == 2 ) THEN
2572
2573
2574 i_start = its
2575 i_end = MIN(ite,ide-1)
2576 j_start = jts
2577 j_end = jte
2578
2579 IF ( config_flags%open_ys ) j_start = MAX(jds+1,jts)
2580 IF ( config_flags%open_ye ) j_end = MIN(jde-1,jte)
2581 IF ( specified ) j_start = MAX(jds+2,jts)
2582 IF ( specified ) j_end = MIN(jde-2,jte)
2583 IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
2584 IF ( config_flags%polar ) j_end = MIN(jde-1,jte)
2585
2586 DO j = j_start, j_end
2587 DO k=kts,ktf
2588 DO i = i_start, i_end
2589
2590 mrdy=msfvy(i,j)*rdy ! ADT eqn 45, 2nd term on RHS
2591
2592 tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2593 *((rv(i,k,j+1)+rv(i,k,j ))*(v(i,k,j+1)+v(i,k,j )) &
2594 -(rv(i,k,j )+rv(i,k,j-1))*(v(i,k,j )+v(i,k,j-1)))
2595
2596 ENDDO
2597 ENDDO
2598 ENDDO
2599
2600 ! Comments on polar boundary conditions
2601 ! tendencies = 0 at poles, and polar points do not contribute at points
2602 ! next to poles
2603 IF (config_flags%polar) THEN
2604 IF (jts == jds) THEN
2605 DO k=kts,ktf
2606 DO i = i_start, i_end
2607 tendency(i,k,jds) = 0.
2608 END DO
2609 END DO
2610 END IF
2611 IF (jte == jde) THEN
2612 DO k=kts,ktf
2613 DO i = i_start, i_end
2614 tendency(i,k,jde) = 0.
2615 END DO
2616 END DO
2617 END IF
2618 END IF
2619
2620 ! specified uses upstream normal wind at boundaries
2621
2622 IF ( specified .AND. jts .LE. jds+1 ) THEN
2623 j = jds+1
2624 DO k=kts,ktf
2625 DO i = i_start, i_end
2626 mrdy=msfvy(i,j)*rdy ! ADT eqn 45, 2nd term on RHS
2627 vb = v(i,k,j-1)
2628 IF (v(i,k,j) .LT. 0.) vb = v(i,k,j)
2629
2630 tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2631 *((rv(i,k,j+1)+rv(i,k,j ))*(v(i,k,j+1)+v(i,k,j )) &
2632 -(rv(i,k,j )+rv(i,k,j-1))*(v(i,k,j )+vb))
2633
2634 ENDDO
2635 ENDDO
2636 ENDIF
2637
2638 IF ( specified .AND. jte .GE. jde-1 ) THEN
2639 j = jde-1
2640 DO k=kts,ktf
2641 DO i = i_start, i_end
2642
2643 mrdy=msfvy(i,j)*rdy ! ADT eqn 45, 2nd term on RHS
2644 vb = v(i,k,j+1)
2645 IF (v(i,k,j) .GT. 0.) vb = v(i,k,j)
2646
2647 tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2648 *((rv(i,k,j+1)+rv(i,k,j ))*(vb+v(i,k,j )) &
2649 -(rv(i,k,j )+rv(i,k,j-1))*(v(i,k,j )+v(i,k,j-1)))
2650
2651 ENDDO
2652 ENDDO
2653 ENDIF
2654
2655 IF ( .NOT. config_flags%periodic_x ) THEN
2656 IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
2657 IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite)
2658 ENDIF
2659 IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
2660 IF ( config_flags%polar ) j_end = MIN(jde-1,jte)
2661
2662 DO j = j_start, j_end
2663 DO k=kts,ktf
2664 DO i = i_start, i_end
2665
2666 mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS
2667
2668 tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
2669 *((ru(i+1,k,j)+ru(i+1,k,j-1))*(v(i+1,k,j)+v(i ,k,j)) &
2670 -(ru(i ,k,j)+ru(i ,k,j-1))*(v(i ,k,j)+v(i-1,k,j)))
2671
2672 ENDDO
2673 ENDDO
2674 ENDDO
2675
2676 ELSE IF ( horz_order == 0 ) THEN
2677
2678 ! Just in case we want to turn horizontal advection off, we can do it
2679
2680 ELSE
2681
2682
2683 WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: h_order not known ',horz_order
2684 CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
2685
2686 ENDIF horizontal_order_test
2687
2688 ! Comments on polar boundary condition
2689 ! Force tendency=0 at NP and SP
2690 ! We keep setting this everywhere, but it can't hurt...
2691 IF ( config_flags%polar .AND. (jts == jds) ) THEN
2692 DO i=its,ite
2693 DO k=kts,ktf
2694 tendency(i,k,jts)=0.
2695 END DO
2696 END DO
2697 END IF
2698 IF ( config_flags%polar .AND. (jte == jde) ) THEN
2699 DO i=its,ite
2700 DO k=kts,ktf
2701 tendency(i,k,jte)=0.
2702 END DO
2703 END DO
2704 END IF
2705
2706 ! radiative lateral boundary condition in y for normal velocity (v)
2707
2708 IF ( (config_flags%open_ys) .and. jts == jds ) THEN
2709
2710 i_start = its
2711 i_end = MIN(ite,ide-1)
2712
2713 DO i = i_start, i_end
2714 DO k = kts, ktf
2715 vb = MIN(rv(i,k,jts)-cb*mut(i,jts), 0.)
2716 tendency(i,k,jts) = tendency(i,k,jts) &
2717 - rdy*vb*(v_old(i,k,jts+1) - v_old(i,k,jts))
2718 ENDDO
2719 ENDDO
2720
2721 ENDIF
2722
2723 IF ( (config_flags%open_ye) .and. jte == jde ) THEN
2724
2725 i_start = its
2726 i_end = MIN(ite,ide-1)
2727
2728 DO i = i_start, i_end
2729 DO k = kts, ktf
2730 vb = MAX(rv(i,k,jte)+cb*mut(i,jte-1), 0.)
2731 tendency(i,k,jte) = tendency(i,k,jte) &
2732 - rdy*vb*(v_old(i,k,jte) - v_old(i,k,jte-1))
2733 ENDDO
2734 ENDDO
2735
2736 ENDIF
2737
2738 ! pick up the rest of the horizontal radiation boundary conditions.
2739 ! (these are the computations that don't require 'cb'.
2740 ! first, set to index ranges
2741
2742 j_start = jts
2743 j_end = MIN(jte,jde)
2744
2745 jmin = jds
2746 jmax = jde-1
2747
2748 IF (config_flags%open_ys) THEN
2749 j_start = MAX(jds+1, jts)
2750 jmin = jds
2751 ENDIF
2752 IF (config_flags%open_ye) THEN
2753 j_end = MIN(jte,jde-1)
2754 jmax = jde-1
2755 ENDIF
2756
2757 ! compute x (u) conditions for v, w, or scalar
2758
2759 IF( (config_flags%open_xs) .and. (its == ids)) THEN
2760
2761 DO j = j_start, j_end
2762
2763 mrdx=msfvy(its,j)*rdx ! ADT eqn 45, 1st term on RHS
2764 jp = MIN( jmax, j )
2765 jm = MAX( jmin, j-1 )
2766
2767 DO k=kts,ktf
2768
2769 uw = 0.5*(ru(its,k,jp)+ru(its,k,jm))
2770 ub = MIN( uw, 0. )
2771 dup = ru(its+1,k,jp)-ru(its,k,jp)
2772 dum = ru(its+1,k,jm)-ru(its,k,jm)
2773 tendency(its,k,j)=tendency(its,k,j)-mrdx*( &
2774 ub*(v_old(its+1,k,j)-v_old(its,k,j)) &
2775 +0.5*v(its,k,j)*(dup+dum))
2776 ENDDO
2777 ENDDO
2778
2779 ENDIF
2780
2781 IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
2782 DO j = j_start, j_end
2783
2784 mrdx=msfvy(ite-1,j)*rdx ! ADT eqn 45, 1st term on RHS
2785 jp = MIN( jmax, j )
2786 jm = MAX( jmin, j-1 )
2787
2788 DO k=kts,ktf
2789
2790 uw = 0.5*(ru(ite,k,jp)+ru(ite,k,jm))
2791 ub = MAX( uw, 0. )
2792 dup = ru(ite,k,jp)-ru(ite-1,k,jp)
2793 dum = ru(ite,k,jm)-ru(ite-1,k,jm)
2794
2795 ! tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*( &
2796 ! ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j)) &
2797 ! +0.5*v(ite-1,k,j)* &
2798 ! ( ru(ite,k,jp)-ru(ite-1,k,jp) &
2799 ! +ru(ite,k,jm)-ru(ite-1,k,jm)) )
2800 tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*( &
2801 ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j)) &
2802 +0.5*v(ite-1,k,j)*(dup+dum))
2803
2804 ENDDO
2805 ENDDO
2806
2807 ENDIF
2808
2809 !-------------------- vertical advection
2810 ! ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
2811 ! Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
2812 ! We therefore need to make a correction for advect_v
2813 ! since 'my' (map scale factor in y direction) isn't a function of z,
2814 ! we can do this using *(my/mx) (see eqn. 45 for example)
2815
2816
2817 i_start = its
2818 i_end = MIN(ite,ide-1)
2819 j_start = jts
2820 j_end = jte
2821
2822 DO i = i_start, i_end
2823 vflux(i,kts)=0.
2824 vflux(i,kte)=0.
2825 ENDDO
2826
2827 ! Polar boundary conditions are like open or specified
2828 ! We don't want to calculate vertical v tendencies at the N or S pole
2829 IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2830 IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte)
2831
2832 vert_order_test : IF (vert_order == 6) THEN
2833
2834 DO j = j_start, j_end
2835
2836
2837 DO k=kts+3,ktf-2
2838 DO i = i_start, i_end
2839 vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2840 vflux(i,k) = vel*flux6( &
2841 v(i,k-3,j), v(i,k-2,j), v(i,k-1,j), &
2842 v(i,k ,j), v(i,k+1,j), v(i,k+2,j), -vel )
2843 ENDDO
2844 ENDDO
2845
2846 DO i = i_start, i_end
2847 k=kts+1
2848 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2849 *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2850 k = kts+2
2851 vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2852 vflux(i,k) = vel*flux4( &
2853 v(i,k-2,j), v(i,k-1,j), &
2854 v(i,k ,j), v(i,k+1,j), -vel )
2855 k = ktf-1
2856 vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2857 vflux(i,k) = vel*flux4( &
2858 v(i,k-2,j), v(i,k-1,j), &
2859 v(i,k ,j), v(i,k+1,j), -vel )
2860 k=ktf
2861 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2862 *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2863
2864 ENDDO
2865
2866
2867 DO k=kts,ktf
2868 DO i = i_start, i_end
2869 ! We are calculating vertical fluxes on v points,
2870 ! so we must mean msf_v_x/y variables
2871 tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
2872 ENDDO
2873 ENDDO
2874
2875 ENDDO
2876
2877 ELSE IF (vert_order == 5) THEN
2878
2879 DO j = j_start, j_end
2880
2881
2882 DO k=kts+3,ktf-2
2883 DO i = i_start, i_end
2884 vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2885 vflux(i,k) = vel*flux5( &
2886 v(i,k-3,j), v(i,k-2,j), v(i,k-1,j), &
2887 v(i,k ,j), v(i,k+1,j), v(i,k+2,j), -vel )
2888 ENDDO
2889 ENDDO
2890
2891 DO i = i_start, i_end
2892 k=kts+1
2893 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2894 *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2895 k = kts+2
2896 vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2897 vflux(i,k) = vel*flux3( &
2898 v(i,k-2,j), v(i,k-1,j), &
2899 v(i,k ,j), v(i,k+1,j), -vel )
2900 k = ktf-1
2901 vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2902 vflux(i,k) = vel*flux3( &
2903 v(i,k-2,j), v(i,k-1,j), &
2904 v(i,k ,j), v(i,k+1,j), -vel )
2905 k=ktf
2906 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2907 *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2908
2909 ENDDO
2910
2911
2912 DO k=kts,ktf
2913 DO i = i_start, i_end
2914 ! We are calculating vertical fluxes on v points,
2915 ! so we must mean msf_v_x/y variables
2916 tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
2917 ENDDO
2918 ENDDO
2919
2920 ENDDO
2921
2922 ELSE IF (vert_order == 4) THEN
2923
2924 DO j = j_start, j_end
2925
2926
2927 DO k=kts+2,ktf-1
2928 DO i = i_start, i_end
2929 vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2930 vflux(i,k) = vel*flux4( &
2931 v(i,k-2,j), v(i,k-1,j), &
2932 v(i,k ,j), v(i,k+1,j), -vel )
2933 ENDDO
2934 ENDDO
2935
2936 DO i = i_start, i_end
2937 k=kts+1
2938 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2939 *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2940 k=ktf
2941 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2942 *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2943
2944 ENDDO
2945
2946
2947 DO k=kts,ktf
2948 DO i = i_start, i_end
2949 ! We are calculating vertical fluxes on v points,
2950 ! so we must mean msf_v_x/y variables
2951 tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
2952 ENDDO
2953 ENDDO
2954
2955 ENDDO
2956
2957 ELSE IF (vert_order == 3) THEN
2958
2959 DO j = j_start, j_end
2960
2961
2962 DO k=kts+2,ktf-1
2963 DO i = i_start, i_end
2964 vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2965 vflux(i,k) = vel*flux3( &
2966 v(i,k-2,j), v(i,k-1,j), &
2967 v(i,k ,j), v(i,k+1,j), -vel )
2968 ENDDO
2969 ENDDO
2970
2971 DO i = i_start, i_end
2972 k=kts+1
2973 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2974 *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2975 k=ktf
2976 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2977 *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2978
2979 ENDDO
2980
2981
2982 DO k=kts,ktf
2983 DO i = i_start, i_end
2984 ! We are calculating vertical fluxes on v points,
2985 ! so we must mean msf_v_x/y variables
2986 tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
2987 ENDDO
2988 ENDDO
2989
2990 ENDDO
2991
2992
2993 ELSE IF (vert_order == 2) THEN
2994
2995 DO j = j_start, j_end
2996 DO k=kts+1,ktf
2997 DO i = i_start, i_end
2998
2999 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
3000 *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
3001 ENDDO
3002 ENDDO
3003
3004 DO k=kts,ktf
3005 DO i = i_start, i_end
3006 ! We are calculating vertical fluxes on v points,
3007 ! so we must mean msf_v_x/y variables
3008 tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
3009 ENDDO
3010 ENDDO
3011 ENDDO
3012
3013 ELSE
3014
3015 WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: v_order not known ',vert_order
3016 CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
3017
3018 ENDIF vert_order_test
3019
3020 END SUBROUTINE advect_v
3021
3022 !-------------------------------------------------------------------
3023
3024 SUBROUTINE advect_scalar ( field, field_old, tendency, &
3025 ru, rv, rom, &
3026 mut, config_flags, &
3027 msfux, msfuy, msfvx, msfvy, &
3028 msftx, msfty, &
3029 fzm, fzp, &
3030 rdx, rdy, rdzw, &
3031 ids, ide, jds, jde, kds, kde, &
3032 ims, ime, jms, jme, kms, kme, &
3033 its, ite, jts, jte, kts, kte )
3034
3035 IMPLICIT NONE
3036
3037 ! Input data
3038
3039 TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
3040
3041 INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
3042 ims, ime, jms, jme, kms, kme, &
3043 its, ite, jts, jte, kts, kte
3044
3045 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, &
3046 field_old, &
3047 ru, &
3048 rv, &
3049 rom
3050
3051 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut
3052 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
3053
3054 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, &
3055 msfuy, &
3056 msfvx, &
3057 msfvy, &
3058 msftx, &
3059 msfty
3060
3061 REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, &
3062 fzp, &
3063 rdzw
3064
3065 REAL , INTENT(IN ) :: rdx, &
3066 rdy
3067
3068 ! Local data
3069
3070 INTEGER :: i, j, k, itf, jtf, ktf
3071 INTEGER :: i_start, i_end, j_start, j_end
3072 INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
3073 INTEGER :: jmin, jmax, jp, jm, imin, imax
3074
3075 REAL :: mrdx, mrdy, ub, vb, uw, vw
3076 REAL , DIMENSION(its:ite, kts:kte) :: vflux
3077
3078
3079 REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx
3080 REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy
3081
3082 INTEGER :: horz_order, vert_order
3083
3084 LOGICAL :: degrade_xs, degrade_ys
3085 LOGICAL :: degrade_xe, degrade_ye
3086
3087 INTEGER :: jp1, jp0, jtmp
3088
3089
3090 ! definition of flux operators, 3rd, 4th, 5th or 6th order
3091
3092 REAL :: flux3, flux4, flux5, flux6
3093 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
3094
3095 flux4(q_im2, q_im1, q_i, q_ip1, ua) = &
3096 ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
3097
3098 flux3(q_im2, q_im1, q_i, q_ip1, ua) = &
3099 flux4(q_im2, q_im1, q_i, q_ip1, ua) + &
3100 sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
3101
3102 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = &
3103 ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) &
3104 +(q_ip2+q_im3) )/60.0
3105
3106 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = &
3107 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) &
3108 -sign(1.,ua)*( &
3109 (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
3110
3111
3112 LOGICAL :: specified
3113
3114 specified = .false.
3115 if(config_flags%specified .or. config_flags%nested) specified = .true.
3116
3117 ! set order for the advection schemes
3118
3119 ktf=MIN(kte,kde-1)
3120 horz_order = config_flags%h_sca_adv_order
3121 vert_order = config_flags%v_sca_adv_order
3122
3123 ! begin with horizontal flux divergence
3124 ! here is the choice of flux operators
3125
3126
3127 horizontal_order_test : IF( horz_order == 6 ) THEN
3128
3129 ! determine boundary mods for flux operators
3130 ! We degrade the flux operators from 3rd/4th order
3131 ! to second order one gridpoint in from the boundaries for
3132 ! all boundary conditions except periodic and symmetry - these
3133 ! conditions have boundary zone data fill for correct application
3134 ! of the higher order flux stencils
3135
3136 degrade_xs = .true.
3137 degrade_xe = .true.
3138 degrade_ys = .true.
3139 degrade_ye = .true.
3140
3141 IF( config_flags%periodic_x .or. &
3142 config_flags%symmetric_xs .or. &
3143 (its > ids+2) ) degrade_xs = .false.
3144 IF( config_flags%periodic_x .or. &
3145 config_flags%symmetric_xe .or. &
3146 (ite < ide-3) ) degrade_xe = .false.
3147 IF( config_flags%periodic_y .or. &
3148 config_flags%symmetric_ys .or. &
3149 (jts > jds+2) ) degrade_ys = .false.
3150 IF( config_flags%periodic_y .or. &
3151 config_flags%symmetric_ye .or. &
3152 (jte < jde-3) ) degrade_ye = .false.
3153
3154 !--------------- y - advection first
3155
3156 ktf=MIN(kte,kde-1)
3157 i_start = its
3158 i_end = MIN(ite,ide-1)
3159 j_start = jts
3160 j_end = MIN(jte,jde-1)
3161
3162 ! higher order flux has a 5 or 7 point stencil, so compute
3163 ! bounds so we can switch to second order flux close to the boundary
3164
3165 j_start_f = j_start
3166 j_end_f = j_end+1
3167
3168 IF(degrade_ys) then
3169 j_start = MAX(jts,jds+1)
3170 j_start_f = jds+3
3171 ENDIF
3172
3173 IF(degrade_ye) then
3174 j_end = MIN(jte,jde-2)
3175 j_end_f = jde-3
3176 ENDIF
3177
3178 IF(config_flags%polar) j_end = MIN(jte,jde-1)
3179
3180 ! compute fluxes, 5th or 6th order
3181
3182 jp1 = 2
3183 jp0 = 1
3184
3185 j_loop_y_flux_6 : DO j = j_start, j_end+1
3186
3187 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
3188
3189 DO k=kts,ktf
3190 DO i = i_start, i_end
3191 vel = rv(i,k,j)
3192 fqy( i, k, jp1 ) = vel*flux6( &
3193 field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), &
3194 field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel )
3195 ENDDO
3196 ENDDO
3197
3198 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
3199
3200 DO k=kts,ktf
3201 DO i = i_start, i_end
3202 fqy(i,k, jp1) = 0.5*rv(i,k,j)* &
3203 (field(i,k,j)+field(i,k,j-1))
3204
3205 ENDDO
3206 ENDDO
3207
3208 ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary
3209
3210 DO k=kts,ktf
3211 DO i = i_start, i_end
3212 vel = rv(i,k,j)
3213 fqy( i, k, jp1 ) = vel*flux4( &
3214 field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
3215 ENDDO
3216 ENDDO
3217
3218 ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary
3219
3220 DO k=kts,ktf
3221 DO i = i_start, i_end
3222 fqy(i, k, jp1) = 0.5*rv(i,k,j)* &
3223 (field(i,k,j)+field(i,k,j-1))
3224 ENDDO
3225 ENDDO
3226
3227 ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary
3228
3229 DO k=kts,ktf
3230 DO i = i_start, i_end
3231 vel = rv(i,k,j)
3232 fqy( i, k, jp1) = vel*flux4( &
3233 field(i,k,j-2),field(i,k,j-1), &
3234 field(i,k,j),field(i,k,j+1),vel )
3235 ENDDO
3236 ENDDO
3237
3238 ENDIF
3239
3240 ! y flux-divergence into tendency
3241
3242 ! Comments on polar boundary conditions
3243 ! Same process as for advect_u - tendencies run from jds to jde-1
3244 ! (latitudes are as for u grid, longitudes are displaced)
3245 ! Therefore: flow is only from one side for points next to poles
3246 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3247 DO k=kts,ktf
3248 DO i = i_start, i_end
3249 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3250 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3251 END DO
3252 END DO
3253 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3254 DO k=kts,ktf
3255 DO i = i_start, i_end
3256 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3257 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3258 END DO
3259 END DO
3260 ELSE ! normal code
3261
3262 IF(j > j_start) THEN
3263
3264 DO k=kts,ktf
3265 DO i = i_start, i_end
3266 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3267 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3268 ENDDO
3269 ENDDO
3270
3271 ENDIF
3272
3273 END IF
3274
3275 jtmp = jp1
3276 jp1 = jp0
3277 jp0 = jtmp
3278
3279 ENDDO j_loop_y_flux_6
3280
3281 ! next, x - flux divergence
3282
3283 i_start = its
3284 i_end = MIN(ite,ide-1)
3285
3286 j_start = jts
3287 j_end = MIN(jte,jde-1)
3288
3289 ! higher order flux has a 5 or 7 point stencil, so compute
3290 ! bounds so we can switch to second order flux close to the boundary
3291
3292 i_start_f = i_start
3293 i_end_f = i_end+1
3294
3295 IF(degrade_xs) then
3296 i_start = MAX(ids+1,its)
3297 i_start_f = i_start+2
3298 ENDIF
3299
3300 IF(degrade_xe) then
3301 i_end = MIN(ide-2,ite)
3302 i_end_f = ide-3
3303 ENDIF
3304
3305 ! compute fluxes
3306
3307 DO j = j_start, j_end
3308
3309 ! 5th or 6th order flux
3310
3311 DO k=kts,ktf
3312 DO i = i_start_f, i_end_f
3313 vel = ru(i,k,j)
3314 fqx( i,k ) = vel*flux6( field(i-3,k,j), field(i-2,k,j), &
3315 field(i-1,k,j), field(i ,k,j), &
3316 field(i+1,k,j), field(i+2,k,j), &
3317 vel )
3318 ENDDO
3319 ENDDO
3320
3321 ! lower order fluxes close to boundaries (if not periodic or symmetric)
3322
3323 IF( degrade_xs ) THEN
3324
3325 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
3326 i = ids+1
3327 DO k=kts,ktf
3328 fqx(i,k) = 0.5*(ru(i,k,j)) &
3329 *(field(i,k,j)+field(i-1,k,j))
3330
3331 ENDDO
3332 ENDIF
3333
3334 i = ids+2
3335 DO k=kts,ktf
3336 vel = ru(i,k,j)
3337 fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), &
3338 field(i ,k,j), field(i+1,k,j), &
3339 vel )
3340 ENDDO
3341
3342 ENDIF
3343
3344 IF( degrade_xe ) THEN
3345
3346 IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
3347 i = ide-1
3348 DO k=kts,ktf
3349 fqx(i,k) = 0.5*(ru(i,k,j)) &
3350 *(field(i,k,j)+field(i-1,k,j))
3351 ENDDO
3352 ENDIF
3353
3354 i = ide-2
3355 DO k=kts,ktf
3356 vel = ru(i,k,j)
3357 fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), &
3358 field(i ,k,j), field(i+1,k,j), &
3359 vel )
3360 ENDDO
3361
3362 ENDIF
3363
3364 ! x flux-divergence into tendency
3365
3366 DO k=kts,ktf
3367 DO i = i_start, i_end
3368 mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3369 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3370 ENDDO
3371 ENDDO
3372
3373 ENDDO
3374
3375 ELSE IF( horz_order == 5 ) THEN
3376
3377 ! determine boundary mods for flux operators
3378 ! We degrade the flux operators from 3rd/4th order
3379 ! to second order one gridpoint in from the boundaries for
3380 ! all boundary conditions except periodic and symmetry - these
3381 ! conditions have boundary zone data fill for correct application
3382 ! of the higher order flux stencils
3383
3384 degrade_xs = .true.
3385 degrade_xe = .true.
3386 degrade_ys = .true.
3387 degrade_ye = .true.
3388
3389 IF( config_flags%periodic_x .or. &
3390 config_flags%symmetric_xs .or. &
3391 (its > ids+2) ) degrade_xs = .false.
3392 IF( config_flags%periodic_x .or. &
3393 config_flags%symmetric_xe .or. &
3394 (ite < ide-3) ) degrade_xe = .false.
3395 IF( config_flags%periodic_y .or. &
3396 config_flags%symmetric_ys .or. &
3397 (jts > jds+2) ) degrade_ys = .false.
3398 IF( config_flags%periodic_y .or. &
3399 config_flags%symmetric_ye .or. &
3400 (jte < jde-3) ) degrade_ye = .false.
3401
3402 !--------------- y - advection first
3403
3404 ktf=MIN(kte,kde-1)
3405 i_start = its
3406 i_end = MIN(ite,ide-1)
3407 j_start = jts
3408 j_end = MIN(jte,jde-1)
3409
3410 ! higher order flux has a 5 or 7 point stencil, so compute
3411 ! bounds so we can switch to second order flux close to the boundary
3412
3413 j_start_f = j_start
3414 j_end_f = j_end+1
3415
3416 IF(degrade_ys) then
3417 j_start = MAX(jts,jds+1)
3418 j_start_f = jds+3
3419 ENDIF
3420
3421 IF(degrade_ye) then
3422 j_end = MIN(jte,jde-2)
3423 j_end_f = jde-3
3424 ENDIF
3425
3426 IF(config_flags%polar) j_end = MIN(jte,jde-1)
3427
3428 ! compute fluxes, 5th or 6th order
3429
3430 jp1 = 2
3431 jp0 = 1
3432
3433 j_loop_y_flux_5 : DO j = j_start, j_end+1
3434
3435 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
3436
3437 DO k=kts,ktf
3438 DO i = i_start, i_end
3439 vel = rv(i,k,j)
3440 fqy( i, k, jp1 ) = vel*flux5( &
3441 field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), &
3442 field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel )
3443 ENDDO
3444 ENDDO
3445
3446 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
3447
3448 DO k=kts,ktf
3449 DO i = i_start, i_end
3450 fqy(i,k, jp1) = 0.5*rv(i,k,j)* &
3451 (field(i,k,j)+field(i,k,j-1))
3452
3453 ENDDO
3454 ENDDO
3455
3456 ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary
3457
3458 DO k=kts,ktf
3459 DO i = i_start, i_end
3460 vel = rv(i,k,j)
3461 fqy( i, k, jp1 ) = vel*flux3( &
3462 field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
3463 ENDDO
3464 ENDDO
3465
3466 ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary
3467
3468 DO k=kts,ktf
3469 DO i = i_start, i_end
3470 fqy(i, k, jp1) = 0.5*rv(i,k,j)* &
3471 (field(i,k,j)+field(i,k,j-1))
3472 ENDDO
3473 ENDDO
3474
3475 ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary
3476
3477 DO k=kts,ktf
3478 DO i = i_start, i_end
3479 vel = rv(i,k,j)
3480 fqy( i, k, jp1) = vel*flux3( &
3481 field(i,k,j-2),field(i,k,j-1), &
3482 field(i,k,j),field(i,k,j+1),vel )
3483 ENDDO
3484 ENDDO
3485
3486 ENDIF
3487
3488 ! y flux-divergence into tendency
3489
3490 ! Comments on polar boundary conditions
3491 ! Same process as for advect_u - tendencies run from jds to jde-1
3492 ! (latitudes are as for u grid, longitudes are displaced)
3493 ! Therefore: flow is only from one side for points next to poles
3494 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3495 DO k=kts,ktf
3496 DO i = i_start, i_end
3497 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3498 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3499 END DO
3500 END DO
3501 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3502 DO k=kts,ktf
3503 DO i = i_start, i_end
3504 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3505 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3506 END DO
3507 END DO
3508 ELSE ! normal code
3509
3510 IF(j > j_start) THEN
3511
3512 DO k=kts,ktf
3513 DO i = i_start, i_end
3514 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3515 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3516 ENDDO
3517 ENDDO
3518
3519 ENDIF
3520
3521 END IF
3522
3523 jtmp = jp1
3524 jp1 = jp0
3525 jp0 = jtmp
3526
3527 ENDDO j_loop_y_flux_5
3528
3529 ! next, x - flux divergence
3530
3531 i_start = its
3532 i_end = MIN(ite,ide-1)
3533
3534 j_start = jts
3535 j_end = MIN(jte,jde-1)
3536
3537 ! higher order flux has a 5 or 7 point stencil, so compute
3538 ! bounds so we can switch to second order flux close to the boundary
3539
3540 i_start_f = i_start
3541 i_end_f = i_end+1
3542
3543 IF(degrade_xs) then
3544 i_start = MAX(ids+1,its)
3545 i_start_f = i_start+2
3546 ENDIF
3547
3548 IF(degrade_xe) then
3549 i_end = MIN(ide-2,ite)
3550 i_end_f = ide-3
3551 ENDIF
3552
3553 ! compute fluxes
3554
3555 DO j = j_start, j_end
3556
3557 ! 5th or 6th order flux
3558
3559 DO k=kts,ktf
3560 DO i = i_start_f, i_end_f
3561 vel = ru(i,k,j)
3562 fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), &
3563 field(i-1,k,j), field(i ,k,j), &
3564 field(i+1,k,j), field(i+2,k,j), &
3565 vel )
3566 ENDDO
3567 ENDDO
3568
3569 ! lower order fluxes close to boundaries (if not periodic or symmetric)
3570
3571 IF( degrade_xs ) THEN
3572
3573 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
3574 i = ids+1
3575 DO k=kts,ktf
3576 fqx(i,k) = 0.5*(ru(i,k,j)) &
3577 *(field(i,k,j)+field(i-1,k,j))
3578
3579 ENDDO
3580 ENDIF
3581
3582 i = ids+2
3583 DO k=kts,ktf
3584 vel = ru(i,k,j)
3585 fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), &
3586 field(i ,k,j), field(i+1,k,j), &
3587 vel )
3588 ENDDO
3589
3590 ENDIF
3591
3592 IF( degrade_xe ) THEN
3593
3594 IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
3595 i = ide-1
3596 DO k=kts,ktf
3597 fqx(i,k) = 0.5*(ru(i,k,j)) &
3598 *(field(i,k,j)+field(i-1,k,j))
3599 ENDDO
3600 ENDIF
3601
3602 i = ide-2
3603 DO k=kts,ktf
3604 vel = ru(i,k,j)
3605 fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), &
3606 field(i ,k,j), field(i+1,k,j), &
3607 vel )
3608 ENDDO
3609
3610 ENDIF
3611
3612 ! x flux-divergence into tendency
3613
3614 DO k=kts,ktf
3615 DO i = i_start, i_end
3616 mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3617 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3618 ENDDO
3619 ENDDO
3620
3621 ENDDO
3622
3623
3624 ELSE IF( horz_order == 4 ) THEN
3625
3626 degrade_xs = .true.
3627 degrade_xe = .true.
3628 degrade_ys = .true.
3629 degrade_ye = .true.
3630
3631 IF( config_flags%periodic_x .or. &
3632 config_flags%symmetric_xs .or. &
3633 (its > ids+1) ) degrade_xs = .false.
3634 IF( config_flags%periodic_x .or. &
3635 config_flags%symmetric_xe .or. &
3636 (ite < ide-2) ) degrade_xe = .false.
3637 IF( config_flags%periodic_y .or. &
3638 config_flags%symmetric_ys .or. &
3639 (jts > jds+1) ) degrade_ys = .false.
3640 IF( config_flags%periodic_y .or. &
3641 config_flags%symmetric_ye .or. &
3642 (jte < jde-2) ) degrade_ye = .false.
3643
3644 ! begin flux computations
3645 ! start with x flux divergence
3646
3647 ktf=MIN(kte,kde-1)
3648
3649 i_start = its
3650 i_end = MIN(ite,ide-1)
3651 j_start = jts
3652 j_end = MIN(jte,jde-1)
3653
3654 ! 3rd or 4th order flux has a 5 point stencil, so compute
3655 ! bounds so we can switch to second order flux close to the boundary
3656
3657 i_start_f = i_start
3658 i_end_f = i_end+1
3659
3660 IF(degrade_xs) then
3661 i_start = ids+1
3662 i_start_f = i_start+1
3663 ENDIF
3664
3665 IF(degrade_xe) then
3666 i_end = ide-2
3667 i_end_f = ide-2
3668 ENDIF
3669
3670 ! compute fluxes
3671
3672 DO j = j_start, j_end
3673
3674 ! 3rd or 4th order flux
3675
3676 DO k=kts,ktf
3677 DO i = i_start_f, i_end_f
3678
3679 fqx( i, k) = ru(i,k,j)*flux4( field(i-2,k,j), field(i-1,k,j), &
3680 field(i ,k,j), field(i+1,k,j), &
3681 ru(i,k,j) )
3682 ENDDO
3683 ENDDO
3684
3685 ! second order flux close to boundaries (if not periodic or symmetric)
3686
3687 IF( degrade_xs ) THEN
3688 DO k=kts,ktf
3689 fqx(i_start, k) = 0.5*ru(i_start,k,j) &
3690 *(field(i_start,k,j)+field(i_start-1,k,j))
3691 ENDDO
3692 ENDIF
3693
3694 IF( degrade_xe ) THEN
3695 DO k=kts,ktf
3696 fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j) &
3697 *(field(i_end+1,k,j)+field(i_end,k,j))
3698 ENDDO
3699 ENDIF
3700
3701 ! x flux-divergence into tendency
3702
3703 DO k=kts,ktf
3704 DO i = i_start, i_end
3705 mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3706 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3707 ENDDO
3708 ENDDO
3709
3710 ENDDO
3711
3712
3713 ! next -> y flux divergence calculation
3714
3715 i_start = its
3716 i_end = MIN(ite,ide-1)
3717 j_start = jts
3718 j_end = MIN(jte,jde-1)
3719
3720 ! 3rd or 4th order flux has a 5 point stencil, so compute
3721 ! bounds so we can switch to second order flux close to the boundary
3722
3723 j_start_f = j_start
3724 j_end_f = j_end+1
3725
3726 IF(degrade_ys) then
3727 j_start = jds+1
3728 j_start_f = j_start+1
3729 ENDIF
3730
3731 IF(degrade_ye) then
3732 j_end = jde-2
3733 j_end_f = jde-2
3734 ENDIF
3735
3736 IF(config_flags%polar) j_end = MIN(jte,jde-1)
3737
3738 jp1 = 2
3739 jp0 = 1
3740
3741 DO j = j_start, j_end+1
3742
3743 IF ((j < j_start_f) .and. degrade_ys) THEN
3744 DO k = kts, ktf
3745 DO i = i_start, i_end
3746 fqy(i,k,jp1) = 0.5*rv(i,k,j_start) &
3747 *(field(i,k,j_start)+field(i,k,j_start-1))
3748 ENDDO
3749 ENDDO
3750 ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
3751 DO k = kts, ktf
3752 DO i = i_start, i_end
3753 ! Assumes j>j_end_f is ONLY j_end+1 ...
3754 ! fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1) &
3755 ! *(field(i,k,j_end+1)+field(i,k,j_end))
3756 fqy(i,k,jp1) = 0.5*rv(i,k,j) &
3757 *(field(i,k,j)+field(i,k,j-1))
3758 ENDDO
3759 ENDDO
3760 ELSE
3761 ! 3rd or 4th order flux
3762 DO k = kts, ktf
3763 DO i = i_start, i_end
3764 fqy( i, k, jp1 ) = rv(i,k,j)*flux4( field(i,k,j-2), field(i,k,j-1), &
3765 field(i,k,j ), field(i,k,j+1), &
3766 rv(i,k,j) )
3767 ENDDO
3768 ENDDO
3769 END IF
3770
3771 ! y flux-divergence into tendency
3772
3773 ! Comments on polar boundary conditions
3774 ! Same process as for advect_u - tendencies run from jds to jde-1
3775 ! (latitudes are as for u grid, longitudes are displaced)
3776 ! Therefore: flow is only from one side for points next to poles
3777 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3778 DO k=kts,ktf
3779 DO i = i_start, i_end
3780 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3781 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3782 END DO
3783 END DO
3784 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3785 DO k=kts,ktf
3786 DO i = i_start, i_end
3787 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3788 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3789 END DO
3790 END DO
3791 ELSE ! normal code
3792
3793 IF ( j > j_start ) THEN
3794
3795 DO k=kts,ktf
3796 DO i = i_start, i_end
3797 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3798 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3799 ENDDO
3800 ENDDO
3801
3802 END IF
3803
3804 END IF
3805
3806 jtmp = jp1
3807 jp1 = jp0
3808 jp0 = jtmp
3809
3810 ENDDO
3811
3812
3813 ELSE IF( horz_order == 3 ) THEN
3814
3815 degrade_xs = .true.
3816 degrade_xe = .true.
3817 degrade_ys = .true.
3818 degrade_ye = .true.
3819
3820 IF( config_flags%periodic_x .or. &
3821 config_flags%symmetric_xs .or. &
3822 (its > ids+1) ) degrade_xs = .false.
3823 IF( config_flags%periodic_x .or. &
3824 config_flags%symmetric_xe .or. &
3825 (ite < ide-2) ) degrade_xe = .false.
3826 IF( config_flags%periodic_y .or. &
3827 config_flags%symmetric_ys .or. &
3828 (jts > jds+1) ) degrade_ys = .false.
3829 IF( config_flags%periodic_y .or. &
3830 config_flags%symmetric_ye .or. &
3831 (jte < jde-2) ) degrade_ye = .false.
3832
3833 ! begin flux computations
3834 ! start with x flux divergence
3835
3836 ktf=MIN(kte,kde-1)
3837
3838 i_start = its
3839 i_end = MIN(ite,ide-1)
3840 j_start = jts
3841 j_end = MIN(jte,jde-1)
3842
3843 ! 3rd or 4th order flux has a 5 point stencil, so compute
3844 ! bounds so we can switch to second order flux close to the boundary
3845
3846 i_start_f = i_start
3847 i_end_f = i_end+1
3848
3849 IF(degrade_xs) then
3850 i_start = ids+1
3851 i_start_f = i_start+1
3852 ENDIF
3853
3854 IF(degrade_xe) then
3855 i_end = ide-2
3856 i_end_f = ide-2
3857 ENDIF
3858
3859 ! compute fluxes
3860
3861 DO j = j_start, j_end
3862
3863 ! 3rd or 4th order flux
3864
3865 DO k=kts,ktf
3866 DO i = i_start_f, i_end_f
3867
3868 fqx( i, k) = ru(i,k,j)*flux3( field(i-2,k,j), field(i-1,k,j), &
3869 field(i ,k,j), field(i+1,k,j), &
3870 ru(i,k,j) )
3871 ENDDO
3872 ENDDO
3873
3874 ! second order flux close to boundaries (if not periodic or symmetric)
3875
3876 IF( degrade_xs ) THEN
3877 DO k=kts,ktf
3878 fqx(i_start, k) = 0.5*ru(i_start,k,j) &
3879 *(field(i_start,k,j)+field(i_start-1,k,j))
3880 ENDDO
3881 ENDIF
3882
3883 IF( degrade_xe ) THEN
3884 DO k=kts,ktf
3885 fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j) &
3886 *(field(i_end+1,k,j)+field(i_end,k,j))
3887 ENDDO
3888 ENDIF
3889
3890 ! x flux-divergence into tendency
3891
3892 DO k=kts,ktf
3893 DO i = i_start, i_end
3894 mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3895 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3896 ENDDO
3897 ENDDO
3898
3899 ENDDO
3900
3901
3902 ! next -> y flux divergence calculation
3903
3904 i_start = its
3905 i_end = MIN(ite,ide-1)
3906 j_start = jts
3907 j_end = MIN(jte,jde-1)
3908
3909 ! 3rd or 4th order flux has a 5 point stencil, so compute
3910 ! bounds so we can switch to second order flux close to the boundary
3911
3912 j_start_f = j_start
3913 j_end_f = j_end+1
3914
3915 IF(degrade_ys) then
3916 j_start = jds+1
3917 j_start_f = j_start+1
3918 ENDIF
3919
3920 IF(degrade_ye) then
3921 j_end = jde-2
3922 j_end_f = jde-2
3923 ENDIF
3924
3925 IF(config_flags%polar) j_end = MIN(jte,jde-1)
3926
3927 jp1 = 2
3928 jp0 = 1
3929
3930 DO j = j_start, j_end+1
3931
3932 IF ((j < j_start_f) .and. degrade_ys) THEN
3933 DO k = kts, ktf
3934 DO i = i_start, i_end
3935 fqy(i,k,jp1) = 0.5*rv(i,k,j_start) &
3936 *(field(i,k,j_start)+field(i,k,j_start-1))
3937 ENDDO
3938 ENDDO
3939 ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
3940 DO k = kts, ktf
3941 DO i = i_start, i_end
3942 ! Assumes j>j_end_f is ONLY j_end+1 ...
3943 ! fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1) &
3944 ! *(field(i,k,j_end+1)+field(i,k,j_end))
3945 fqy(i,k,jp1) = 0.5*rv(i,k,j) &
3946 *(field(i,k,j)+field(i,k,j-1))
3947 ENDDO
3948 ENDDO
3949 ELSE
3950 ! 3rd or 4th order flux
3951 DO k = kts, ktf
3952 DO i = i_start, i_end
3953 fqy( i, k, jp1 ) = rv(i,k,j)*flux3( field(i,k,j-2), field(i,k,j-1), &
3954 field(i,k,j ), field(i,k,j+1), &
3955 rv(i,k,j) )
3956 ENDDO
3957 ENDDO
3958 END IF
3959
3960 ! y flux-divergence into tendency
3961
3962 ! Comments on polar boundary conditions
3963 ! Same process as for advect_u - tendencies run from jds to jde-1
3964 ! (latitudes are as for u grid, longitudes are displaced)
3965 ! Therefore: flow is only from one side for points next to poles
3966 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3967 DO k=kts,ktf
3968 DO i = i_start, i_end
3969 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3970 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3971 END DO
3972 END DO
3973 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3974 DO k=kts,ktf
3975 DO i = i_start, i_end
3976 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3977 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3978 END DO
3979 END DO
3980 ELSE ! normal code
3981
3982 IF ( j > j_start ) THEN
3983
3984 DO k=kts,ktf
3985 DO i = i_start, i_end
3986 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3987 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3988 ENDDO
3989 ENDDO
3990
3991 END IF
3992
3993 END IF
3994
3995 jtmp = jp1
3996 jp1 = jp0
3997 jp0 = jtmp
3998
3999 ENDDO
4000
4001 ELSE IF( horz_order == 2 ) THEN
4002
4003 i_start = its
4004 i_end = MIN(ite,ide-1)
4005 j_start = jts
4006 j_end = MIN(jte,jde-1)
4007
4008 IF ( .NOT. config_flags%periodic_x ) THEN
4009 IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
4010 IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite)
4011 ENDIF
4012
4013 DO j = j_start, j_end
4014 DO k = kts, ktf
4015 DO i = i_start, i_end
4016 mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
4017 tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 &
4018 *(ru(i+1,k,j)*(field(i+1,k,j)+field(i ,k,j)) &
4019 -ru(i ,k,j)*(field(i ,k,j)+field(i-1,k,j)))
4020 ENDDO
4021 ENDDO
4022 ENDDO
4023
4024 i_start = its
4025 i_end = MIN(ite,ide-1)
4026
4027 ! Polar boundary conditions are like open or specified
4028 IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
4029 IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-2,jte)
4030
4031 DO j = j_start, j_end
4032 DO k = kts, ktf
4033 DO i = i_start, i_end
4034 mrdy=msftx(i,j)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4035 tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 &
4036 *(rv(i,k,j+1)*(field(i,k,j+1)+field(i,k,j )) &
4037 -rv(i,k,j )*(field(i,k,j )+field(i,k,j-1)))
4038 ENDDO
4039 ENDDO
4040 ENDDO
4041
4042 ! Polar boundary condtions
4043 ! These won't be covered in the loop above...
4044 IF (config_flags%polar) THEN
4045 IF (jts == jds) THEN
4046 DO k=kts,ktf
4047 DO i = i_start, i_end
4048 mrdy=msftx(i,jds)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4049 tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
4050 *rv(i,k,jds+1)*(field(i,k,jds+1)+field(i,k,jds))
4051 END DO
4052 END DO
4053 END IF
4054 IF (jte == jde) THEN
4055 DO k=kts,ktf
4056 DO i = i_start, i_end
4057 mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4058 tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
4059 *rv(i,k,jde-1)*(field(i,k,jde-1)+field(i,k,jde-2))
4060 END DO
4061 END DO
4062 END IF
4063 END IF
4064
4065 ELSE IF ( horz_order == 0 ) THEN
4066
4067 ! Just in case we want to turn horizontal advection off, we can do it
4068
4069 ELSE
4070
4071 WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_6a, h_order not known ',horz_order
4072 CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
4073
4074 ENDIF horizontal_order_test
4075
4076 ! pick up the rest of the horizontal radiation boundary conditions.
4077 ! (these are the computations that don't require 'cb'.
4078 ! first, set to index ranges
4079
4080 i_start = its
4081 i_end = MIN(ite,ide-1)
4082 j_start = jts
4083 j_end = MIN(jte,jde-1)
4084
4085 ! compute x (u) conditions for v, w, or scalar
4086
4087 IF( (config_flags%open_xs) .and. (its == ids) ) THEN
4088
4089 DO j = j_start, j_end
4090 DO k = kts, ktf
4091 ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
4092 tendency(its,k,j) = tendency(its,k,j) &
4093 - rdx*( &
4094 ub*( field_old(its+1,k,j) &
4095 - field_old(its ,k,j) ) + &
4096 field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j)) &
4097 )
4098 ENDDO
4099 ENDDO
4100
4101 ENDIF
4102
4103 IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
4104
4105 DO j = j_start, j_end
4106 DO k = kts, ktf
4107 ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
4108 tendency(i_end,k,j) = tendency(i_end,k,j) &
4109 - rdx*( &
4110 ub*( field_old(i_end ,k,j) &
4111 - field_old(i_end-1,k,j) ) + &
4112 field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j)) &
4113 )
4114 ENDDO
4115 ENDDO
4116
4117 ENDIF
4118
4119 IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
4120
4121 DO i = i_start, i_end
4122 DO k = kts, ktf
4123 vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
4124 tendency(i,k,jts) = tendency(i,k,jts) &
4125 - rdy*( &
4126 vb*( field_old(i,k,jts+1) &
4127 - field_old(i,k,jts ) ) + &
4128 field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts)) &
4129 )
4130 ENDDO
4131 ENDDO
4132
4133 ENDIF
4134
4135 IF( (config_flags%open_ye) .and. (jte == jde)) THEN
4136
4137 DO i = i_start, i_end
4138 DO k = kts, ktf
4139 vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
4140 tendency(i,k,j_end) = tendency(i,k,j_end) &
4141 - rdy*( &
4142 vb*( field_old(i,k,j_end ) &
4143 - field_old(i,k,j_end-1) ) + &
4144 field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1)) &
4145 )
4146 ENDDO
4147 ENDDO
4148
4149 ENDIF
4150
4151
4152 !-------------------- vertical advection
4153 ! Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
4154 ! Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
4155 ! So we don't need to make a correction for advect_scalar
4156
4157 i_start = its
4158 i_end = MIN(ite,ide-1)
4159 j_start = jts
4160 j_end = MIN(jte,jde-1)
4161
4162 DO i = i_start, i_end
4163 vflux(i,kts)=0.
4164 vflux(i,kte)=0.
4165 ENDDO
4166
4167 vert_order_test : IF (vert_order == 6) THEN
4168
4169 DO j = j_start, j_end
4170
4171 DO k=kts+3,ktf-2
4172 DO i = i_start, i_end
4173 vel=rom(i,k,j)
4174 vflux(i,k) = vel*flux6( &
4175 field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), &
4176 field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel )
4177 ENDDO
4178 ENDDO
4179
4180 DO i = i_start, i_end
4181
4182 k=kts+1
4183 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4184
4185 k = kts+2
4186 vel=rom(i,k,j)
4187 vflux(i,k) = vel*flux4( &
4188 field(i,k-2,j), field(i,k-1,j), &
4189 field(i,k ,j), field(i,k+1,j), -vel )
4190 k = ktf-1
4191 vel=rom(i,k,j)
4192 vflux(i,k) = vel*flux4( &
4193 field(i,k-2,j), field(i,k-1,j), &
4194 field(i,k ,j), field(i,k+1,j), -vel )
4195
4196 k=ktf
4197 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4198 ENDDO
4199
4200 DO k=kts,ktf
4201 DO i = i_start, i_end
4202 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4203 ENDDO
4204 ENDDO
4205
4206 ENDDO
4207
4208 ELSE IF (vert_order == 5) THEN
4209
4210 DO j = j_start, j_end
4211
4212 DO k=kts+3,ktf-2
4213 DO i = i_start, i_end
4214 vel=rom(i,k,j)
4215 vflux(i,k) = vel*flux5( &
4216 field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), &
4217 field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel )
4218 ENDDO
4219 ENDDO
4220
4221 DO i = i_start, i_end
4222
4223 k=kts+1
4224 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4225
4226 k = kts+2
4227 vel=rom(i,k,j)
4228 vflux(i,k) = vel*flux3( &
4229 field(i,k-2,j), field(i,k-1,j), &
4230 field(i,k ,j), field(i,k+1,j), -vel )
4231 k = ktf-1
4232 vel=rom(i,k,j)
4233 vflux(i,k) = vel*flux3( &
4234 field(i,k-2,j), field(i,k-1,j), &
4235 field(i,k ,j), field(i,k+1,j), -vel )
4236
4237 k=ktf
4238 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4239 ENDDO
4240
4241 DO k=kts,ktf
4242 DO i = i_start, i_end
4243 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4244 ENDDO
4245 ENDDO
4246
4247 ENDDO
4248
4249 ELSE IF (vert_order == 4) THEN
4250
4251 DO j = j_start, j_end
4252
4253 DO k=kts+2,ktf-1
4254 DO i = i_start, i_end
4255 vel=rom(i,k,j)
4256 vflux(i,k) = vel*flux4( &
4257 field(i,k-2,j), field(i,k-1,j), &
4258 field(i,k ,j), field(i,k+1,j), -vel )
4259 ENDDO
4260 ENDDO
4261
4262 DO i = i_start, i_end
4263
4264 k=kts+1
4265 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4266 k=ktf
4267 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4268 ENDDO
4269
4270 DO k=kts,ktf
4271 DO i = i_start, i_end
4272 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4273 ENDDO
4274 ENDDO
4275
4276 ENDDO
4277
4278 ELSE IF (vert_order == 3) THEN
4279
4280 DO j = j_start, j_end
4281
4282 DO k=kts+2,ktf-1
4283 DO i = i_start, i_end
4284 vel=rom(i,k,j)
4285 vflux(i,k) = vel*flux3( &
4286 field(i,k-2,j), field(i,k-1,j), &
4287 field(i,k ,j), field(i,k+1,j), -vel )
4288 ENDDO
4289 ENDDO
4290
4291 DO i = i_start, i_end
4292
4293 k=kts+1
4294 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4295 k=ktf
4296 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4297 ENDDO
4298
4299 DO k=kts,ktf
4300 DO i = i_start, i_end
4301 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4302 ENDDO
4303 ENDDO
4304
4305 ENDDO
4306
4307
4308 ELSE IF (vert_order == 2) THEN
4309
4310 DO j = j_start, j_end
4311 DO k = kts+1, ktf
4312 DO i = i_start, i_end
4313 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4314 ENDDO
4315 ENDDO
4316
4317 DO k = kts, ktf
4318 DO i = i_start, i_end
4319 tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4320 ENDDO
4321 ENDDO
4322
4323 ENDDO
4324
4325 ELSE
4326
4327 WRITE (wrf_err_message,*) ' advect_scalar_6a, v_order not known ',vert_order
4328 CALL wrf_error_fatal ( wrf_err_message )
4329
4330 ENDIF vert_order_test
4331
4332 END SUBROUTINE advect_scalar
4333
4334 !---------------------------------------------------------------------------------
4335
4336 SUBROUTINE advect_w ( w, w_old, tendency, &
4337 ru, rv, rom, &
4338 mut, config_flags, &
4339 msfux, msfuy, msfvx, msfvy, &
4340 msftx, msfty, &
4341 fzm, fzp, &
4342 rdx, rdy, rdzu, &
4343 ids, ide, jds, jde, kds, kde, &
4344 ims, ime, jms, jme, kms, kme, &
4345 its, ite, jts, jte, kts, kte )
4346
4347 IMPLICIT NONE
4348
4349 ! Input data
4350
4351 TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
4352
4353 INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
4354 ims, ime, jms, jme, kms, kme, &
4355 its, ite, jts, jte, kts, kte
4356
4357 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: w, &
4358 w_old, &
4359 ru, &
4360 rv, &
4361 rom
4362
4363 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut
4364 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
4365
4366 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, &
4367 msfuy, &
4368 msfvx, &
4369 msfvy, &
4370 msftx, &
4371 msfty
4372
4373 REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, &
4374 fzp, &
4375 rdzu
4376
4377 REAL , INTENT(IN ) :: rdx, &
4378 rdy
4379
4380 ! Local data
4381
4382 INTEGER :: i, j, k, itf, jtf, ktf
4383 INTEGER :: i_start, i_end, j_start, j_end
4384 INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
4385 INTEGER :: jmin, jmax, jp, jm, imin, imax
4386
4387 REAL :: mrdx, mrdy, ub, vb, uw, vw
4388 REAL , DIMENSION(its:ite, kts:kte) :: vflux
4389
4390 INTEGER :: horz_order, vert_order
4391
4392 REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx
4393 REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy
4394
4395 LOGICAL :: degrade_xs, degrade_ys
4396 LOGICAL :: degrade_xe, degrade_ye
4397
4398 INTEGER :: jp1, jp0, jtmp
4399
4400 ! definition of flux operators, 3rd, 4th, 5th or 6th order
4401
4402 REAL :: flux3, flux4, flux5, flux6
4403 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
4404
4405 flux4(q_im2, q_im1, q_i, q_ip1, ua) = &
4406 ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
4407
4408 flux3(q_im2, q_im1, q_i, q_ip1, ua) = &
4409 flux4(q_im2, q_im1, q_i, q_ip1, ua) + &
4410 sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
4411
4412 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = &
4413 ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) &
4414 +(q_ip2+q_im3) )/60.0
4415
4416 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = &
4417 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) &
4418 -sign(1.,ua)*( &
4419 (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
4420
4421
4422 LOGICAL :: specified
4423
4424 specified = .false.
4425 if(config_flags%specified .or. config_flags%nested) specified = .true.
4426
4427 ! set order for the advection scheme
4428
4429 ktf=MIN(kte,kde-1)
4430 horz_order = config_flags%h_sca_adv_order
4431 vert_order = config_flags%v_sca_adv_order
4432
4433 ! here is the choice of flux operators
4434
4435 ! begin with horizontal flux divergence
4436
4437 horizontal_order_test : IF( horz_order == 6 ) THEN
4438
4439 ! determine boundary mods for flux operators
4440 ! We degrade the flux operators from 3rd/4th order
4441 ! to second order one gridpoint in from the boundaries for
4442 ! all boundary conditions except periodic and symmetry - these
4443 ! conditions have boundary zone data fill for correct application
4444 ! of the higher order flux stencils
4445
4446 degrade_xs = .true.
4447 degrade_xe = .true.
4448 degrade_ys = .true.
4449 degrade_ye = .true.
4450
4451 IF( config_flags%periodic_x .or. &
4452 config_flags%symmetric_xs .or. &
4453 (its > ids+2) ) degrade_xs = .false.
4454 IF( config_flags%periodic_x .or. &
4455 config_flags%symmetric_xe .or. &
4456 (ite < ide-3) ) degrade_xe = .false.
4457 IF( config_flags%periodic_y .or. &
4458 config_flags%symmetric_ys .or. &
4459 (jts > jds+2) ) degrade_ys = .false.
4460 IF( config_flags%periodic_y .or. &
4461 config_flags%symmetric_ye .or. &
4462 (jte < jde-3) ) degrade_ye = .false.
4463
4464 !--------------- y - advection first
4465
4466 i_start = its
4467 i_end = MIN(ite,ide-1)
4468 j_start = jts
4469 j_end = MIN(jte,jde-1)
4470
4471 ! higher order flux has a 5 or 7 point stencil, so compute
4472 ! bounds so we can switch to second order flux close to the boundary
4473
4474 j_start_f = j_start
4475 j_end_f = j_end+1
4476
4477 IF(degrade_ys) then
4478 j_start = MAX(jts,jds+1)
4479 j_start_f = jds+3
4480 ENDIF
4481
4482 IF(degrade_ye) then
4483 j_end = MIN(jte,jde-2)
4484 j_end_f = jde-3
4485 ENDIF
4486
4487 IF(config_flags%polar) j_end = MIN(jte,jde-1)
4488
4489 ! compute fluxes, 5th or 6th order
4490
4491 jp1 = 2
4492 jp0 = 1
4493
4494 j_loop_y_flux_6 : DO j = j_start, j_end+1
4495
4496 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
4497
4498 DO k=kts+1,ktf
4499 DO i = i_start, i_end
4500 vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4501 fqy( i, k, jp1 ) = vel*flux6( &
4502 w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), &
4503 w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel )
4504 ENDDO
4505 ENDDO
4506
4507 k = ktf+1
4508 DO i = i_start, i_end
4509 vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4510 fqy( i, k, jp1 ) = vel*flux6( &
4511 w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), &
4512 w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel )
4513 ENDDO
4514
4515 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
4516
4517 DO k=kts+1,ktf
4518 DO i = i_start, i_end
4519 fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* &
4520 (w(i,k,j)+w(i,k,j-1))
4521 ENDDO
4522 ENDDO
4523
4524 k = ktf+1
4525 DO i = i_start, i_end
4526 fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* &
4527 (w(i,k,j)+w(i,k,j-1))
4528 ENDDO
4529
4530 ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary
4531
4532 DO k=kts+1,ktf
4533 DO i = i_start, i_end
4534 vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4535 fqy( i, k, jp1 ) = vel*flux4( &
4536 w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4537 ENDDO
4538 ENDDO
4539
4540 k = ktf+1
4541 DO i = i_start, i_end
4542 vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4543 fqy( i, k, jp1 ) = vel*flux4( &
4544 w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4545 ENDDO
4546
4547 ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary
4548
4549 DO k=kts+1,ktf
4550 DO i = i_start, i_end
4551 fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* &
4552 (w(i,k,j)+w(i,k,j-1))
4553 ENDDO
4554 ENDDO
4555
4556 k = ktf+1
4557 DO i = i_start, i_end
4558 fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* &
4559 (w(i,k,j)+w(i,k,j-1))
4560 ENDDO
4561
4562 ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary
4563
4564 DO k=kts+1,ktf
4565 DO i = i_start, i_end
4566 vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4567 fqy( i, k, jp1 ) = vel*flux4( &
4568 w(i,k,j-2),w(i,k,j-1), &
4569 w(i,k,j),w(i,k,j+1),vel )
4570 ENDDO
4571 ENDDO
4572
4573 k = ktf+1
4574 DO i = i_start, i_end
4575 vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4576 fqy( i, k, jp1 ) = vel*flux4( &
4577 w(i,k,j-2),w(i,k,j-1), &
4578 w(i,k,j),w(i,k,j+1),vel )
4579 ENDDO
4580
4581 ENDIF
4582
4583 ! y flux-divergence into tendency
4584
4585 ! Comments for polar boundary conditions
4586 ! Same process as for advect_u - tendencies run from jds to jde-1
4587 ! (latitudes are as for u grid, longitudes are displaced)
4588 ! Therefore: flow is only from one side for points next to poles
4589 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
4590 DO k=kts,ktf
4591 DO i = i_start, i_end
4592 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
4593 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
4594 ENDDO
4595 ENDDO
4596 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
4597 DO k=kts,ktf
4598 DO i = i_start, i_end
4599 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
4600 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
4601 END DO
4602 END DO
4603 ELSE ! normal code
4604
4605 IF(j > j_start) THEN
4606
4607 DO k=kts+1,ktf+1
4608 DO i = i_start, i_end
4609 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
4610 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
4611 ENDDO
4612 ENDDO
4613
4614 ENDIF
4615
4616 ENDIF
4617
4618 jtmp = jp1
4619 jp1 = jp0
4620 jp0 = jtmp
4621
4622 ENDDO j_loop_y_flux_6
4623
4624 ! next, x - flux divergence
4625
4626 i_start = its
4627 i_end = MIN(ite,ide-1)
4628
4629 j_start = jts
4630 j_end = MIN(jte,jde-1)
4631
4632 ! higher order flux has a 5 or 7 point stencil, so compute
4633 ! bounds so we can switch to second order flux close to the boundary
4634
4635 i_start_f = i_start
4636 i_end_f = i_end+1
4637
4638 IF(degrade_xs) then
4639 i_start = MAX(ids+1,its)
4640 i_start_f = i_start+2
4641 ENDIF
4642
4643 IF(degrade_xe) then
4644 i_end = MIN(ide-2,ite)
4645 i_end_f = ide-3
4646 ENDIF
4647
4648 ! compute fluxes
4649
4650 DO j = j_start, j_end
4651
4652 ! 5th or 6th order flux
4653
4654 DO k=kts+1,ktf
4655 DO i = i_start_f, i_end_f
4656 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4657 fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j), &
4658 w(i-1,k,j), w(i ,k,j), &
4659 w(i+1,k,j), w(i+2,k,j), &
4660 vel )
4661 ENDDO
4662 ENDDO
4663
4664 k = ktf+1
4665 DO i = i_start_f, i_end_f
4666 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4667 fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j), &
4668 w(i-1,k,j), w(i ,k,j), &
4669 w(i+1,k,j), w(i+2,k,j), &
4670 vel )
4671 ENDDO
4672
4673 ! lower order fluxes close to boundaries (if not periodic or symmetric)
4674
4675 IF( degrade_xs ) THEN
4676
4677 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
4678 i = ids+1
4679 DO k=kts+1,ktf
4680 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
4681 *(w(i,k,j)+w(i-1,k,j))
4682 ENDDO
4683 k = ktf+1
4684 fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
4685 *(w(i,k,j)+w(i-1,k,j))
4686 ENDIF
4687
4688 DO k=kts+1,ktf
4689 i = i_start+1
4690 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4691 fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), &
4692 w(i ,k,j), w(i+1,k,j), &
4693 vel )
4694 ENDDO
4695
4696 k = ktf+1
4697 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4698 fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), &
4699 w(i ,k,j), w(i+1,k,j), &
4700 vel )
4701 ENDIF
4702
4703 IF( degrade_xe ) THEN
4704
4705 IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
4706 i = ide-1
4707 DO k=kts+1,ktf
4708 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
4709 *(w(i,k,j)+w(i-1,k,j))
4710 ENDDO
4711 k = ktf+1
4712 fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
4713 *(w(i,k,j)+w(i-1,k,j))
4714 ENDIF
4715
4716 i = ide-2
4717 DO k=kts+1,ktf
4718 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4719 fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), &
4720 w(i ,k,j), w(i+1,k,j), &
4721 vel )
4722 ENDDO
4723
4724 k = ktf+1
4725 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4726 fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), &
4727 w(i ,k,j), w(i+1,k,j), &
4728 vel )
4729 ENDIF
4730
4731 ! x flux-divergence into tendency
4732
4733 DO k=kts+1,ktf+1
4734 DO i = i_start, i_end
4735 mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS
4736 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
4737 ENDDO
4738 ENDDO
4739
4740 ENDDO
4741
4742
4743 ELSE IF (horz_order == 5 ) THEN
4744
4745 ! determine boundary mods for flux operators
4746 ! We degrade the flux operators from 3rd/4th order
4747 ! to second order one gridpoint in from the boundaries for
4748 ! all boundary conditions except periodic and symmetry - these
4749 ! conditions have boundary zone data fill for correct application
4750 ! of the higher order flux stencils
4751
4752 degrade_xs = .true.
4753 degrade_xe = .true.
4754 degrade_ys = .true.
4755 degrade_ye = .true.
4756
4757 IF( config_flags%periodic_x .or. &
4758 config_flags%symmetric_xs .or. &
4759 (its > ids+2) ) degrade_xs = .false.
4760 IF( config_flags%periodic_x .or. &
4761 config_flags%symmetric_xe .or. &
4762 (ite < ide-3) ) degrade_xe = .false.
4763 IF( config_flags%periodic_y .or. &
4764 config_flags%symmetric_ys .or. &
4765 (jts > jds+2) ) degrade_ys = .false.
4766 IF( config_flags%periodic_y .or. &
4767 config_flags%symmetric_ye .or. &
4768 (jte < jde-3) ) degrade_ye = .false.
4769
4770 !--------------- y - advection first
4771
4772 i_start = its
4773 i_end = MIN(ite,ide-1)
4774 j_start = jts
4775 j_end = MIN(jte,jde-1)
4776
4777 ! higher order flux has a 5 or 7 point stencil, so compute
4778 ! bounds so we can switch to second order flux close to the boundary
4779
4780 j_start_f = j_start
4781 j_end_f = j_end+1
4782
4783 IF(degrade_ys) then
4784 j_start = MAX(jts,jds+1)
4785 j_start_f = jds+3
4786 ENDIF
4787
4788 IF(degrade_ye) then
4789 j_end = MIN(jte,jde-2)
4790 j_end_f = jde-3
4791 ENDIF
4792
4793 IF(config_flags%polar) j_end = MIN(jte,jde-1)
4794
4795 ! compute fluxes, 5th or 6th order
4796
4797 jp1 = 2
4798 jp0 = 1
4799
4800 j_loop_y_flux_5 : DO j = j_start, j_end+1
4801
4802 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
4803
4804 DO k=kts+1,ktf
4805 DO i = i_start, i_end
4806 vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4807 fqy( i, k, jp1 ) = vel*flux5( &
4808 w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), &
4809 w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel )
4810 ENDDO
4811 ENDDO
4812
4813 k = ktf+1
4814 DO i = i_start, i_end
4815 vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4816 fqy( i, k, jp1 ) = vel*flux5( &
4817 w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), &
4818 w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel )
4819 ENDDO
4820
4821 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
4822
4823 DO k=kts+1,ktf
4824 DO i = i_start, i_end
4825 fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* &
4826 (w(i,k,j)+w(i,k,j-1))
4827 ENDDO
4828 ENDDO
4829
4830 k = ktf+1
4831 DO i = i_start, i_end
4832 fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* &
4833 (w(i,k,j)+w(i,k,j-1))
4834 ENDDO
4835
4836 ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary
4837
4838 DO k=kts+1,ktf
4839 DO i = i_start, i_end
4840 vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4841 fqy( i, k, jp1 ) = vel*flux3( &
4842 w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4843 ENDDO
4844 ENDDO
4845
4846 k = ktf+1
4847 DO i = i_start, i_end
4848 vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4849 fqy( i, k, jp1 ) = vel*flux3( &
4850 w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4851 ENDDO
4852
4853 ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary
4854
4855 DO k=kts+1,ktf
4856 DO i = i_start, i_end
4857 fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* &
4858 (w(i,k,j)+w(i,k,j-1))
4859 ENDDO
4860 ENDDO
4861
4862 k = ktf+1
4863 DO i = i_start, i_end
4864 fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* &
4865 (w(i,k,j)+w(i,k,j-1))
4866 ENDDO
4867
4868 ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary
4869
4870 DO k=kts+1,ktf
4871 DO i = i_start, i_end
4872 vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4873 fqy( i, k, jp1 ) = vel*flux3( &
4874 w(i,k,j-2),w(i,k,j-1), &
4875 w(i,k,j),w(i,k,j+1),vel )
4876 ENDDO
4877 ENDDO
4878
4879 k = ktf+1
4880 DO i = i_start, i_end
4881 vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4882 fqy( i, k, jp1 ) = vel*flux3( &
4883 w(i,k,j-2),w(i,k,j-1), &
4884 w(i,k,j),w(i,k,j+1),vel )
4885 ENDDO
4886
4887 ENDIF
4888
4889 ! y flux-divergence into tendency
4890
4891 ! Comments for polar boundary conditions
4892 ! Same process as for advect_u - tendencies run from jds to jde-1
4893 ! (latitudes are as for u grid, longitudes are displaced)
4894 ! Therefore: flow is only from one side for points next to poles
4895 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
4896 DO k=kts,ktf
4897 DO i = i_start, i_end
4898 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
4899 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
4900 END DO
4901 END DO
4902 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
4903 DO k=kts,ktf
4904 DO i = i_start, i_end
4905 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
4906 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
4907 END DO
4908 END DO
4909 ELSE ! normal code
4910
4911 IF(j > j_start) THEN
4912
4913 DO k=kts+1,ktf+1
4914 DO i = i_start, i_end
4915 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
4916 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
4917 ENDDO
4918 ENDDO
4919
4920 ENDIF
4921
4922 END IF
4923
4924 jtmp = jp1
4925 jp1 = jp0
4926 jp0 = jtmp
4927
4928 ENDDO j_loop_y_flux_5
4929
4930 ! next, x - flux divergence
4931
4932 i_start = its
4933 i_end = MIN(ite,ide-1)
4934
4935 j_start = jts
4936 j_end = MIN(jte,jde-1)
4937
4938 ! higher order flux has a 5 or 7 point stencil, so compute
4939 ! bounds so we can switch to second order flux close to the boundary
4940
4941 i_start_f = i_start
4942 i_end_f = i_end+1
4943
4944 IF(degrade_xs) then
4945 i_start = MAX(ids+1,its)
4946 i_start_f = i_start+2
4947 ENDIF
4948
4949 IF(degrade_xe) then
4950 i_end = MIN(ide-2,ite)
4951 i_end_f = ide-3
4952 ENDIF
4953
4954 ! compute fluxes
4955
4956 DO j = j_start, j_end
4957
4958 ! 5th or 6th order flux
4959
4960 DO k=kts+1,ktf
4961 DO i = i_start_f, i_end_f
4962 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4963 fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), &
4964 w(i-1,k,j), w(i ,k,j), &
4965 w(i+1,k,j), w(i+2,k,j), &
4966 vel )
4967 ENDDO
4968 ENDDO
4969
4970 k = ktf+1
4971 DO i = i_start_f, i_end_f
4972 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4973 fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), &
4974 w(i-1,k,j), w(i ,k,j), &
4975 w(i+1,k,j), w(i+2,k,j), &
4976 vel )
4977 ENDDO
4978
4979 ! lower order fluxes close to boundaries (if not periodic or symmetric)
4980
4981 IF( degrade_xs ) THEN
4982
4983 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
4984 i = ids+1
4985 DO k=kts+1,ktf
4986 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
4987 *(w(i,k,j)+w(i-1,k,j))
4988 ENDDO
4989 k = ktf+1
4990 fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
4991 *(w(i,k,j)+w(i-1,k,j))
4992 ENDIF
4993
4994 i = i_start+1
4995 DO k=kts+1,ktf
4996 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4997 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), &
4998 w(i ,k,j), w(i+1,k,j), &
4999 vel )
5000 ENDDO
5001 k = ktf+1
5002 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5003 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), &
5004 w(i ,k,j), w(i+1,k,j), &
5005 vel )
5006
5007 ENDIF
5008
5009 IF( degrade_xe ) THEN
5010
5011 IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
5012 i = ide-1
5013 DO k=kts+1,ktf
5014 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
5015 *(w(i,k,j)+w(i-1,k,j))
5016 ENDDO
5017 k = ktf+1
5018 fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
5019 *(w(i,k,j)+w(i-1,k,j))
5020 ENDIF
5021
5022 i = ide-2
5023 DO k=kts+1,ktf
5024 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5025 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), &
5026 w(i ,k,j), w(i+1,k,j), &
5027 vel )
5028 ENDDO
5029 k = ktf+1
5030 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5031 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), &
5032 w(i ,k,j), w(i+1,k,j), &
5033 vel )
5034 ENDIF
5035
5036 ! x flux-divergence into tendency
5037
5038 DO k=kts+1,ktf+1
5039 DO i = i_start, i_end
5040 mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS
5041 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5042 ENDDO
5043 ENDDO
5044
5045 ENDDO
5046
5047 ELSE IF ( horz_order == 4 ) THEN
5048
5049 degrade_xs = .true.
5050 degrade_xe = .true.
5051 degrade_ys = .true.
5052 degrade_ye = .true.
5053
5054 IF( config_flags%periodic_x .or. &
5055 config_flags%symmetric_xs .or. &
5056 (its > ids+1) ) degrade_xs = .false.
5057 IF( config_flags%periodic_x .or. &
5058 config_flags%symmetric_xe .or. &
5059 (ite < ide-2) ) degrade_xe = .false.
5060 IF( config_flags%periodic_y .or. &
5061 config_flags%symmetric_ys .or. &
5062 (jts > jds+1) ) degrade_ys = .false.
5063 IF( config_flags%periodic_y .or. &
5064 config_flags%symmetric_ye .or. &
5065 (jte < jde-2) ) degrade_ye = .false.
5066
5067 ! begin flux computations
5068 ! start with x flux divergence
5069
5070 !---------------
5071
5072 ktf=MIN(kte,kde-1)
5073
5074 i_start = its
5075 i_end = MIN(ite,ide-1)
5076 j_start = jts
5077 j_end = MIN(jte,jde-1)
5078
5079 ! 3rd or 4th order flux has a 5 point stencil, so compute
5080 ! bounds so we can switch to second order flux close to the boundary
5081
5082 i_start_f = i_start
5083 i_end_f = i_end+1
5084
5085 IF(degrade_xs) then
5086 i_start = ids+1
5087 i_start_f = i_start+1
5088 ENDIF
5089
5090 IF(degrade_xe) then
5091 i_end = ide-2
5092 i_end_f = ide-2
5093 ENDIF
5094
5095 ! compute fluxes
5096
5097 DO j = j_start, j_end
5098
5099 DO k=kts+1,ktf
5100 DO i = i_start_f, i_end_f
5101 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5102 fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), &
5103 w(i ,k,j), w(i+1,k,j), &
5104 vel )
5105 ENDDO
5106 ENDDO
5107
5108 k = ktf+1
5109 DO i = i_start_f, i_end_f
5110 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5111 fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), &
5112 w(i ,k,j), w(i+1,k,j), &
5113 vel )
5114 ENDDO
5115 ! second order flux close to boundaries (if not periodic or symmetric)
5116
5117 IF( degrade_xs ) THEN
5118 DO k=kts+1,ktf
5119 fqx(i_start, k) = &
5120 0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j)) &
5121 *(w(i_start,k,j)+w(i_start-1,k,j))
5122 ENDDO
5123 k = ktf+1
5124 fqx(i_start, k) = &
5125 0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j)) &
5126 *(w(i_start,k,j)+w(i_start-1,k,j))
5127 ENDIF
5128
5129 IF( degrade_xe ) THEN
5130 DO k=kts+1,ktf
5131 fqx(i_end+1, k) = &
5132 0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j)) &
5133 *(w(i_end+1,k,j)+w(i_end,k,j))
5134 ENDDO
5135 k = ktf+1
5136 fqx(i_end+1, k) = &
5137 0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j)) &
5138 *(w(i_end+1,k,j)+w(i_end,k,j))
5139 ENDIF
5140
5141 ! x flux-divergence into tendency
5142
5143 DO k=kts+1,ktf+1
5144 DO i = i_start, i_end
5145 mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS
5146 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5147 ENDDO
5148 ENDDO
5149
5150 ENDDO
5151
5152 ! next -> y flux divergence calculation
5153
5154 i_start = its
5155 i_end = MIN(ite,ide-1)
5156 j_start = jts
5157 j_end = MIN(jte,jde-1)
5158
5159
5160 ! 3rd or 4th order flux has a 5 point stencil, so compute
5161 ! bounds so we can switch to second order flux close to the boundary
5162
5163 j_start_f = j_start
5164 j_end_f = j_end+1
5165
5166 IF(degrade_ys) then
5167 j_start = jds+1
5168 j_start_f = j_start+1
5169 ENDIF
5170
5171 IF(degrade_ye) then
5172 j_end = jde-2
5173 j_end_f = jde-2
5174 ENDIF
5175
5176 IF(config_flags%polar) j_end = MIN(jte,jde-1)
5177
5178 jp1 = 2
5179 jp0 = 1
5180
5181 DO j = j_start, j_end+1
5182
5183 IF ((j < j_start_f) .and. degrade_ys) THEN
5184 DO k = kts+1, ktf
5185 DO i = i_start, i_end
5186 fqy(i, k, jp1) = &
5187 0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start)) &
5188 *(w(i,k,j_start)+w(i,k,j_start-1))
5189 ENDDO
5190 ENDDO
5191 k = ktf+1
5192 DO i = i_start, i_end
5193 fqy(i, k, jp1) = &
5194 0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start)) &
5195 *(w(i,k,j_start)+w(i,k,j_start-1))
5196 ENDDO
5197 ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
5198 DO k = kts+1, ktf
5199 DO i = i_start, i_end
5200 ! Assumes j>j_end_f is ONLY j_end+1 ...
5201 ! fqy(i, k, jp1) = &
5202 ! 0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1)) &
5203 ! *(w(i,k,j_end+1)+w(i,k,j_end))
5204 fqy(i, k, jp1) = &
5205 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)) &
5206 *(w(i,k,j)+w(i,k,j-1))
5207 ENDDO
5208 ENDDO
5209 k = ktf+1
5210 DO i = i_start, i_end
5211 ! Assumes j>j_end_f is ONLY j_end+1 ...
5212 ! fqy(i, k, jp1) = &
5213 ! 0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1)) &
5214 ! *(w(i,k,j_end+1)+w(i,k,j_end))
5215 fqy(i, k, jp1) = &
5216 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)) &
5217 *(w(i,k,j)+w(i,k,j-1))
5218 ENDDO
5219 ELSE
5220 ! 3rd or 4th order flux
5221 DO k = kts+1, ktf
5222 DO i = i_start, i_end
5223 vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
5224 fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1), &
5225 w(i,k,j ), w(i,k,j+1), &
5226 vel )
5227 ENDDO
5228 ENDDO
5229 k = ktf+1
5230 DO i = i_start, i_end
5231 vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
5232 fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1), &
5233 w(i,k,j ), w(i,k,j+1), &
5234 vel )
5235 ENDDO
5236 END IF
5237
5238 ! y flux-divergence into tendency
5239
5240 ! Comments for polar boundary conditions
5241 ! Same process as for advect_u - tendencies run from jds to jde-1
5242 ! (latitudes are as for u grid, longitudes are displaced)
5243 ! Therefore: flow is only from one side for points next to poles
5244 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
5245 DO k=kts,ktf
5246 DO i = i_start, i_end
5247 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5248 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
5249 END DO
5250 END DO
5251 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
5252 DO k=kts,ktf
5253 DO i = i_start, i_end
5254 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5255 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
5256 END DO
5257 END DO
5258 ELSE ! normal code
5259
5260 IF( j > j_start ) THEN
5261
5262 DO k = kts+1, ktf+1
5263 DO i = i_start, i_end
5264 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5265 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
5266 ENDDO
5267 ENDDO
5268
5269 END IF
5270
5271 END IF
5272
5273 jtmp = jp1
5274 jp1 = jp0
5275 jp0 = jtmp
5276
5277 ENDDO
5278
5279 ELSE IF ( horz_order == 3 ) THEN
5280
5281 degrade_xs = .true.
5282 degrade_xe = .true.
5283 degrade_ys = .true.
5284 degrade_ye = .true.
5285
5286 IF( config_flags%periodic_x .or. &
5287 config_flags%symmetric_xs .or. &
5288 (its > ids+1) ) degrade_xs = .false.
5289 IF( config_flags%periodic_x .or. &
5290 config_flags%symmetric_xe .or. &
5291 (ite < ide-2) ) degrade_xe = .false.
5292 IF( config_flags%periodic_y .or. &
5293 config_flags%symmetric_ys .or. &
5294 (jts > jds+1) ) degrade_ys = .false.
5295 IF( config_flags%periodic_y .or. &
5296 config_flags%symmetric_ye .or. &
5297 (jte < jde-2) ) degrade_ye = .false.
5298
5299 ! begin flux computations
5300 ! start with x flux divergence
5301
5302 !---------------
5303
5304 ktf=MIN(kte,kde-1)
5305
5306 i_start = its
5307 i_end = MIN(ite,ide-1)
5308 j_start = jts
5309 j_end = MIN(jte,jde-1)
5310
5311 ! 3rd or 4th order flux has a 5 point stencil, so compute
5312 ! bounds so we can switch to second order flux close to the boundary
5313
5314 i_start_f = i_start
5315 i_end_f = i_end+1
5316
5317 IF(degrade_xs) then
5318 i_start = ids+1
5319 i_start_f = i_start+1
5320 ENDIF
5321
5322 IF(degrade_xe) then
5323 i_end = ide-2
5324 i_end_f = ide-2
5325 ENDIF
5326
5327 ! compute fluxes
5328
5329 DO j = j_start, j_end
5330
5331 DO k=kts+1,ktf
5332 DO i = i_start_f, i_end_f
5333 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5334 fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), &
5335 w(i ,k,j), w(i+1,k,j), &
5336 vel )
5337 ENDDO
5338 ENDDO
5339 k = ktf+1
5340 DO i = i_start_f, i_end_f
5341 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5342 fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), &
5343 w(i ,k,j), w(i+1,k,j), &
5344 vel )
5345 ENDDO
5346
5347 ! second order flux close to boundaries (if not periodic or symmetric)
5348
5349 IF( degrade_xs ) THEN
5350 DO k=kts+1,ktf
5351 fqx(i_start, k) = &
5352 0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j)) &
5353 *(w(i_start,k,j)+w(i_start-1,k,j))
5354 ENDDO
5355 k = ktf+1
5356 fqx(i_start, k) = &
5357 0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j)) &
5358 *(w(i_start,k,j)+w(i_start-1,k,j))
5359 ENDIF
5360
5361 IF( degrade_xe ) THEN
5362 DO k=kts+1,ktf
5363 fqx(i_end+1, k) = &
5364 0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j)) &
5365 *(w(i_end+1,k,j)+w(i_end,k,j))
5366 ENDDO
5367 k = ktf+1
5368 fqx(i_end+1, k) = &
5369 0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j)) &
5370 *(w(i_end+1,k,j)+w(i_end,k,j))
5371 ENDIF
5372
5373 ! x flux-divergence into tendency
5374
5375 DO k=kts+1,ktf+1
5376 DO i = i_start, i_end
5377 mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS
5378 tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5379 ENDDO
5380 ENDDO
5381
5382 ENDDO
5383
5384 ! next -> y flux divergence calculation
5385
5386 i_start = its
5387 i_end = MIN(ite,ide-1)
5388 j_start = jts
5389 j_end = MIN(jte,jde-1)
5390
5391
5392 ! 3rd or 4th order flux has a 5 point stencil, so compute
5393 ! bounds so we can switch to second order flux close to the boundary
5394
5395 j_start_f = j_start
5396 j_end_f = j_end+1
5397
5398 IF(degrade_ys) then
5399 j_start = jds+1
5400 j_start_f = j_start+1
5401 ENDIF
5402
5403 IF(degrade_ye) then
5404 j_end = jde-2
5405 j_end_f = jde-2
5406 ENDIF
5407
5408 IF(config_flags%polar) j_end = MIN(jte,jde-1)
5409
5410 jp1 = 2
5411 jp0 = 1
5412
5413 DO j = j_start, j_end+1
5414
5415 IF ((j < j_start_f) .and. degrade_ys) THEN
5416 DO k = kts+1, ktf
5417 DO i = i_start, i_end
5418 fqy(i, k, jp1) = &
5419 0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start)) &
5420 *(w(i,k,j_start)+w(i,k,j_start-1))
5421 ENDDO
5422 ENDDO
5423 k = ktf+1
5424 DO i = i_start, i_end
5425 fqy(i, k, jp1) = &
5426 0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start)) &
5427 *(w(i,k,j_start)+w(i,k,j_start-1))
5428 ENDDO
5429 ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
5430 DO k = kts+1, ktf
5431 DO i = i_start, i_end
5432 ! Assumes j>j_end_f is ONLY j_end+1 ...
5433 ! fqy(i, k, jp1) = &
5434 ! 0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1)) &
5435 ! *(w(i,k,j_end+1)+w(i,k,j_end))
5436 fqy(i, k, jp1) = &
5437 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)) &
5438 *(w(i,k,j)+w(i,k,j-1))
5439 ENDDO
5440 ENDDO
5441 k = ktf+1
5442 DO i = i_start, i_end
5443 ! Assumes j>j_end_f is ONLY j_end+1 ...
5444 ! fqy(i, k, jp1) = &
5445 ! 0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1)) &
5446 ! *(w(i,k,j_end+1)+w(i,k,j_end))
5447 fqy(i, k, jp1) = &
5448 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)) &
5449 *(w(i,k,j)+w(i,k,j-1))
5450 ENDDO
5451 ELSE
5452 ! 3rd or 4th order flux
5453 DO k = kts+1, ktf
5454 DO i = i_start, i_end
5455 vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
5456 fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1), &
5457 w(i,k,j ), w(i,k,j+1), &
5458 vel )
5459 ENDDO
5460 ENDDO
5461 k = ktf+1
5462 DO i = i_start, i_end
5463 vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
5464 fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1), &
5465 w(i,k,j ), w(i,k,j+1), &
5466 vel )
5467 ENDDO
5468 END IF
5469
5470 ! y flux-divergence into tendency
5471
5472 ! Comments for polar boundary conditions
5473 ! Same process as for advect_u - tendencies run from jds to jde-1
5474 ! (latitudes are as for u grid, longitudes are displaced)
5475 ! Therefore: flow is only from one side for points next to poles
5476 IF ( config_flags%polar .AND. (j == jds+1) ) THEN
5477 DO k=kts,ktf
5478 DO i = i_start, i_end
5479 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5480 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
5481 END DO
5482 END DO
5483 ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
5484 DO k=kts,ktf
5485 DO i = i_start, i_end
5486 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5487 tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
5488 END DO
5489 END DO
5490 ELSE ! normal code
5491
5492 IF( j > j_start ) THEN
5493
5494 DO k = kts+1, ktf+1
5495 DO i = i_start, i_end
5496 mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5497 tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
5498 ENDDO
5499 ENDDO
5500
5501 END IF
5502
5503 END IF
5504
5505 jtmp = jp1
5506 jp1 = jp0
5507 jp0 = jtmp
5508
5509 ENDDO
5510
5511 ELSE IF (horz_order == 2 ) THEN
5512
5513 i_start = its
5514 i_end = MIN(ite,ide-1)
5515 j_start = jts
5516 j_end = MIN(jte,jde-1)
5517
5518 IF ( .NOT. config_flags%periodic_x ) THEN
5519 IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
5520 IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite)
5521 ENDIF
5522
5523 DO j = j_start, j_end
5524 DO k=kts+1,ktf
5525 DO i = i_start, i_end
5526
5527 mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS
5528
5529 tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 &
5530 *((fzm(k)*ru(i+1,k,j)+fzp(k)*ru(i+1,k-1,j)) &
5531 *(w(i+1,k,j)+w(i,k,j)) &
5532 -(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
5533 *(w(i,k,j)+w(i-1,k,j)))
5534
5535 ENDDO
5536 ENDDO
5537
5538 k = ktf+1
5539 DO i = i_start, i_end
5540
5541 mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS
5542
5543 tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 &
5544 *(((2.-fzm(k-1))*ru(i+1,k-1,j)-fzp(k-1)*ru(i+1,k-2,j)) &
5545 *(w(i+1,k,j)+w(i,k,j)) &
5546 -((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
5547 *(w(i,k,j)+w(i-1,k,j)))
5548
5549 ENDDO
5550
5551 ENDDO
5552
5553 i_start = its
5554 i_end = MIN(ite,ide-1)
5555 ! Polar boundary conditions are like open or specified
5556 IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
5557 IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-2,jte)
5558
5559 DO j = j_start, j_end
5560 DO k=kts+1,ktf
5561 DO i = i_start, i_end
5562
5563 mrdy=msftx(i,j)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5564
5565 tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 &
5566 *((fzm(k)*rv(i,k,j+1)+fzp(k)*rv(i,k-1,j+1))* &
5567 (w(i,k,j+1)+w(i,k,j)) &
5568 -(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)) &
5569 *(w(i,k,j)+w(i,k,j-1)))
5570
5571 ENDDO
5572 ENDDO
5573
5574 k = ktf+1
5575 DO i = i_start, i_end
5576
5577 mrdy=msftx(i,j)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5578
5579 tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 &
5580 *(((2.-fzm(k-1))*rv(i,k-1,j+1)-fzp(k-1)*rv(i,k-2,j+1))* &
5581 (w(i,k,j+1)+w(i,k,j)) &
5582 -((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)) &
5583 *(w(i,k,j)+w(i,k,j-1)))
5584
5585 ENDDO
5586
5587 ENDDO
5588
5589 ! Polar boundary condition ... not covered in above j-loop
5590 IF (config_flags%polar) THEN
5591 IF (jts == jds) THEN
5592 DO k=kts+1,ktf
5593 DO i = i_start, i_end
5594 mrdy=msftx(i,jds)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5595 tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
5596 *((fzm(k)*rv(i,k,jds+1)+fzp(k)*rv(i,k-1,jds+1))* &
5597 (w(i,k,jds+1)+w(i,k,jds)))
5598 END DO
5599 END DO
5600 k = ktf+1
5601 DO i = i_start, i_end
5602 mrdy=msftx(i,jds)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5603 tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
5604 *((2.-fzm(k-1))*rv(i,k-1,jds+1)-fzp(k-1)*rv(i,k-2,jds+1))* &
5605 (w(i,k,jds+1)+w(i,k,jds))
5606 ENDDO
5607 END IF
5608 IF (jte == jde) THEN
5609 DO k=kts+1,ktf
5610 DO i = i_start, i_end
5611 mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5612 tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
5613 *((fzm(k)*rv(i,k,jde-1)+fzp(k)*rv(i,k-1,jde-1))* &
5614 (w(i,k,jde-1)+w(i,k,jde-2)))
5615 END DO
5616 END DO
5617 k = ktf+1
5618 DO i = i_start, i_end
5619 mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5620 tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
5621 *((2.-fzm(k-1))*rv(i,k-1,jde-1)-fzp(k-1)*rv(i,k-2,jde-1)) &
5622 *(w(i,k,jde-1)+w(i,k,jde-2))
5623 ENDDO
5624 END IF
5625 END IF
5626
5627 ELSE IF ( horz_order == 0 ) THEN
5628
5629 ! Just in case we want to turn horizontal advection off, we can do it
5630
5631 ELSE
5632
5633 WRITE ( wrf_err_message ,*) ' advect_w_6a, h_order not known ',horz_order
5634 CALL wrf_error_fatal ( wrf_err_message )
5635
5636 ENDIF horizontal_order_test
5637
5638
5639 ! pick up the the horizontal radiation boundary conditions.
5640 ! (these are the computations that don't require 'cb'.
5641 ! first, set to index ranges
5642
5643
5644 i_start = its
5645 i_end = MIN(ite,ide-1)
5646 j_start = jts
5647 j_end = MIN(jte,jde-1)
5648
5649 IF( (config_flags%open_xs) .and. (its == ids)) THEN
5650
5651 DO j = j_start, j_end
5652 DO k = kts+1, ktf
5653
5654 uw = 0.5*(fzm(k)*(ru(its,k ,j)+ru(its+1,k ,j)) + &
5655 fzp(k)*(ru(its,k-1,j)+ru(its+1,k-1,j)) )
5656 ub = MIN( uw, 0. )
5657
5658 tendency(its,k,j) = tendency(its,k,j) &
5659 - rdx*( &
5660 ub*(w_old(its+1,k,j) - w_old(its,k,j)) + &
5661 w(its,k,j)*( &
5662 fzm(k)*(ru(its+1,k ,j)-ru(its,k ,j))+ &
5663 fzp(k)*(ru(its+1,k-1,j)-ru(its,k-1,j))) &
5664 )
5665 ENDDO
5666 ENDDO
5667
5668 k = ktf+1
5669 DO j = j_start, j_end
5670
5671 uw = 0.5*( (2.-fzm(k-1))*(ru(its,k-1,j)+ru(its+1,k-1,j)) &
5672 -fzp(k-1)*(ru(its,k-2,j)+ru(its+1,k-2,j)) )
5673 ub = MIN( uw, 0. )
5674
5675 tendency(its,k,j) = tendency(its,k,j) &
5676 - rdx*( &
5677 ub*(w_old(its+1,k,j) - w_old(its,k,j)) + &
5678 w(its,k,j)*( &
5679 (2.-fzm(k-1))*(ru(its+1,k-1,j)-ru(its,k-1,j))- &
5680 fzp(k-1)*(ru(its+1,k-2,j)-ru(its,k-2,j))) &
5681 )
5682 ENDDO
5683
5684 ENDIF
5685
5686 IF( (config_flags%open_xe) .and. (ite == ide)) THEN
5687
5688 DO j = j_start, j_end
5689 DO k = kts+1, ktf
5690
5691 uw = 0.5*(fzm(k)*(ru(ite-1,k ,j)+ru(ite,k ,j)) + &
5692 fzp(k)*(ru(ite-1,k-1,j)+ru(ite,k-1,j)) )
5693 ub = MAX( uw, 0. )
5694
5695 tendency(i_end,k,j) = tendency(i_end,k,j) &
5696 - rdx*( &
5697 ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) + &
5698 w(i_end,k,j)*( &
5699 fzm(k)*(ru(ite,k ,j)-ru(ite-1,k ,j)) + &
5700 fzp(k)*(ru(ite,k-1,j)-ru(ite-1,k-1,j))) &
5701 )
5702 ENDDO
5703 ENDDO
5704
5705 k = ktf+1
5706 DO j = j_start, j_end
5707
5708 uw = 0.5*( (2.-fzm(k-1))*(ru(ite-1,k-1,j)+ru(ite,k-1,j)) &
5709 -fzp(k-1)*(ru(ite-1,k-2,j)+ru(ite,k-2,j)) )
5710 ub = MAX( uw, 0. )
5711
5712 tendency(i_end,k,j) = tendency(i_end,k,j) &
5713 - rdx*( &
5714 ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) + &
5715 w(i_end,k,j)*( &
5716 (2.-fzm(k-1))*(ru(ite,k-1,j)-ru(ite-1,k-1,j)) - &
5717 fzp(k-1)*(ru(ite,k-2,j)-ru(ite-1,k-2,j))) &
5718 )
5719 ENDDO
5720
5721 ENDIF
5722
5723
5724 IF( (config_flags%open_ys) .and. (jts == jds)) THEN
5725
5726 DO i = i_start, i_end
5727 DO k = kts+1, ktf
5728
5729 vw = 0.5*( fzm(k)*(rv(i,k ,jts)+rv(i,k ,jts+1)) + &
5730 fzp(k)*(rv(i,k-1,jts)+rv(i,k-1,jts+1)) )
5731 vb = MIN( vw, 0. )
5732
5733 tendency(i,k,jts) = tendency(i,k,jts) &
5734 - rdy*( &
5735 vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) + &
5736 w(i,k,jts)*( &
5737 fzm(k)*(rv(i,k ,jts+1)-rv(i,k ,jts))+ &
5738 fzp(k)*(rv(i,k-1,jts+1)-rv(i,k-1,jts))) &
5739 )
5740 ENDDO
5741 ENDDO
5742
5743 k = ktf+1
5744 DO i = i_start, i_end
5745 vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jts)+rv(i,k-1,jts+1)) &
5746 -fzp(k-1)*(rv(i,k-2,jts)+rv(i,k-2,jts+1)) )
5747 vb = MIN( vw, 0. )
5748
5749 tendency(i,k,jts) = tendency(i,k,jts) &
5750 - rdy*( &
5751 vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) + &
5752 w(i,k,jts)*( &
5753 (2.-fzm(k-1))*(rv(i,k-1,jts+1)-rv(i,k-1,jts))- &
5754 fzp(k-1)*(rv(i,k-2,jts+1)-rv(i,k-2,jts))) &
5755 )
5756 ENDDO
5757
5758 ENDIF
5759
5760 IF( (config_flags%open_ye) .and. (jte == jde) ) THEN
5761
5762 DO i = i_start, i_end
5763 DO k = kts+1, ktf
5764
5765 vw = 0.5*( fzm(k)*(rv(i,k ,jte-1)+rv(i,k ,jte)) + &
5766 fzp(k)*(rv(i,k-1,jte-1)+rv(i,k-1,jte)) )
5767 vb = MAX( vw, 0. )
5768
5769 tendency(i,k,j_end) = tendency(i,k,j_end) &
5770 - rdy*( &
5771 vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) + &
5772 w(i,k,j_end)*( &
5773 fzm(k)*(rv(i,k ,jte)-rv(i,k ,jte-1))+ &
5774 fzp(k)*(rv(i,k-1,jte)-rv(i,k-1,jte-1))) &
5775 )
5776 ENDDO
5777 ENDDO
5778
5779 k = ktf+1
5780 DO i = i_start, i_end
5781
5782 vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jte-1)+rv(i,k-1,jte)) &
5783 -fzp(k-1)*(rv(i,k-2,jte-1)+rv(i,k-2,jte)) )
5784 vb = MAX( vw, 0. )
5785
5786 tendency(i,k,j_end) = tendency(i,k,j_end) &
5787 - rdy*( &
5788 vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) + &
5789 w(i,k,j_end)*( &
5790 (2.-fzm(k-1))*(rv(i,k-1,jte)-rv(i,k-1,jte-1))- &
5791 fzp(k-1)*(rv(i,k-2,jte)-rv(i,k-2,jte-1))) &
5792 )
5793 ENDDO
5794
5795 ENDIF
5796
5797 !-------------------- vertical advection
5798 ! ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
5799 ! Here we have: - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
5800 ! Therefore we don't need to make a correction for advect_w
5801
5802 i_start = its
5803 i_end = MIN(ite,ide-1)
5804 j_start = jts
5805 j_end = MIN(jte,jde-1)
5806
5807 DO i = i_start, i_end
5808 vflux(i,kts)=0.
5809 vflux(i,kte)=0.
5810 ENDDO
5811
5812 vert_order_test : IF (vert_order == 6) THEN
5813
5814 DO j = j_start, j_end
5815
5816 DO k=kts+3,ktf-1
5817 DO i = i_start, i_end
5818 vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5819 vflux(i,k) = vel*flux6( &
5820 w(i,k-3,j), w(i,k-2,j), w(i,k-1,j), &
5821 w(i,k ,j), w(i,k+1,j), w(i,k+2,j), -vel )
5822 ENDDO
5823 ENDDO
5824
5825 DO i = i_start, i_end
5826
5827 k=kts+1
5828 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5829
5830 k = kts+2
5831 vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5832 vflux(i,k) = vel*flux4( &
5833 w(i,k-2,j), w(i,k-1,j), &
5834 w(i,k ,j), w(i,k+1,j), -vel )
5835
5836 k = ktf
5837 vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5838 vflux(i,k) = vel*flux4( &
5839 w(i,k-2,j), w(i,k-1,j), &
5840 w(i,k ,j), w(i,k+1,j), -vel )
5841
5842 k=ktf+1
5843 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5844
5845 ENDDO
5846
5847 DO k=kts+1,ktf
5848 DO i = i_start, i_end
5849 tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5850 ENDDO
5851 ENDDO
5852
5853 ! pick up flux contribution for w at the lid. wcs, 13 march 2004
5854 k = ktf+1
5855 DO i = i_start, i_end
5856 tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5857 ENDDO
5858
5859 ENDDO
5860
5861 ELSE IF (vert_order == 5) THEN
5862
5863 DO j = j_start, j_end
5864
5865 DO k=kts+3,ktf-1
5866 DO i = i_start, i_end
5867 vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5868 vflux(i,k) = vel*flux5( &
5869 w(i,k-3,j), w(i,k-2,j), w(i,k-1,j), &
5870 w(i,k ,j), w(i,k+1,j), w(i,k+2,j), -vel )
5871 ENDDO
5872 ENDDO
5873
5874 DO i = i_start, i_end
5875
5876 k=kts+1
5877 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5878
5879 k = kts+2
5880 vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5881 vflux(i,k) = vel*flux3( &
5882 w(i,k-2,j), w(i,k-1,j), &
5883 w(i,k ,j), w(i,k+1,j), -vel )
5884 k = ktf
5885 vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5886 vflux(i,k) = vel*flux3( &
5887 w(i,k-2,j), w(i,k-1,j), &
5888 w(i,k ,j), w(i,k+1,j), -vel )
5889
5890 k=ktf+1
5891 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5892
5893 ENDDO
5894
5895 DO k=kts+1,ktf
5896 DO i = i_start, i_end
5897 tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5898 ENDDO
5899 ENDDO
5900
5901 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5902 k = ktf+1
5903 DO i = i_start, i_end
5904 tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5905 ENDDO
5906
5907 ENDDO
5908
5909 ELSE IF (vert_order == 4) THEN
5910
5911 DO j = j_start, j_end
5912
5913 DO k=kts+2,ktf
5914 DO i = i_start, i_end
5915 vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5916 vflux(i,k) = vel*flux4( &
5917 w(i,k-2,j), w(i,k-1,j), &
5918 w(i,k ,j), w(i,k+1,j), -vel )
5919 ENDDO
5920 ENDDO
5921
5922 DO i = i_start, i_end
5923
5924 k=kts+1
5925 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5926 k=ktf+1
5927 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5928
5929 ENDDO
5930
5931 DO k=kts+1,ktf
5932 DO i = i_start, i_end
5933 tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5934 ENDDO
5935 ENDDO
5936
5937 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5938 k = ktf+1
5939 DO i = i_start, i_end
5940 tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5941 ENDDO
5942
5943 ENDDO
5944
5945 ELSE IF (vert_order == 3) THEN
5946
5947 DO j = j_start, j_end
5948
5949 DO k=kts+2,ktf
5950 DO i = i_start, i_end
5951 vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5952 vflux(i,k) = vel*flux3( &
5953 w(i,k-2,j), w(i,k-1,j), &
5954 w(i,k ,j), w(i,k+1,j), -vel )
5955 ENDDO
5956 ENDDO
5957
5958 DO i = i_start, i_end
5959
5960 k=kts+1
5961 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5962 k=ktf+1
5963 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5964
5965 ENDDO
5966
5967 DO k=kts+1,ktf
5968 DO i = i_start, i_end
5969 tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5970 ENDDO
5971 ENDDO
5972
5973 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5974 k = ktf+1
5975 DO i = i_start, i_end
5976 tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5977 ENDDO
5978
5979 ENDDO
5980
5981 ELSE IF (vert_order == 2) THEN
5982
5983 DO j = j_start, j_end
5984 DO k=kts+1,ktf+1
5985 DO i = i_start, i_end
5986
5987 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5988 ENDDO
5989 ENDDO
5990 DO k=kts+1,ktf
5991 DO i = i_start, i_end
5992 tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5993
5994 ENDDO
5995 ENDDO
5996
5997 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5998 k = ktf+1
5999 DO i = i_start, i_end
6000 tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
6001 ENDDO
6002
6003 ENDDO
6004
6005 ELSE
6006
6007 WRITE (wrf_err_message ,*) ' advect_w, v_order not known ',vert_order
6008 CALL wrf_error_fatal ( wrf_err_message )
6009
6010 ENDIF vert_order_test
6011
6012 END SUBROUTINE advect_w
6013
6014 !----------------------------------------------------------------
6015
6016 SUBROUTINE advect_scalar_pd ( field, field_old, tendency, &
6017 ru, rv, rom, &
6018 mut, mub, mu_old, &
6019 config_flags, &
6020 msfux, msfuy, msfvx, msfvy, &
6021 msftx, msfty, &
6022 fzm, fzp, &
6023 rdx, rdy, rdzw, dt, &
6024 ids, ide, jds, jde, kds, kde, &
6025 ims, ime, jms, jme, kms, kme, &
6026 its, ite, jts, jte, kts, kte )
6027
6028 ! this is a first cut at a positive definite advection option
6029 ! for scalars in WRF. This version is memory intensive ->
6030 ! we save 3d arrays of x, y and z both high and low order fluxes
6031 ! (six in all). Alternatively, we could sweep in a direction
6032 ! and lower the cost considerably.
6033
6034 ! uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
6035 ! fluxes initially
6036
6037 ! WCS, 3 December 2002, 24 February 2003
6038
6039 IMPLICIT NONE
6040
6041 ! Input data
6042
6043 TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
6044
6045 INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
6046 ims, ime, jms, jme, kms, kme, &
6047 its, ite, jts, jte, kts, kte
6048
6049 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, &
6050 field_old, &
6051 ru, &
6052 rv, &
6053 rom
6054
6055 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, mub, mu_old
6056 REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
6057
6058 REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, &
6059 msfuy, &
6060 msfvx, &
6061 msfvy, &
6062 msftx, &
6063 msfty
6064
6065 REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, &
6066 fzp, &
6067 rdzw
6068
6069 REAL , INTENT(IN ) :: rdx, &
6070 rdy, &
6071 dt
6072
6073 ! Local data
6074
6075 INTEGER :: i, j, k, itf, jtf, ktf
6076 INTEGER :: i_start, i_end, j_start, j_end
6077 INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
6078 INTEGER :: jmin, jmax, jp, jm, imin, imax
6079
6080 REAL :: mrdx, mrdy, ub, vb, uw, vw, mu
6081
6082 ! storage for high and low order fluxes
6083
6084 REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqx, fqy, fqz
6085 REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqxl, fqyl, fqzl
6086
6087 INTEGER :: horz_order, vert_order
6088
6089 LOGICAL :: degrade_xs, degrade_ys
6090 LOGICAL :: degrade_xe, degrade_ye
6091
6092 INTEGER :: jp1, jp0, jtmp
6093
6094 REAL :: flux_out, ph_low, scale
6095 REAL, PARAMETER :: eps=1.e-20
6096
6097
6098 ! definition of flux operators, 3rd, 4th, 5th or 6th order
6099
6100 REAL :: flux3, flux4, flux5, flux6, flux_upwind
6101 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
6102
6103 flux4(q_im2, q_im1, q_i, q_ip1, ua) = &
6104 (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
6105
6106 flux3(q_im2, q_im1, q_i, q_ip1, ua) = &
6107 flux4(q_im2, q_im1, q_i, q_ip1, ua) + &
6108 sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
6109
6110 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = &
6111 (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2) &
6112 +(1./60.)*(q_ip2+q_im3)
6113
6114 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = &
6115 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) &
6116 -sign(1.,ua)*(1./60.)*( &
6117 (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
6118
6119 flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 &
6120 +0.5*max(-1.0,(cr-abs(cr)))*q_i
6121 ! flux_upwind(q_im1, q_i, cr ) = 0.
6122
6123 REAL :: dx,dy,dz
6124
6125 LOGICAL, PARAMETER :: pd_limit = .true.
6126
6127 ! set order for the advection schemes
6128
6129 ! write(6,*) ' in pd advection routine '
6130
6131 ! Empty arrays just in case:
6132 IF (config_flags%polar) THEN
6133 fqx(:,:,:) = 0.
6134 fqy(:,:,:) = 0.
6135 fqz(:,:,:) = 0.
6136 fqxl(:,:,:) = 0.
6137 fqyl(:,:,:) = 0.
6138 fqzl(:,:,:) = 0.
6139 END IF
6140
6141 ktf=MIN(kte,kde-1)
6142 horz_order = config_flags%h_sca_adv_order
6143 vert_order = config_flags%v_sca_adv_order
6144
6145 ! determine boundary mods for flux operators
6146 ! We degrade the flux operators from 3rd/4th order
6147 ! to second order one gridpoint in from the boundaries for
6148 ! all boundary conditions except periodic and symmetry - these
6149 ! conditions have boundary zone data fill for correct application
6150 ! of the higher order flux stencils
6151
6152 degrade_xs = .true.
6153 degrade_xe = .true.
6154 degrade_ys = .true.
6155 degrade_ye = .true.
6156
6157 ! begin with horizontal flux divergence
6158 ! here is the choice of flux operators
6159
6160
6161 horizontal_order_test : IF( horz_order == 6 ) THEN
6162
6163 IF( config_flags%periodic_x .or. &
6164 config_flags%symmetric_xs .or. &
6165 (its > ids+2) ) degrade_xs = .false.
6166 IF( config_flags%periodic_x .or. &
6167 config_flags%symmetric_xe .or. &
6168 (ite < ide-3) ) degrade_xe = .false.
6169 IF( config_flags%periodic_y .or. &
6170 config_flags%symmetric_ys .or. &
6171 (jts > jds+2) ) degrade_ys = .false.
6172 IF( config_flags%periodic_y .or. &
6173 config_flags%symmetric_ye .or. &
6174 (jte < jde-3) ) degrade_ye = .false.
6175
6176 !--------------- y - advection first
6177
6178 !-- y flux compute; these bounds are for periodic and sym b.c.
6179
6180 ktf=MIN(kte,kde-1)
6181 i_start = its-1
6182 i_end = MIN(ite,ide-1)+1
6183 j_start = jts-1
6184 j_end = MIN(jte,jde-1)+1
6185 j_start_f = j_start
6186 j_end_f = j_end+1
6187
6188 !-- modify loop bounds if open or specified
6189
6190 IF(degrade_xs) i_start = its
6191 IF(degrade_xe) i_end = MIN(ite,ide-1)
6192
6193 IF(degrade_ys) then
6194 j_start = MAX(jts,jds+1)
6195 j_start_f = jds+3
6196 ENDIF
6197
6198 IF(degrade_ye) then
6199 j_end = MIN(jte,jde-2)
6200 j_end_f = jde-3
6201 ENDIF
6202
6203 ! compute fluxes, 6th order
6204
6205 j_loop_y_flux_6 : DO j = j_start, j_end+1
6206
6207 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6208
6209 DO k=kts,ktf
6210 DO i = i_start, i_end
6211
6212 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6213 mu = 0.5*(mut(i,j)+mut(i,j-1))
6214 vel = rv(i,k,j)
6215 cr = vel*dt/dy/mu
6216 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6217
6218 fqy( i, k, j ) = vel*flux6( &
6219 field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), &
6220 field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel )
6221
6222 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6223
6224 ENDDO
6225 ENDDO
6226
6227 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
6228
6229 DO k=kts,ktf
6230 DO i = i_start, i_end
6231
6232 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6233 mu = 0.5*(mut(i,j)+mut(i,j-1))
6234 vel = rv(i,k,j)
6235 cr = vel*dt/dy/mu
6236 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6237
6238 fqy(i,k, j) = 0.5*rv(i,k,j)* &
6239 (field(i,k,j)+field(i,k,j-1))
6240
6241 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6242
6243 ENDDO
6244 ENDDO
6245
6246 ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary
6247
6248 DO k=kts,ktf
6249 DO i = i_start, i_end
6250
6251 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6252 mu = 0.5*(mut(i,j)+mut(i,j-1))
6253 vel = rv(i,k,j)
6254 cr = vel*dt/dy/mu
6255 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6256
6257 fqy( i, k, j ) = vel*flux4( &
6258 field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
6259 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6260
6261 ENDDO
6262 ENDDO
6263
6264 ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary
6265
6266 DO k=kts,ktf
6267 DO i = i_start, i_end
6268
6269 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6270 mu = 0.5*(mut(i,j)+mut(i,j-1))
6271 vel = rv(i,k,j)
6272 cr = vel*dt/dy/mu
6273 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6274
6275 fqy(i, k, j ) = 0.5*rv(i,k,j)* &
6276 (field(i,k,j)+field(i,k,j-1))
6277 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6278
6279 ENDDO
6280 ENDDO
6281
6282 ELSE IF ( j == jde-2 ) THEN ! 4th order flux 2 in from north boundary
6283
6284 DO k=kts,ktf
6285 DO i = i_start, i_end
6286
6287 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6288 mu = 0.5*(mut(i,j)+mut(i,j-1))
6289 vel = rv(i,k,j)
6290 cr = vel*dt/dy/mu
6291 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6292
6293 fqy( i, k, j) = vel*flux4( &
6294 field(i,k,j-2),field(i,k,j-1), &
6295 field(i,k,j),field(i,k,j+1),vel )
6296 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6297
6298 ENDDO
6299 ENDDO
6300
6301 ENDIF
6302
6303 ENDDO j_loop_y_flux_6
6304
6305 ! next, x flux
6306
6307 !-- these bounds are for periodic and sym conditions
6308
6309 i_start = its-1
6310 i_end = MIN(ite,ide-1)+1
6311 i_start_f = i_start
6312 i_end_f = i_end+1
6313
6314 j_start = jts-1
6315 j_end = MIN(jte,jde-1)+1
6316
6317 !-- modify loop bounds for open and specified b.c
6318
6319 IF(degrade_ys) j_start = jts
6320 IF(degrade_ye) j_end = MIN(jte,jde-1)
6321
6322 IF(degrade_xs) then
6323 i_start = MAX(ids+1,its)
6324 i_start_f = i_start+2
6325 ENDIF
6326
6327 IF(degrade_xe) then
6328 i_end = MIN(ide-2,ite)
6329 i_end_f = ide-3
6330 ENDIF
6331
6332 ! compute fluxes
6333
6334 DO j = j_start, j_end
6335
6336 ! 6th order flux
6337
6338 DO k=kts,ktf
6339 DO i = i_start_f, i_end_f
6340
6341 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6342 mu = 0.5*(mut(i,j)+mut(i-1,j))
6343 vel = ru(i,k,j)
6344 cr = vel*dt/dx/mu
6345 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6346
6347 fqx( i,k,j ) = vel*flux6( field(i-3,k,j), field(i-2,k,j), &
6348 field(i-1,k,j), field(i ,k,j), &
6349 field(i+1,k,j), field(i+2,k,j), &
6350 vel )
6351 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6352
6353 ENDDO
6354 ENDDO
6355
6356 ! lower order fluxes close to boundaries (if not periodic or symmetric)
6357
6358 IF( degrade_xs ) THEN
6359
6360 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
6361 i = ids+1
6362 DO k=kts,ktf
6363
6364 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6365 mu = 0.5*(mut(i,j)+mut(i-1,j))
6366 vel = ru(i,k,j)/mu
6367 cr = vel*dt/dx
6368 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6369
6370 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6371 *(field(i,k,j)+field(i-1,k,j))
6372
6373 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6374
6375 ENDDO
6376 ENDIF
6377
6378 i = ids+2
6379 DO k=kts,ktf
6380 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6381 mu = 0.5*(mut(i,j)+mut(i-1,j))
6382 vel = ru(i,k,j)
6383 cr = vel*dt/dx/mu
6384 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6385 fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), &
6386 field(i ,k,j), field(i+1,k,j), &
6387 vel )
6388 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6389
6390 ENDDO
6391
6392 ENDIF
6393
6394 IF( degrade_xe ) THEN
6395
6396 IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
6397 i = ide-1
6398 DO k=kts,ktf
6399 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6400 mu = 0.5*(mut(i,j)+mut(i-1,j))
6401 vel = ru(i,k,j)
6402 cr = vel*dt/dx/mu
6403 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6404 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6405 *(field(i,k,j)+field(i-1,k,j))
6406 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6407
6408 ENDDO
6409 ENDIF
6410
6411 i = ide-2
6412 DO k=kts,ktf
6413
6414 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6415 mu = 0.5*(mut(i,j)+mut(i-1,j))
6416 vel = ru(i,k,j)
6417 cr = vel*dt/dx/mu
6418 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6419 fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), &
6420 field(i ,k,j), field(i+1,k,j), &
6421 vel )
6422 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6423
6424 ENDDO
6425
6426 ENDIF
6427
6428 ENDDO ! enddo for outer J loop
6429
6430 !--- end of 6th order horizontal flux calculation
6431
6432 ELSE IF( horz_order == 5 ) THEN
6433
6434 IF( config_flags%periodic_x .or. &
6435 config_flags%symmetric_xs .or. &
6436 (its > ids+2) ) degrade_xs = .false.
6437 IF( config_flags%periodic_x .or. &
6438 config_flags%symmetric_xe .or. &
6439 (ite < ide-3) ) degrade_xe = .false.
6440 IF( config_flags%periodic_y .or. &
6441 config_flags%symmetric_ys .or. &
6442 (jts > jds+2) ) degrade_ys = .false.
6443 IF( config_flags%periodic_y .or. &
6444 config_flags%symmetric_ye .or. &
6445 (jte < jde-3) ) degrade_ye = .false.
6446
6447 !--------------- y - advection first
6448
6449 !-- y flux compute; these bounds are for periodic and sym b.c.
6450
6451 ktf=MIN(kte,kde-1)
6452 i_start = its-1
6453 i_end = MIN(ite,ide-1)+1
6454 j_start = jts-1
6455 j_end = MIN(jte,jde-1)+1
6456 j_start_f = j_start
6457 j_end_f = j_end+1
6458
6459 !-- modify loop bounds if open or specified
6460
6461 IF(degrade_xs) i_start = its
6462 IF(degrade_xe) i_end = MIN(ite,ide-1)
6463
6464 IF(degrade_ys) then
6465 j_start = MAX(jts,jds+1)
6466 j_start_f = jds+3
6467 ENDIF
6468
6469 IF(degrade_ye) then
6470 j_end = MIN(jte,jde-2)
6471 j_end_f = jde-3
6472 ENDIF
6473
6474 ! compute fluxes, 5th order
6475
6476 j_loop_y_flux_5 : DO j = j_start, j_end+1
6477
6478 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6479
6480 DO k=kts,ktf
6481 DO i = i_start, i_end
6482
6483 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6484 mu = 0.5*(mut(i,j)+mut(i,j-1))
6485 vel = rv(i,k,j)
6486 cr = vel*dt/dy/mu
6487 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6488
6489 fqy( i, k, j ) = vel*flux5( &
6490 field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), &
6491 field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel )
6492
6493 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6494
6495 ENDDO
6496 ENDDO
6497
6498 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
6499
6500 DO k=kts,ktf
6501 DO i = i_start, i_end
6502
6503 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6504 mu = 0.5*(mut(i,j)+mut(i,j-1))
6505 vel = rv(i,k,j)
6506 cr = vel*dt/dy/mu
6507 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6508
6509 fqy(i,k, j) = 0.5*rv(i,k,j)* &
6510 (field(i,k,j)+field(i,k,j-1))
6511
6512 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6513
6514 ENDDO
6515 ENDDO
6516
6517 ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary
6518
6519 DO k=kts,ktf
6520 DO i = i_start, i_end
6521
6522 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6523 mu = 0.5*(mut(i,j)+mut(i,j-1))
6524 vel = rv(i,k,j)
6525 cr = vel*dt/dy/mu
6526 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6527
6528 fqy( i, k, j ) = vel*flux3( &
6529 field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
6530 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6531
6532 ENDDO
6533 ENDDO
6534
6535 ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary
6536
6537 DO k=kts,ktf
6538 DO i = i_start, i_end
6539
6540 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6541 mu = 0.5*(mut(i,j)+mut(i,j-1))
6542 vel = rv(i,k,j)
6543 cr = vel*dt/dy/mu
6544 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6545
6546 fqy(i, k, j ) = 0.5*rv(i,k,j)* &
6547 (field(i,k,j)+field(i,k,j-1))
6548 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6549
6550 ENDDO
6551 ENDDO
6552
6553 ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary
6554
6555 DO k=kts,ktf
6556 DO i = i_start, i_end
6557
6558 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6559 mu = 0.5*(mut(i,j)+mut(i,j-1))
6560 vel = rv(i,k,j)
6561 cr = vel*dt/dy/mu
6562 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6563
6564 fqy( i, k, j) = vel*flux3( &
6565 field(i,k,j-2),field(i,k,j-1), &
6566 field(i,k,j),field(i,k,j+1),vel )
6567 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6568
6569 ENDDO
6570 ENDDO
6571
6572 ENDIF
6573
6574 ENDDO j_loop_y_flux_5
6575
6576 ! next, x flux
6577
6578 !-- these bounds are for periodic and sym conditions
6579
6580 i_start = its-1
6581 i_end = MIN(ite,ide-1)+1
6582 i_start_f = i_start
6583 i_end_f = i_end+1
6584
6585 j_start = jts-1
6586 j_end = MIN(jte,jde-1)+1
6587
6588 !-- modify loop bounds for open and specified b.c
6589
6590 IF(degrade_ys) j_start = jts
6591 IF(degrade_ye) j_end = MIN(jte,jde-1)
6592
6593 IF(degrade_xs) then
6594 i_start = MAX(ids+1,its)
6595 i_start_f = i_start+2
6596 ENDIF
6597
6598 IF(degrade_xe) then
6599 i_end = MIN(ide-2,ite)
6600 i_end_f = ide-3
6601 ENDIF
6602
6603 ! compute fluxes
6604
6605 DO j = j_start, j_end
6606
6607 ! 5th order flux
6608
6609 DO k=kts,ktf
6610 DO i = i_start_f, i_end_f
6611
6612 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6613 mu = 0.5*(mut(i,j)+mut(i-1,j))
6614 vel = ru(i,k,j)
6615 cr = vel*dt/dx/mu
6616 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6617
6618 fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), &
6619 field(i-1,k,j), field(i ,k,j), &
6620 field(i+1,k,j), field(i+2,k,j), &
6621 vel )
6622 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6623
6624 ENDDO
6625 ENDDO
6626
6627 ! lower order fluxes close to boundaries (if not periodic or symmetric)
6628
6629 IF( degrade_xs ) THEN
6630
6631 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
6632 i = ids+1
6633 DO k=kts,ktf
6634
6635 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6636 mu = 0.5*(mut(i,j)+mut(i-1,j))
6637 vel = ru(i,k,j)/mu
6638 cr = vel*dt/dx
6639 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6640
6641 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6642 *(field(i,k,j)+field(i-1,k,j))
6643
6644 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6645
6646 ENDDO
6647 ENDIF
6648
6649 i = ids+2
6650 DO k=kts,ktf
6651 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6652 mu = 0.5*(mut(i,j)+mut(i-1,j))
6653 vel = ru(i,k,j)
6654 cr = vel*dt/dx/mu
6655 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6656 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), &
6657 field(i ,k,j), field(i+1,k,j), &
6658 vel )
6659 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6660
6661 ENDDO
6662
6663 ENDIF
6664
6665 IF( degrade_xe ) THEN
6666
6667 IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
6668 i = ide-1
6669 DO k=kts,ktf
6670 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6671 mu = 0.5*(mut(i,j)+mut(i-1,j))
6672 vel = ru(i,k,j)
6673 cr = vel*dt/dx/mu
6674 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6675 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6676 *(field(i,k,j)+field(i-1,k,j))
6677 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6678
6679 ENDDO
6680 ENDIF
6681
6682 i = ide-2
6683 DO k=kts,ktf
6684
6685 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6686 mu = 0.5*(mut(i,j)+mut(i-1,j))
6687 vel = ru(i,k,j)
6688 cr = vel*dt/dx/mu
6689 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6690 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), &
6691 field(i ,k,j), field(i+1,k,j), &
6692 vel )
6693 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6694
6695 ENDDO
6696
6697 ENDIF
6698
6699 ENDDO ! enddo for outer J loop
6700
6701 !--- end of 5th order horizontal flux calculation
6702
6703 ELSE IF( horz_order == 4 ) THEN
6704
6705 IF( config_flags%periodic_x .or. &
6706 config_flags%symmetric_xs .or. &
6707 (its > ids+1) ) degrade_xs = .false.
6708 IF( config_flags%periodic_x .or. &
6709 config_flags%symmetric_xe .or. &
6710 (ite < ide-2) ) degrade_xe = .false.
6711 IF( config_flags%periodic_y .or. &
6712 config_flags%symmetric_ys .or. &
6713 (jts > jds+1) ) degrade_ys = .false.
6714 IF( config_flags%periodic_y .or. &
6715 config_flags%symmetric_ye .or. &
6716 (jte < jde-2) ) degrade_ye = .false.
6717
6718 !--------------- y - advection first
6719
6720 !-- y flux compute; these bounds are for periodic and sym b.c.
6721
6722 ktf=MIN(kte,kde-1)
6723 i_start = its-1
6724 i_end = MIN(ite,ide-1)+1
6725 j_start = jts-1
6726 j_end = MIN(jte,jde-1)+1
6727 j_start_f = j_start
6728 j_end_f = j_end+1
6729
6730 !-- modify loop bounds if open or specified
6731
6732 IF(degrade_xs) i_start = its
6733 IF(degrade_xe) i_end = MIN(ite,ide-1)
6734
6735 IF(degrade_ys) then
6736 j_start = MAX(jts,jds+1)
6737 j_start_f = jds+2
6738 ENDIF
6739
6740 IF(degrade_ye) then
6741 j_end = MIN(jte,jde-2)
6742 j_end_f = jde-2
6743 ENDIF
6744
6745 ! compute fluxes, 4th order
6746
6747 j_loop_y_flux_4 : DO j = j_start, j_end+1
6748
6749 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6750
6751 DO k=kts,ktf
6752 DO i = i_start, i_end
6753
6754 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6755 mu = 0.5*(mut(i,j)+mut(i,j-1))
6756 vel = rv(i,k,j)
6757 cr = vel*dt/dy/mu
6758 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6759
6760 fqy( i, k, j ) = vel*flux4( field(i,k,j-2), field(i,k,j-1), &
6761 field(i,k,j ), field(i,k,j+1), vel )
6762
6763 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6764
6765 ENDDO
6766 ENDDO
6767
6768 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
6769
6770 DO k=kts,ktf
6771 DO i = i_start, i_end
6772
6773 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6774 mu = 0.5*(mut(i,j)+mut(i,j-1))
6775 vel = rv(i,k,j)
6776 cr = vel*dt/dy/mu
6777 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6778
6779 fqy(i,k, j) = 0.5*rv(i,k,j)* &
6780 (field(i,k,j)+field(i,k,j-1))
6781
6782 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6783
6784 ENDDO
6785 ENDDO
6786
6787 ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary
6788
6789 DO k=kts,ktf
6790 DO i = i_start, i_end
6791
6792 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6793 mu = 0.5*(mut(i,j)+mut(i,j-1))
6794 vel = rv(i,k,j)
6795 cr = vel*dt/dy/mu
6796 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6797
6798 fqy(i, k, j ) = 0.5*rv(i,k,j)* &
6799 (field(i,k,j)+field(i,k,j-1))
6800 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6801
6802 ENDDO
6803 ENDDO
6804
6805 ENDIF
6806
6807 ENDDO j_loop_y_flux_4
6808
6809 ! next, x flux
6810
6811 !-- these bounds are for periodic and sym conditions
6812
6813 i_start = its-1
6814 i_end = MIN(ite,ide-1)+1
6815 i_start_f = i_start
6816 i_end_f = i_end+1
6817
6818 j_start = jts-1
6819 j_end = MIN(jte,jde-1)+1
6820
6821 !-- modify loop bounds for open and specified b.c
6822
6823 IF(degrade_ys) j_start = jts
6824 IF(degrade_ye) j_end = MIN(jte,jde-1)
6825
6826 IF(degrade_xs) then
6827 i_start = MAX(ids+1,its)
6828 i_start_f = i_start+1
6829 ENDIF
6830
6831 IF(degrade_xe) then
6832 i_end = MIN(ide-2,ite)
6833 i_end_f = ide-2
6834 ENDIF
6835
6836 ! compute fluxes
6837
6838 DO j = j_start, j_end
6839
6840 ! 4th order flux
6841
6842 DO k=kts,ktf
6843 DO i = i_start_f, i_end_f
6844
6845 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6846 mu = 0.5*(mut(i,j)+mut(i-1,j))
6847 vel = ru(i,k,j)
6848 cr = vel*dt/dx/mu
6849 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6850
6851 fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), &
6852 field(i ,k,j), field(i+1,k,j), vel )
6853 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6854
6855 ENDDO
6856 ENDDO
6857
6858 ! lower order fluxes close to boundaries (if not periodic or symmetric)
6859
6860 IF( degrade_xs ) THEN
6861 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
6862 i = ids+1
6863 DO k=kts,ktf
6864
6865 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6866 mu = 0.5*(mut(i,j)+mut(i-1,j))
6867 vel = ru(i,k,j)/mu
6868 cr = vel*dt/dx
6869 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6870
6871 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6872 *(field(i,k,j)+field(i-1,k,j))
6873
6874 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6875
6876 ENDDO
6877 ENDIF
6878 ENDIF
6879
6880 IF( degrade_xe ) THEN
6881 IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
6882 i = ide-1
6883 DO k=kts,ktf
6884 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
6885 mu = 0.5*(mut(i,j)+mut(i-1,j))
6886 vel = ru(i,k,j)
6887 cr = vel*dt/dx/mu
6888 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
6889 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6890 *(field(i,k,j)+field(i-1,k,j))
6891 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6892
6893 ENDDO
6894 ENDIF
6895 ENDIF
6896
6897 ENDDO ! enddo for outer J loop
6898
6899 !--- end of 4th order horizontal flux calculation
6900
6901 ELSE IF( horz_order == 3 ) THEN
6902
6903 IF( config_flags%periodic_x .or. &
6904 config_flags%symmetric_xs .or. &
6905 (its > ids+1) ) degrade_xs = .false.
6906 IF( config_flags%periodic_x .or. &
6907 config_flags%symmetric_xe .or. &
6908 (ite < ide-2) ) degrade_xe = .false.
6909 IF( config_flags%periodic_y .or. &
6910 config_flags%symmetric_ys .or. &
6911 (jts > jds+1) ) degrade_ys = .false.
6912 IF( config_flags%periodic_y .or. &
6913 config_flags%symmetric_ye .or. &
6914 (jte < jde-2) ) degrade_ye = .false.
6915
6916 !--------------- y - advection first
6917
6918 !-- y flux compute; these bounds are for periodic and sym b.c.
6919
6920 ktf=MIN(kte,kde-1)
6921 i_start = its-1
6922 i_end = MIN(ite,ide-1)+1
6923 j_start = jts-1
6924 j_end = MIN(jte,jde-1)+1
6925 j_start_f = j_start
6926 j_end_f = j_end+1
6927
6928 !-- modify loop bounds if open or specified
6929
6930 IF(degrade_xs) i_start = its
6931 IF(degrade_xe) i_end = MIN(ite,ide-1)
6932
6933 IF(degrade_ys) then
6934 j_start = MAX(jts,jds+1)
6935 j_start_f = jds+2
6936 ENDIF
6937
6938 IF(degrade_ye) then
6939 j_end = MIN(jte,jde-2)
6940 j_end_f = jde-2
6941 ENDIF
6942
6943 ! compute fluxes, 3rd order
6944
6945 j_loop_y_flux_3 : DO j = j_start, j_end+1
6946
6947 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6948
6949 DO k=kts,ktf
6950 DO i = i_start, i_end
6951
6952 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6953 mu = 0.5*(mut(i,j)+mut(i,j-1))
6954 vel = rv(i,k,j)
6955 cr = vel*dt/dy/mu
6956 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6957
6958 fqy( i, k, j ) = vel*flux3( field(i,k,j-2), field(i,k,j-1), &
6959 field(i,k,j ), field(i,k,j+1), vel )
6960
6961 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6962
6963 ENDDO
6964 ENDDO
6965
6966 ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary
6967
6968 DO k=kts,ktf
6969 DO i = i_start, i_end
6970
6971 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6972 mu = 0.5*(mut(i,j)+mut(i,j-1))
6973 vel = rv(i,k,j)
6974 cr = vel*dt/dy/mu
6975 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6976
6977 fqy(i,k, j) = 0.5*rv(i,k,j)* &
6978 (field(i,k,j)+field(i,k,j-1))
6979
6980 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6981
6982 ENDDO
6983 ENDDO
6984
6985 ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary
6986
6987 DO k=kts,ktf
6988 DO i = i_start, i_end
6989
6990 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
6991 mu = 0.5*(mut(i,j)+mut(i,j-1))
6992 vel = rv(i,k,j)
6993 cr = vel*dt/dy/mu
6994 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
6995
6996 fqy(i, k, j ) = 0.5*rv(i,k,j)* &
6997 (field(i,k,j)+field(i,k,j-1))
6998 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6999
7000 ENDDO
7001 ENDDO
7002
7003 ENDIF
7004
7005 ENDDO j_loop_y_flux_3
7006
7007 ! next, x flux
7008
7009 !-- these bounds are for periodic and sym conditions
7010
7011 i_start = its-1
7012 i_end = MIN(ite,ide-1)+1
7013 i_start_f = i_start
7014 i_end_f = i_end+1
7015
7016 j_start = jts-1
7017 j_end = MIN(jte,jde-1)+1
7018
7019 !-- modify loop bounds for open and specified b.c
7020
7021 IF(degrade_ys) j_start = jts
7022 IF(degrade_ye) j_end = MIN(jte,jde-1)
7023
7024 IF(degrade_xs) then
7025 i_start = MAX(ids+1,its)
7026 i_start_f = i_start+1
7027 ENDIF
7028
7029 IF(degrade_xe) then
7030 i_end = MIN(ide-2,ite)
7031 i_end_f = ide-2
7032 ENDIF
7033
7034 ! compute fluxes
7035
7036 DO j = j_start, j_end
7037
7038 ! 4th order flux
7039
7040 DO k=kts,ktf
7041 DO i = i_start_f, i_end_f
7042
7043 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
7044 mu = 0.5*(mut(i,j)+mut(i-1,j))
7045 vel = ru(i,k,j)
7046 cr = vel*dt/dx/mu
7047 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
7048
7049 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), &
7050 field(i ,k,j), field(i+1,k,j), vel )
7051 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7052
7053 ENDDO
7054 ENDDO
7055
7056 ! lower order fluxes close to boundaries (if not periodic or symmetric)
7057
7058 IF( degrade_xs ) THEN
7059
7060 IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
7061 i = ids+1
7062 DO k=kts,ktf
7063
7064 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
7065 mu = 0.5*(mut(i,j)+mut(i-1,j))
7066 vel = ru(i,k,j)/mu
7067 cr = vel*dt/dx
7068 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
7069
7070 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
7071 *(field(i,k,j)+field(i-1,k,j))
7072
7073 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7074
7075 ENDDO
7076 ENDIF
7077 ENDIF
7078
7079 IF( degrade_xe ) THEN
7080 IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
7081 i = ide-1
7082 DO k=kts,ktf
7083 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
7084 mu = 0.5*(mut(i,j)+mut(i-1,j))
7085 vel = ru(i,k,j)
7086 cr = vel*dt/dx/mu
7087 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
7088 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
7089 *(field(i,k,j)+field(i-1,k,j))
7090 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7091
7092 ENDDO
7093 ENDIF
7094 ENDIF
7095
7096 ENDDO ! enddo for outer J loop
7097
7098 !--- end of 3rd order horizontal flux calculation
7099
7100
7101 ELSE IF( horz_order == 2 ) THEN
7102
7103 IF( config_flags%periodic_x .or. &
7104 config_flags%symmetric_xs .or. &
7105 (its > ids) ) degrade_xs = .false.
7106 IF( config_flags%periodic_x .or. &
7107 config_flags%symmetric_xe .or. &
7108 (ite < ide-1) ) degrade_xe = .false.
7109 IF( config_flags%periodic_y .or. &
7110 config_flags%symmetric_ys .or. &
7111 (jts > jds) ) degrade_ys = .false.
7112 IF( config_flags%periodic_y .or. &
7113 config_flags%symmetric_ye .or. &
7114 (jte < jde-1) ) degrade_ye = .false.
7115
7116 !-- y flux compute; these bounds are for periodic and sym b.c.
7117
7118 ktf=MIN(kte,kde-1)
7119 i_start = its-1
7120 i_end = MIN(ite,ide-1)+1
7121 j_start = jts-1
7122 j_end = MIN(jte,jde-1)+1
7123
7124 !-- modify loop bounds if open or specified
7125
7126 IF(degrade_xs) i_start = its
7127 IF(degrade_xe) i_end = MIN(ite,ide-1)
7128 IF(degrade_ys) j_start = MAX(jts,jds+1)
7129 IF(degrade_ye) j_end = MIN(jte,jde-2)
7130
7131 ! compute fluxes, 2nd order, y flux
7132
7133 DO j = j_start, j_end+1
7134 DO k=kts,ktf
7135 DO i = i_start, i_end
7136 dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy
7137 mu = 0.5*(mut(i,j)+mut(i,j-1))
7138 vel = rv(i,k,j)
7139 cr = vel*dt/dy/mu
7140 fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr)
7141
7142 fqy(i,k, j) = 0.5*rv(i,k,j)* &
7143 (field(i,k,j)+field(i,k,j-1))
7144
7145 fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7146 ENDDO
7147 ENDDO
7148 ENDDO
7149
7150 ! next, x flux
7151
7152 DO j = j_start, j_end
7153 DO k=kts,ktf
7154 DO i = i_start, i_end+1
7155 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
7156 mu = 0.5*(mut(i,j)+mut(i-1,j))
7157 vel = ru(i,k,j)
7158 cr = vel*dt/dx/mu
7159 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr)
7160 fqx( i,k,j ) = 0.5*ru(i,k,j)* &
7161 (field(i,k,j)+field(i-1,k,j))
7162
7163 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7164 ENDDO
7165 ENDDO
7166 ENDDO
7167
7168 !--- end of 2nd order horizontal flux calculation
7169
7170 ELSE
7171
7172 WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order
7173 CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
7174
7175 ENDIF horizontal_order_test
7176
7177 ! pick up the rest of the horizontal radiation boundary conditions.
7178 ! (these are the computations that don't require 'cb'.
7179 ! first, set to index ranges
7180
7181 i_start = its
7182 i_end = MIN(ite,ide-1)
7183 j_start = jts
7184 j_end = MIN(jte,jde-1)
7185
7186 ! compute x (u) conditions for v, w, or scalar
7187
7188 IF( (config_flags%open_xs) .and. (its == ids) ) THEN
7189
7190 DO j = j_start, j_end
7191 DO k = kts, ktf
7192 ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
7193 tendency(its,k,j) = tendency(its,k,j) &
7194 - rdx*( &
7195 ub*( field_old(its+1,k,j) &
7196 - field_old(its ,k,j) ) + &
7197 field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j)) &
7198 )
7199 ENDDO
7200 ENDDO
7201
7202 ENDIF
7203
7204 IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
7205
7206 DO j = j_start, j_end
7207 DO k = kts, ktf
7208 ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
7209 tendency(i_end,k,j) = tendency(i_end,k,j) &
7210 - rdx*( &
7211 ub*( field_old(i_end ,k,j) &
7212 - field_old(i_end-1,k,j) ) + &
7213 field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j)) &
7214 )
7215 ENDDO
7216 ENDDO
7217
7218 ENDIF
7219
7220 IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
7221
7222 DO i = i_start, i_end
7223 DO k = kts, ktf
7224 vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
7225 tendency(i,k,jts) = tendency(i,k,jts) &
7226 - rdy*( &
7227 vb*( field_old(i,k,jts+1) &
7228 - field_old(i,k,jts ) ) + &
7229 field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts)) &
7230 )
7231 ENDDO
7232 ENDDO
7233
7234 ENDIF
7235
7236 IF( (config_flags%open_ye) .and. (jte == jde)) THEN
7237
7238 DO i = i_start, i_end
7239 DO k = kts, ktf
7240 vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
7241 tendency(i,k,j_end) = tendency(i,k,j_end) &
7242 - rdy*( &
7243 vb*( field_old(i,k,j_end ) &
7244 - field_old(i,k,j_end-1) ) + &
7245 field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1)) &
7246 )
7247 ENDDO
7248 ENDDO
7249
7250 ENDIF
7251
7252 IF( (config_flags%polar) .and. (jts == jds) ) THEN
7253
7254 ! Assuming rv(i,k,jds) = 0.
7255 DO i = i_start, i_end
7256 DO k = kts, ktf
7257 vb = MIN( 0.5*rv(i,k,jts+1), 0. )
7258 tendency(i,k,jts) = tendency(i,k,jts) &
7259 - rdy*( &
7260 vb*( field_old(i,k,jts+1) &
7261 - field_old(i,k,jts ) ) + &
7262 field(i,k,jts)*rv(i,k,jts+1) &
7263 )
7264 ENDDO
7265 ENDDO
7266
7267 ENDIF
7268
7269 IF( (config_flags%polar) .and. (jte == jde)) THEN
7270
7271 ! Assuming rv(i,k,jde) = 0.
7272 DO i = i_start, i_end
7273 DO k = kts, ktf
7274 vb = MAX( 0.5*rv(i,k,jte-1), 0. )
7275 tendency(i,k,j_end) = tendency(i,k,j_end) &
7276 - rdy*( &
7277 vb*( field_old(i,k,j_end ) &
7278 - field_old(i,k,j_end-1) ) + &
7279 field(i,k,j_end)*(-rv(i,k,jte-1)) &
7280 )
7281 ENDDO
7282 ENDDO
7283
7284 ENDIF
7285
7286 !-------------------- vertical advection
7287
7288 !-- loop bounds for periodic or sym conditions
7289
7290 i_start = its-1
7291 i_end = MIN(ite,ide-1)+1
7292 j_start = jts-1
7293 j_end = MIN(jte,jde-1)+1
7294
7295 !-- loop bounds for open or specified conditions
7296
7297 IF(degrade_xs) i_start = its
7298 IF(degrade_xe) i_end = MIN(ite,ide-1)
7299 IF(degrade_ys) j_start = jts
7300 IF(degrade_ye) j_end = MIN(jte,jde-1)
7301
7302 vert_order_test : IF (vert_order == 6) THEN
7303
7304 DO j = j_start, j_end
7305
7306 DO i = i_start, i_end
7307 fqz(i,1,j) = 0.
7308 fqzl(i,1,j) = 0.
7309 fqz(i,kde,j) = 0.
7310 fqzl(i,kde,j) = 0.
7311 ENDDO
7312
7313 DO k=kts+3,ktf-2
7314 DO i = i_start, i_end
7315 dz = 2./(rdzw(k)+rdzw(k-1))
7316 mu = 0.5*(mut(i,j)+mut(i,j))
7317 vel = rom(i,k,j)
7318 cr = vel*dt/dz/mu
7319 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7320
7321 fqz(i,k,j) = vel*flux6( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), &
7322 field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel )
7323 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7324 ENDDO
7325 ENDDO
7326
7327 DO i = i_start, i_end
7328
7329 k=kts+1
7330 dz = 2./(rdzw(k)+rdzw(k-1))
7331 mu = 0.5*(mut(i,j)+mut(i,j))
7332 vel = rom(i,k,j)
7333 cr = vel*dt/dz/mu
7334 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7335 fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7336 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7337
7338 k=kts+2
7339 dz = 2./(rdzw(k)+rdzw(k-1))
7340 mu = 0.5*(mut(i,j)+mut(i,j))
7341 vel = rom(i,k,j)
7342 cr = vel*dt/dz/mu
7343 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7344
7345 fqz(i,k,j) = vel*flux4( &
7346 field(i,k-2,j), field(i,k-1,j), &
7347 field(i,k ,j), field(i,k+1,j), -vel )
7348 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7349
7350 k=ktf-1
7351 dz = 2./(rdzw(k)+rdzw(k-1))
7352 mu = 0.5*(mut(i,j)+mut(i,j))
7353 vel = rom(i,k,j)
7354 cr = vel*dt/dz/mu
7355 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7356
7357 fqz(i,k,j) = vel*flux4( &
7358 field(i,k-2,j), field(i,k-1,j), &
7359 field(i,k ,j), field(i,k+1,j), -vel )
7360 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7361
7362 k=ktf
7363 dz = 2./(rdzw(k)+rdzw(k-1))
7364 mu = 0.5*(mut(i,j)+mut(i,j))
7365 vel = rom(i,k,j)
7366 cr = vel*dt/dz/mu
7367 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7368 fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7369 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7370
7371 ENDDO
7372
7373 ENDDO
7374
7375 ELSE IF (vert_order == 5) THEN
7376
7377 DO j = j_start, j_end
7378
7379 DO i = i_start, i_end
7380 fqz(i,1,j) = 0.
7381 fqzl(i,1,j) = 0.
7382 fqz(i,kde,j) = 0.
7383 fqzl(i,kde,j) = 0.
7384 ENDDO
7385
7386 DO k=kts+3,ktf-2
7387 DO i = i_start, i_end
7388 dz = 2./(rdzw(k)+rdzw(k-1))
7389 mu = 0.5*(mut(i,j)+mut(i,j))
7390 vel = rom(i,k,j)
7391 cr = vel*dt/dz/mu
7392 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7393
7394 fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), &
7395 field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel )
7396 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7397 ENDDO
7398 ENDDO
7399
7400 DO i = i_start, i_end
7401
7402 k=kts+1
7403 dz = 2./(rdzw(k)+rdzw(k-1))
7404 mu = 0.5*(mut(i,j)+mut(i,j))
7405 vel = rom(i,k,j)
7406 cr = vel*dt/dz/mu
7407 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7408 fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7409 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7410
7411 k=kts+2
7412 dz = 2./(rdzw(k)+rdzw(k-1))
7413 mu = 0.5*(mut(i,j)+mut(i,j))
7414 vel = rom(i,k,j)
7415 cr = vel*dt/dz/mu
7416 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7417
7418 fqz(i,k,j) = vel*flux3( &
7419 field(i,k-2,j), field(i,k-1,j), &
7420 field(i,k ,j), field(i,k+1,j), -vel )
7421 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7422
7423 k=ktf-1
7424 dz = 2./(rdzw(k)+rdzw(k-1))
7425 mu = 0.5*(mut(i,j)+mut(i,j))
7426 vel = rom(i,k,j)
7427 cr = vel*dt/dz/mu
7428 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7429
7430 fqz(i,k,j) = vel*flux3( &
7431 field(i,k-2,j), field(i,k-1,j), &
7432 field(i,k ,j), field(i,k+1,j), -vel )
7433 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7434
7435 k=ktf
7436 dz = 2./(rdzw(k)+rdzw(k-1))
7437 mu = 0.5*(mut(i,j)+mut(i,j))
7438 vel = rom(i,k,j)
7439 cr = vel*dt/dz/mu
7440 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7441 fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7442 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7443
7444 ENDDO
7445
7446 ENDDO
7447
7448 ELSE IF (vert_order == 4) THEN
7449
7450 DO j = j_start, j_end
7451
7452 DO i = i_start, i_end
7453 fqz(i,1,j) = 0.
7454 fqzl(i,1,j) = 0.
7455 fqz(i,kde,j) = 0.
7456 fqzl(i,kde,j) = 0.
7457 ENDDO
7458
7459 DO k=kts+2,ktf-1
7460 DO i = i_start, i_end
7461
7462 dz = 2./(rdzw(k)+rdzw(k-1))
7463 mu = 0.5*(mut(i,j)+mut(i,j))
7464 vel = rom(i,k,j)
7465 cr = vel*dt/dz/mu
7466 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7467
7468 fqz(i,k,j) = vel*flux4( &
7469 field(i,k-2,j), field(i,k-1,j), &
7470 field(i,k ,j), field(i,k+1,j), -vel )
7471 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7472 ENDDO
7473 ENDDO
7474
7475 DO i = i_start, i_end
7476
7477 k=kts+1
7478 dz = 2./(rdzw(k)+rdzw(k-1))
7479 mu = 0.5*(mut(i,j)+mut(i,j))
7480 vel = rom(i,k,j)
7481 cr = vel*dt/dz/mu
7482 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7483 fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7484 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7485
7486 k=ktf
7487 dz = 2./(rdzw(k)+rdzw(k-1))
7488 mu = 0.5*(mut(i,j)+mut(i,j))
7489 vel = rom(i,k,j)
7490 cr = vel*dt/dz/mu
7491 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7492 fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7493 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7494
7495 ENDDO
7496
7497 ENDDO
7498
7499 ELSE IF (vert_order == 3) THEN
7500
7501 DO j = j_start, j_end
7502
7503 DO i = i_start, i_end
7504 fqz(i,1,j) = 0.
7505 fqzl(i,1,j) = 0.
7506 fqz(i,kde,j) = 0.
7507 fqzl(i,kde,j) = 0.
7508 ENDDO
7509
7510 DO k=kts+2,ktf-1
7511 DO i = i_start, i_end
7512
7513 dz = 2./(rdzw(k)+rdzw(k-1))
7514 mu = 0.5*(mut(i,j)+mut(i,j))
7515 vel = rom(i,k,j)
7516 cr = vel*dt/dz/mu
7517 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7518
7519 fqz(i,k,j) = vel*flux3( &
7520 field(i,k-2,j), field(i,k-1,j), &
7521 field(i,k ,j), field(i,k+1,j), -vel )
7522 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7523 ENDDO
7524 ENDDO
7525
7526 DO i = i_start, i_end
7527
7528 k=kts+1
7529 dz = 2./(rdzw(k)+rdzw(k-1))
7530 mu = 0.5*(mut(i,j)+mut(i,j))
7531 vel = rom(i,k,j)
7532 cr = vel*dt/dz/mu
7533 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7534 fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7535 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7536
7537 k=ktf
7538 dz = 2./(rdzw(k)+rdzw(k-1))
7539 mu = 0.5*(mut(i,j)+mut(i,j))
7540 vel = rom(i,k,j)
7541 cr = vel*dt/dz/mu
7542 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7543 fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7544 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7545
7546 ENDDO
7547
7548 ENDDO
7549
7550 ELSE IF (vert_order == 2) THEN
7551
7552 DO j = j_start, j_end
7553
7554 DO i = i_start, i_end
7555 fqz(i,1,j) = 0.
7556 fqzl(i,1,j) = 0.
7557 fqz(i,kde,j) = 0.
7558 fqzl(i,kde,j) = 0.
7559 ENDDO
7560
7561 DO k=kts+1,ktf
7562 DO i = i_start, i_end
7563
7564 dz = 2./(rdzw(k)+rdzw(k-1))
7565 mu = 0.5*(mut(i,j)+mut(i,j))
7566 vel = rom(i,k,j)
7567 cr = vel*dt/dz/mu
7568 fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr)
7569 fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7570 fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7571
7572 ENDDO
7573 ENDDO
7574
7575 ENDDO
7576
7577 ELSE
7578
7579 WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
7580 CALL wrf_error_fatal ( wrf_err_message )
7581
7582 ENDIF vert_order_test
7583
7584 IF (pd_limit) THEN
7585
7586 ! positive definite filter
7587
7588 i_start = its-1
7589 i_end = MIN(ite,ide-1)+1
7590 j_start = jts-1
7591 j_end = MIN(jte,jde-1)+1
7592
7593 !-- loop bounds for open or specified conditions
7594
7595 IF(degrade_xs) i_start = its
7596 IF(degrade_xe) i_end = MIN(ite,ide-1)
7597 IF(degrade_ys) j_start = jts
7598 IF(degrade_ye) j_end = MIN(jte,jde-1)
7599
7600 IF(config_flags%specified .or. config_flags%nested) THEN
7601 IF (degrade_xs) i_start = MAX(its,ids+1)
7602 IF (degrade_xe) i_end = MIN(ite,ide-2)
7603 IF (degrade_ys) j_start = MAX(jts,jds+1)
7604 IF (degrade_ye) j_end = MIN(jte,jde-2)
7605 END IF
7606
7607 IF(config_flags%open_xs) THEN
7608 IF (degrade_xs) i_start = MAX(its,ids+1)
7609 END IF
7610 IF(config_flags%open_xe) THEN
7611 IF (degrade_xe) i_end = MIN(ite,ide-2)
7612 END IF
7613 IF(config_flags%open_ys) THEN
7614 IF (degrade_ys) j_start = MAX(jts,jds+1)
7615 END IF
7616 IF(config_flags%open_ye) THEN
7617 IF (degrade_ye) j_end = MIN(jte,jde-2)
7618 END IF
7619 ! ADT note:
7620 ! We don't want to change j_start and j_end
7621 ! for polar BC's since we want to calculate
7622 ! fluxes for directions other than y at the
7623 ! edge
7624
7625 !-- here is the limiter...
7626
7627 DO j=j_start, j_end
7628 DO k=kts, ktf
7629 DO i=i_start, i_end
7630
7631 ! ADT note:
7632 ! Since fq{x,y,z}l are based on coupled variables (ru,rv,rom)
7633 ! I'm guessing this "msft" here is to cancel those out in order
7634 ! to make these comparisons work..., ADT Eq. 48
7635 !ph_low = (mub(i,j)+mu_old(i,j))*field_old(i,k,j) &
7636 ! - dt*( msft(i,j)*( rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) &
7637 ! +rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) ) &
7638 ! +rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
7639 ph_low = (mub(i,j)+mu_old(i,j))*field_old(i,k,j) &
7640 - dt*( msfty(i,j)*rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) &
7641 +msftx(i,j)*rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) &
7642 +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
7643
7644 !flux_out = dt*(msft(i,j)*( rdx*( max(0.,fqx (i+1,k,j)) &
7645 ! -min(0.,fqx (i ,k,j)) ) &
7646 ! +rdy*( max(0.,fqy (i,k,j+1)) &
7647 ! -min(0.,fqy (i,k,j )) ) ) &
7648 ! +rdzw(k)*( min(0.,fqz (i,k+1,j)) &
7649 ! -max(0.,fqz (i,k ,j)) ) )
7650 flux_out = dt*( msfty(i,j)*rdx*( max(0.,fqx (i+1,k,j)) &
7651 -min(0.,fqx (i ,k,j)) ) &
7652 +msftx(i,j)*rdy*( max(0.,fqy (i,k,j+1)) &
7653 -min(0.,fqy (i,k,j )) ) &
7654 +msfty(i,j)*rdzw(k)*( min(0.,fqz (i,k+1,j)) &
7655 -max(0.,fqz (i,k ,j)) ) )
7656
7657 IF( flux_out .gt. ph_low ) THEN
7658
7659 scale = max(0.,ph_low/(flux_out+eps))
7660 IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j)
7661 IF( fqx (i ,k,j) .lt. 0.) fqx(i ,k,j) = scale*fqx(i ,k,j)
7662 IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1)
7663 IF( fqy (i,k,j ) .lt. 0.) fqy(i,k,j ) = scale*fqy(i,k,j )
7664 ! note: z flux is opposite sign in mass coordinate because
7665 ! vertical coordinate decreases with increasing k
7666 IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j)
7667 IF( fqz (i,k ,j) .gt. 0.) fqz(i,k ,j) = scale*fqz(i,k ,j)
7668
7669 END IF
7670
7671 ENDDO
7672 ENDDO
7673 ENDDO
7674
7675 END IF
7676
7677 ! add in the pd-limited flux divergence
7678
7679 i_start = its
7680 i_end = MIN(ite,ide-1)
7681 j_start = jts
7682 j_end = MIN(jte,jde-1)
7683
7684 DO j = j_start, j_end
7685 DO k = kts, ktf
7686 DO i = i_start, i_end
7687
7688 tendency (i,k,j) = tendency(i,k,j) &
7689 -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) &
7690 +fqzl(i,k+1,j)-fqzl(i,k,j))
7691
7692 ENDDO
7693 ENDDO
7694 ENDDO
7695
7696 ! x flux divergence
7697 !
7698 IF(degrade_xs) i_start = i_start + 1
7699 IF(degrade_xe) i_end = i_end - 1
7700
7701 DO j = j_start, j_end
7702 DO k = kts, ktf
7703 DO i = i_start, i_end
7704
7705 ! Un-"canceled" map scale factor, ADT Eq. 48
7706 tendency (i,k,j) = tendency(i,k,j) &
7707 - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) &
7708 +fqxl(i+1,k,j)-fqxl(i,k,j)) )
7709
7710 ENDDO
7711 ENDDO
7712 ENDDO
7713
7714 ! y flux divergence
7715 !
7716 i_start = its
7717 i_end = MIN(ite,ide-1)
7718 IF(degrade_ys) j_start = j_start + 1
7719 IF(degrade_ye) j_end = j_end - 1
7720
7721 DO j = j_start, j_end
7722 DO k = kts, ktf
7723 DO i = i_start, i_end
7724
7725 ! Un-"canceled" map scale factor, ADT Eq. 48
7726 tendency (i,k,j) = tendency(i,k,j) &
7727 - msfty(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) &
7728 +fqyl(i,k,j+1)-fqyl(i,k,j)) )
7729
7730 ENDDO
7731 ENDDO
7732 ENDDO
7733
7734 END SUBROUTINE advect_scalar_pd
7735
7736 !----------------------------------------------------------------
7737
7738 END MODULE module_advect_em
7739