Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_advect_em.F @ 3094

Last change on this file since 3094 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 239.5 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format