Context Navigation

module_advect_em.F @ 2807

Last change on this file since 2807 was 196, checked in by aslmd, 15 years ago

MESOSCALE: an important change for tracer transport. attempted to incorporate into the model (based on v2.2) all the changes performed by the WRF team in v3.1 about positive-definite + monotonic tracer transport. without the monotonic option, tracer transport behaves really badly when sharp gradients are involved. might be helpful in regional dust storm simulations to get rid of instabilities and negative values for tracers. see Wong et al. MWR 2009 or http://www.mmm.ucar.edu/wrf/users/docs/user_guide_V3/users_guide_chap5.htm

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

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

Download in other formats:

Original Format