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