Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_ADVECTION.F @ 3094

Last change on this file since 3094 was 11, checked in by aslmd, 14 years ago
spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 126.9 KB

Line
1	!----------------------------------------------------------------------
2	!#define BIT_FOR_BIT
3	!----------------------------------------------------------------------
4	#include "nmm_loop_basemacros.h"
5	#include "nmm_loop_macros.h"
6	!----------------------------------------------------------------------
7	!
8	!NCEP_MESO:MODEL_LAYER: HORIZONTAL AND VERTICAL ADVECTION
9	!
10	!----------------------------------------------------------------------
11	!
12	MODULE MODULE_ADVECTION
13	!
14	!----------------------------------------------------------------------
15	USE MODULE_MODEL_CONSTANTS
16	USE MODULE_EXT_INTERNAL
17	!----------------------------------------------------------------------
18	#ifdef DM_PARALLEL
19	INCLUDE "mpif.h"
20	#endif
21	!----------------------------------------------------------------------
22	!
23	REAL,PARAMETER :: FF2=-0.64813,FF3=0.24520,FF4=-0.12189
24	REAL,PARAMETER :: FFC=1.533,FBC=1.-FFC
25	REAL :: CONSERVE_MIN=0.9,CONSERVE_MAX=1.1
26	!
27	!----------------------------------------------------------------------
28	!*** CRANK-NICHOLSON OFF-CENTER WEIGHTS FOR CURRENT AND FUTURE
29	!*** TIME LEVELS.
30	!-----------------------------------------------------------------------
31	!
32	REAL,PARAMETER :: WGT1=0.90
33	REAL,PARAMETER :: WGT2=2.-WGT1
34	!
35	!*** FOR CRANK_NICHOLSON CHECK ONLY.
36	!
37	INTEGER :: ITEST=47,JTEST=70
38	REAL :: ADTP,ADUP,ADVP,TTLO,TTUP,TULO,TUUP,TVLO,TVUP
39	!
40	!----------------------------------------------------------------------
41	CONTAINS
42	!
43	!***********************************************************************
44	SUBROUTINE ADVE(NTSD,DT,DETA1,DETA2,PDTOP &
45	& ,CURV,F,FAD,F4D,EM_LOC,EMT_LOC,EN,ENT,DX,DY &
46	& ,HTM,HBM2,VTM,VBM2,LMH,LMV &
47	& ,T,U,V,PDSLO,TOLD,UOLD,VOLD &
48	& ,PETDT,UPSTRM &
49	& ,FEW,FNS,FNE,FSE &
50	& ,ADT,ADU,ADV &
51	& ,N_IUP_H,N_IUP_V &
52	& ,N_IUP_ADH,N_IUP_ADV &
53	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
54	& ,IHE,IHW,IVE,IVW,INDX3_WRK &
55	& ,IDS,IDE,JDS,JDE,KDS,KDE &
56	& ,IMS,IME,JMS,JME,KMS,KME &
57	& ,ITS,ITE,JTS,JTE,KTS,KTE)
58	!***********************************************************************
59	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
60	! . . .
61	! SUBPROGRAM: ADVE HORIZONTAL AND VERTICAL ADVECTION
62	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 93-10-28
63	!
64	! ABSTRACT:
65	! ADVE CALCULATES THE CONTRIBUTION OF THE HORIZONTAL AND VERTICAL
66	! ADVECTION TO THE TENDENCIES OF TEMPERATURE AND WIND AND THEN
67	! UPDATES THOSE VARIABLES.
68	! THE JANJIC ADVECTION SCHEME FOR THE ARAKAWA E GRID IS USED
69	! FOR ALL VARIABLES INSIDE THE FIFTH ROW. AN UPSTREAM SCHEME
70	! IS USED ON ALL VARIABLES IN THE THIRD, FOURTH, AND FIFTH
71	! OUTERMOST ROWS. THE ADAMS-BASHFORTH TIME SCHEME IS USED.
72	!
73	! PROGRAM HISTORY LOG:
74	! 87-06-?? JANJIC - ORIGINATOR
75	! 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
76	! 96-03-28 BLACK - ADDED EXTERNAL EDGE
77	! 98-10-30 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
78	! 99-07- JANJIC - CONVERTED TO ADAMS-BASHFORTH SCHEME
79	! COMBINING HORIZONTAL AND VERTICAL ADVECTION
80	! 02-02-04 BLACK - ADDED VERTICAL CFL CHECK
81	! 02-02-05 BLACK - CONVERTED TO WRF FORMAT
82	! 02-08-29 MICHALAKES - CONDITIONAL COMPILATION OF MPI
83	! CONVERT TO GLOBAL INDEXING
84	! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
85	! 04-05-29 JANJIC,BLACK - CRANK-NICHOLSON VERTICAL ADVECTION
86	! 04-11-23 BLACK - THREADED
87	!
88	! USAGE: CALL ADVE FROM SUBROUTINE SOLVE_NMM
89	! INPUT ARGUMENT LIST:
90	!
91	! OUTPUT ARGUMENT LIST:
92	!
93	! OUTPUT FILES:
94	! NONE
95	!
96	! SUBPROGRAMS CALLED:
97	!
98	! UNIQUE: NONE
99	!
100	! LIBRARY: NONE
101	!
102	! ATTRIBUTES:
103	! LANGUAGE: FORTRAN 90
104	! MACHINE : IBM SP
105	!$$$
106	!***********************************************************************
107	!-----------------------------------------------------------------------
108	!
109	IMPLICIT NONE
110	!
111	!-----------------------------------------------------------------------
112	!
113	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
114	& ,IMS,IME,JMS,JME,KMS,KME &
115	& ,ITS,ITE,JTS,JTE,KTS,KTE
116	!
117	INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
118	INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
119	& ,N_IUP_ADH,N_IUP_ADV
120	INTEGER, DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
121	& ,IUP_ADH,IUP_ADV &
122	& ,LMH,LMV
123	!
124	!*** NMM_MAX_DIM is set in configure.wrf and must agree with
125	!*** the value of dimspec q in the Registry/Registry
126	!
127	INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
128	!
129	INTEGER,INTENT(IN) :: NTSD
130	!
131	REAL,INTENT(IN) :: DT,DY,EN,ENT,F4D,PDTOP
132	!
133	REAL,DIMENSION(NMM_MAX_DIM),INTENT(IN) :: EM_LOC,EMT_LOC
134	!
135	REAL,DIMENSION(KMS:KME),INTENT(IN) :: DETA1,DETA2
136	!
137	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CURV,DX,F,FAD,HBM2 &
138	& ,PDSLO,VBM2
139	!
140	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
141	!
142	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,VTM
143	!
144	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: T,TOLD &
145	& ,U,UOLD &
146	& ,V,VOLD
147	!
148	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: ADT,ADU &
149	& ,ADV &
150	& ,FEW,FNE &
151	& ,FNS,FSE
152	!
153	!-----------------------------------------------------------------------
154	!
155	!*** LOCAL VARIABLES
156	!
157	LOGICAL :: UPSTRM
158	!
159	INTEGER :: I,IEND,IFP,IFQ,II,IPQ,ISP,ISQ,ISTART &
160	& ,IUP_ADH_J,IVH,IVL &
161	& ,J,J1,JA,JAK,JEND,JGLOBAL,JJ,JKNT,JP2,JSTART &
162	& ,K,KNTI_ADH,KSTART,KSTOP,LMHK,LMVK &
163	& ,N,N_IUPH_J,N_IUPADH_J,N_IUPADV_J
164	!
165	INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB
166	!
167	INTEGER :: J0_P3,J0_P2,J0_P1,J0_00,J0_M1,J1_P2,J1_P1,J1_00,J1_M1 &
168	& ,J2_P1,J2_00,J2_M1,J3_P2,J3_P1,J3_00 &
169	& ,J4_P1,J4_00,J4_M1,J5_00,J5_M1,J6_P1,J6_00
170	!
171	INTEGER,DIMENSION(ITS-5:ITE+5) :: KBOT_CFL_T,KTOP_CFL_T &
172	& ,KBOT_CFL_U,KTOP_CFL_U &
173	& ,KBOT_CFL_V,KTOP_CFL_V
174	!
175	INTEGER,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: ISPA,ISQA
176	!
177	REAL :: ARRAY3_X,CFL,CFT,CFU,CFV,CMT,CMU,CMV &
178	& ,DPDE_P3,DTE,DTQ &
179	& ,F0,F1,F2,F3,FEW_00,FEW_P1,FNE_X,FNS_P1,FNS_X,FPP,FSE_X &
180	& ,HM,PDOP,PDOPU,PDOPV,PP &
181	& ,PVVLO,PVVLOU,PVVLOV,PVVUP,PVVUPU,PVVUPV &
182	& ,QP,RDP,RDPD,RDPDX,RDPDY,RDPU,RDPV &
183	& ,T_UP,TEMPA,TEMPB,TTA,TTB,U_UP,UDY_P1,UDY_X &
184	& ,VXD_X,VDX_P2,V_UP,VDX_X,VM,VTA,VUA,VVA &
185	& ,VVLO,VVLOU,VVLOV,VVUP,VVUPU,VVUPV
186	!
187	REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: ARRAY0,ARRAY1 &
188	& ,ARRAY2,ARRAY3 &
189	& ,VAD_TEND_T,VAD_TEND_U &
190	& ,VAD_TEND_V
191	!
192	REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: TEW,UEW,VEW
193	!
194	REAL,DIMENSION(KTS:KTE) :: CRT,CRU,CRV,DETA1_PDTOP &
195	& ,RCMT,RCMU,RCMV,RSTT,RSTU,RSTV,TN,UN &
196	& ,VAD_TNDX_T,VAD_TNDX_U,VAD_TNDX_V,VN
197	!
198	REAL,DIMENSION(ITS-5:ITE+5,-1:1) :: PETDTK
199	!
200	REAL,DIMENSION(ITS-5:ITE+5) :: TDN,UDN,VDN
201	!
202	!-----------------------------------------------------------------------
203	!
204	!*** TYPE 0 WORKING ARRAY
205	!
206	REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-3:3) :: DPDE
207	!
208	!*** TYPE 1 WORKING ARRAY
209	!
210	REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-2:2) :: TST,UDY,UST,VDX,VST
211	!
212	!*** TYPE 4 WORKING ARRAY
213	!
214	REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-1:1) :: TNS,UNS,VNS
215	!
216	!*** TYPE 5 WORKING ARRAY
217	!
218	REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-1:0) :: TNE,UNE,VNE
219	!
220	!*** TYPE 6 WORKING ARRAY
221	!
222	REAL,DIMENSION(ITS-5:ITE+5,KMS:KME, 0:1) :: TSE,USE,VSE
223	!-----------------------------------------------------------------------
224	!-----------------------------------------------------------------------
225	!***********************************************************************
226	!
227	! DPDE ----- 3
228	! \| J Increasing
229	! \|
230	! \| ^
231	! FNS ----- 2 \|
232	! \| \|
233	! \| \|
234	! \| \|
235	! VNS ----- 1 \|
236	! \|
237	! \|
238	! \|
239	! ADV ----- 0 ------> Current J
240	! \|
241	! \|
242	! \|
243	! VNS ----- -1
244	! \|
245	! \|
246	! \|
247	! FNS ----- -2
248	! \|
249	! \|
250	! \|
251	! DPDE ----- -3
252	!
253	!***********************************************************************
254	!-----------------------------------------------------------------------
255	!-----------------------------------------------------------------------
256	!
257	ISTART=MYIS_P2
258	IEND=MYIE_P2
259	IF(ITE==IDE)IEND=MYIE-3
260	!
261	DTQ=DT*0.25
262	DTE=DT(0.50.25)
263	!***
264	!*** INITIALIZE SOME WORKING ARRAYS TO ZERO
265	!***
266	DO K=KTS,KTE
267	DO I=ITS-5,ITE+5
268	TEW(I,K)=0.
269	UEW(I,K)=0.
270	VEW(I,K)=0.
271	ENDDO
272	ENDDO
273	!
274	!*** TYPE 0
275	!
276	DO N=-3,3
277	DO K=KTS,KTE
278	DO I=ITS-5,ITE+5
279	DPDE(I,K,N)=0.
280	ENDDO
281	ENDDO
282	ENDDO
283	!
284	!*** TYPE 1
285	!
286	DO N=-2,2
287	DO K=KTS,KTE
288	DO I=ITS-5,ITE+5
289	TST(I,K,N)=0.
290	UST(I,K,N)=0.
291	VST(I,K,N)=0.
292	UDY(I,K,N)=0.
293	VDX(I,K,N)=0.
294	ENDDO
295	ENDDO
296	ENDDO
297	!
298	!*** TYPES 5 AND 6
299	!
300	DO N=-1,0
301	DO K=KTS,KTE
302	DO I=ITS-5,ITE+5
303	TNE(I,K,N)=0.
304	TSE(I,K,N+1)=0.
305	UNE(I,K,N)=0.
306	USE(I,K,N+1)=0.
307	VNE(I,K,N)=0.
308	VSE(I,K,N+1)=0.
309	ENDDO
310	ENDDO
311	ENDDO
312	!-----------------------------------------------------------------------
313	!***
314	!*** PRECOMPUTE DETA1 TIMES PDTOP.
315	!***
316	!-----------------------------------------------------------------------
317	!
318	DO K=KTS,KTE
319	DETA1_PDTOP(K)=DETA1(K)*PDTOP
320	ENDDO
321	!-----------------------------------------------------------------------
322	!***
323	!*** WE NEED THE STARTING AND ENDING J FOR THIS TASK'S INTEGRATION
324	!***
325	!-----------------------------------------------------------------------
326	!
327	JSTART=MYJS2
328	JEND=MYJE2
329	!
330	!-----------------------------------------------------------------------
331	!
332	!*** START THE HORIZONTAL ADVECTION IN THE INITIAL SOUTHERN SLABS.
333	!
334	!-----------------------------------------------------------------------
335	!
336	DO J=-2,1
337	JJ=JSTART+J
338	!$omp parallel do &
339	!$omp& private(i,k)
340	DO K=KTS,KTE
341	DO I=MYIS_P4,MYIE_P4
342	TST(I,K,J)=T(I,K,JJ)FFC+TOLD(I,K,JJ)FBC
343	UST(I,K,J)=U(I,K,JJ)FFC+UOLD(I,K,JJ)FBC
344	VST(I,K,J)=V(I,K,JJ)FFC+VOLD(I,K,JJ)FBC
345	ENDDO
346	ENDDO
347	ENDDO
348	!
349	!-----------------------------------------------------------------------
350	!*** MARCH NORTHWARD THROUGH THE SOUTHERNMOST SLABS TO BEGIN
351	!*** FILLING THE MAIN WORKING ARRAYS WHICH ARE MULTI-DIMENSIONED
352	!*** IN J BECAUSE THEY ARE DIFFERENCED OR AVERAGED IN J.
353	!*** ONLY THE NORTHERNMOST OF EACH OF THE WORKING ARRAYS WILL BE
354	!*** FILLED IN THE PRIMARY INTEGRATION SECTION.
355	!-----------------------------------------------------------------------
356	!
357	J1=-3
358	IF(JTS==JDS)J1=-2 ! Cannot go 3 south from J=2 for south tasks
359	!
360	DO J=J1,2
361	JJ=JSTART+J
362	!
363	!$omp parallel do &
364	!$omp& private(i,k)
365	DO K=KTS,KTE
366	DO I=MYIS_P4,MYIE_P4
367	DPDE(I,K,J)=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,JJ)
368	ENDDO
369	ENDDO
370	!
371	ENDDO
372	!
373	!-----------------------------------------------------------------------
374	DO J=-2,1
375	JJ=JSTART+J
376	!
377	!$omp parallel do &
378	!$omp& private(i,k)
379	DO K=KTS,KTE
380	DO I=MYIS_P4,MYIE_P4
381	UDY(I,K,J)=U(I,K,JJ)*DY
382	VDX_X=V(I,K,JJ)*DX(I,JJ)
383	FNS(I,K,JJ)=VDX_X*(DPDE(I,K,J-1)+DPDE(I,K,J+1))
384	VDX(I,K,J)=VDX_X
385	ENDDO
386	ENDDO
387	!
388	ENDDO
389	!
390	!-----------------------------------------------------------------------
391	DO J=-2,0
392	JJ=JSTART+J
393	!
394	!$omp parallel do &
395	!$omp& private(i,k,tempa)
396	DO K=KTS,KTE
397	DO I=MYIS_P3,MYIE_P3
398	TEMPA=(UDY(I+IHE(JJ),K,J)+VDX(I+IHE(JJ),K,J)) &
399	& +(UDY(I,K,J+1) +VDX(I,K,J+1))
400	FNE(I,K,JJ)=TEMPA*(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J+1))
401	ENDDO
402	ENDDO
403	!
404	ENDDO
405	!
406	!-----------------------------------------------------------------------
407	DO J=-1,1
408	JJ=JSTART+J
409	!
410	!$omp parallel do &
411	!$omp& private(i,k,tempb)
412	DO K=KTS,KTE
413	DO I=MYIS_P3,MYIE_P3
414	TEMPB=(UDY(I+IHE(JJ),K,J)-VDX(I+IHE(JJ),K,J)) &
415	& +(UDY(I,K,J-1) -VDX(I,K,J-1))
416	FSE(I,K,JJ)=TEMPB*(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J-1))
417	ENDDO
418	ENDDO
419	!
420	ENDDO
421	!
422	!-----------------------------------------------------------------------
423	DO J=-1,0
424	JJ=JSTART+J
425	!
426	!$omp parallel do &
427	!$omp& private(fns_x,i,k,udy_x)
428	DO K=KTS,KTE
429	DO I=MYIS1_P3,MYIE1_P3
430	FNS_X=FNS(I,K,JJ)
431	TNS(I,K,J)=FNS_X*(TST(I,K,J+1)-TST(I,K,J-1))
432	!
433	UDY_X=U(I,K,JJ)*DY
434	FEW(I,K,JJ)=UDY_X*(DPDE(I+IVW(JJ),K,J)+DPDE(I+IVE(JJ),K,J))
435	ENDDO
436	ENDDO
437	!
438	!$omp parallel do &
439	!$omp& private(i,k)
440	DO K=KTS,KTE
441	DO I=MYIS1_P4,MYIE1_P4
442	UNS(I,K,J)=(FNS(I+IHW(JJ),K,JJ)+FNS(I+IHE(JJ),K,JJ)) &
443	& *(UST(I,K,J+1)-UST(I,K,J-1))
444	VNS(I,K,J)=(FNS(I,K,JJ-1)+FNS(I,K,JJ+1)) &
445	& *(VST(I,K,J+1)-VST(I,K,J-1))
446	ENDDO
447	ENDDO
448	!
449	ENDDO
450	!
451	!-----------------------------------------------------------------------
452	JJ=JSTART-1
453	!
454	!$omp parallel do &
455	!$omp& private(fne_x,fse_x,i,k)
456	DO K=KTS,KTE
457	DO I=MYIS1_P2,MYIE1_P2
458	FNE_X=FNE(I,K,JJ)
459	TNE(I,K,-1)=FNE_X*(TST(I+IHE(JJ),K,0)-TST(I,K,-1))
460	!
461	FSE_X=FSE(I,K,JJ+1)
462	TSE(I,K,0)=FSE_X*(TST(I+IHE(JJ+1),K,-1)-TST(I,K,0))
463	!
464	UNE(I,K,-1)=(FNE(I+IVW(JJ),K,JJ)+FNE(I+IVE(JJ),K,JJ)) &
465	& *(UST(I+IVE(JJ),K,0)-UST(I,K,-1))
466	USE(I,K,0)=(FSE(I+IVW(JJ+1),K,JJ+1)+FSE(I+IVE(JJ+1),K,JJ+1)) &
467	& *(UST(I+IVE(JJ+1),K,-1)-UST(I,K,0))
468	VNE(I,K,-1)=(FNE(I,K,JJ-1)+FNE(I,K,JJ+1)) &
469	& *(VST(I+IVE(JJ),K,0)-VST(I,K,-1))
470	VSE(I,K,0)=(FSE(I,K,JJ)+FSE(I,K,JJ+2)) &
471	& *(VST(I+IVE(JJ+1),K,-1)-VST(I,K,0))
472	ENDDO
473	ENDDO
474	!
475	JKNT=0
476	!
477	!-----------------------------------------------------------------------
478	!-----------------------------------------------------------------------
479	!
480	main_integration : DO J=JSTART,JEND
481	!
482	!-----------------------------------------------------------------------
483	!-----------------------------------------------------------------------
484	!***
485	!*** SET THE 3RD INDEX IN THE WORKING ARRAYS (SEE SUBROUTINE INIT
486	!*** AND PFDHT DIAGRAMS)
487	!***
488	!*** J[TYPE]_NN WHERE "TYPE" IS THE WORKING ARRAY TYPE SEEN IN THE
489	!*** LOCAL DECLARATION ABOVE (DEPENDENT UPON THE J EXTENT) AND
490	!*** NN IS THE NUMBER OF ROWS NORTH OF THE CENTRAL ROW WHOSE J IS
491	!*** THE CURRENT VALUE OF THE main_integration LOOP.
492	!*** (P3 denotes +3, M1 denotes -1, etc.)
493	!***
494	!-----------------------------------------------------------------------
495	!
496	JKNT=JKNT+1
497	!
498	J0_P3=INDX3_WRK(3,JKNT,0)
499	J0_P2=INDX3_WRK(2,JKNT,0)
500	J0_P1=INDX3_WRK(1,JKNT,0)
501	J0_00=INDX3_WRK(0,JKNT,0)
502	J0_M1=INDX3_WRK(-1,JKNT,0)
503	!
504	J1_P2=INDX3_WRK(2,JKNT,1)
505	J1_P1=INDX3_WRK(1,JKNT,1)
506	J1_00=INDX3_WRK(0,JKNT,1)
507	J1_M1=INDX3_WRK(-1,JKNT,1)
508	!
509	J2_P1=INDX3_WRK(1,JKNT,2)
510	J2_00=INDX3_WRK(0,JKNT,2)
511	J2_M1=INDX3_WRK(-1,JKNT,2)
512	!
513	J3_P2=INDX3_WRK(2,JKNT,3)
514	J3_P1=INDX3_WRK(1,JKNT,3)
515	J3_00=INDX3_WRK(0,JKNT,3)
516	!
517	J4_P1=INDX3_WRK(1,JKNT,4)
518	J4_00=INDX3_WRK(0,JKNT,4)
519	J4_M1=INDX3_WRK(-1,JKNT,4)
520	!
521	J5_00=INDX3_WRK(0,JKNT,5)
522	J5_M1=INDX3_WRK(-1,JKNT,5)
523	!
524	J6_P1=INDX3_WRK(1,JKNT,6)
525	J6_00=INDX3_WRK(0,JKNT,6)
526	!
527	MY_IS_GLB=1 ! make this a noop for global indexing
528	MY_IE_GLB=1 ! make this a noop for global indexing
529	MY_JS_GLB=1 ! make this a noop for global indexing
530	MY_JE_GLB=1 ! make this a noop for global indexing
531
532	!-----------------------------------------------------------------------
533	!
534	!$omp parallel do &
535	!$omp& private(dpde_p3,few_00,fne_x,fns_p1,fse_x,i,k,tempa,tempb &
536	!$omp& ,udy_p1,vdx_p2)
537	vertical_loop_1 : DO K=KTS,KTE
538	!
539	!-----------------------------------------------------------------------
540	!*** EXECUTE HORIZONTAL ADVECTION.
541	!-----------------------------------------------------------------------
542	!
543	DO I=MYIS_P4,MYIE_P4
544	TST(I,K,J1_P2)=T(I,K,J+2)FFC+TOLD(I,K,J+2)FBC
545	UST(I,K,J1_P2)=U(I,K,J+2)FFC+UOLD(I,K,J+2)FBC
546	VST(I,K,J1_P2)=V(I,K,J+2)FFC+VOLD(I,K,J+2)FBC
547	ENDDO
548	!
549	!-----------------------------------------------------------------------
550	!*** MASS FLUXES AND MASS POINT ADVECTION COMPONENTS
551	!-----------------------------------------------------------------------
552	!
553	DO I=MYIS_P4,MYIE_P4
554	!
555	!-----------------------------------------------------------------------
556	!*** THE NS AND EW FLUXES IN THE FOLLOWING LOOP ARE ON V POINTS
557	!*** FOR T.
558	!-----------------------------------------------------------------------
559	!
560	DPDE_P3=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,J+3)
561	DPDE(I,K,J0_P3)=DPDE_P3
562	!
563	!-----------------------------------------------------------------------
564	UDY(I,K,J1_P2)=U(I,K,J+2)*DY
565	VDX_P2=V(I,K,J+2)*DX(I,J+2)
566	VDX(I,K,J1_P2)=VDX_P2
567	FNS(I,K,J+2)=VDX_P2*(DPDE(I,K,J0_P1)+DPDE_P3)
568	ENDDO
569	!
570	!-----------------------------------------------------------------------
571	DO I=MYIS_P3,MYIE_P3
572	TEMPA=(UDY(I+IHE(J+1),K,J1_P1)+VDX(I+IHE(J+1),K,J1_P1)) &
573	& +(UDY(I,K,J1_P2) +VDX(I,K,J1_P2))
574	FNE(I,K,J+1)=TEMPA*(DPDE(I,K,J0_P1)+DPDE(I+IHE(J+1),K,J0_P2))
575	!
576	!-----------------------------------------------------------------------
577	TEMPB=(UDY(I+IHE(J+2),K,J1_P2)-VDX(I+IHE(J+2),K,J1_P2)) &
578	& +(UDY(I,K,J1_P1) -VDX(I,K,J1_P1))
579	FSE(I,K,J+2)=TEMPB*(DPDE(I,K,J0_P2)+DPDE(I+IHE(J),K,J0_P1))
580	!
581	!-----------------------------------------------------------------------
582	FNS_P1=FNS(I,K,J+1)
583	TNS(I,K,J4_P1)=FNS_P1*(TST(I,K,J1_P2)-TST(I,K,J1_00))
584	!
585	!-----------------------------------------------------------------------
586	UDY_P1=U(I,K,J+1)*DY
587	FEW(I,K,J+1)=UDY_P1*(DPDE(I+IVW(J+1),K,J0_P1) &
588	& +DPDE(I+IVE(J+1),K,J0_P1))
589	FEW_00=FEW(I,K,J)
590	TEW(I,K)=FEW_00*(TST(I+IVE(J),K,J1_00)-TST(I+IVW(J),K,J1_00))
591	!
592	!-----------------------------------------------------------------------
593	!*** THE NE AND SE FLUXES ARE ASSOCIATED WITH H POINTS
594	!*** (ACTUALLY JUST TO THE NE AND SE OF EACH H POINT).
595	!-----------------------------------------------------------------------
596	!
597	FNE_X=FNE(I,K,J)
598	TNE(I,K,J5_00)=FNE_X*(TST(I+IHE(J),K,J1_P1)-TST(I,K,J1_00))
599	!
600	FSE_X=FSE(I,K,J+1)
601	TSE(I,K,J6_P1)=FSE_X*(TST(I+IHE(J+1),K,J1_00)-TST(I,K,J1_P1))
602	ENDDO
603	!
604	!-----------------------------------------------------------------------
605	!*** CALCULATION OF MOMENTUM ADVECTION COMPONENTS
606	!-----------------------------------------------------------------------
607	!-----------------------------------------------------------------------
608	!*** THE NS AND EW FLUXES ARE ON H POINTS FOR U AND V.
609	!-----------------------------------------------------------------------
610	!
611	DO I=MYIS_P2,MYIE_P2
612	UEW(I,K)=(FEW(I+IHW(J),K,J)+FEW(I+IHE(J),K,J)) &
613	& *(UST(I+IHE(J),K,J1_00)-UST(I+IHW(J),K,J1_00))
614	UNS(I,K,J4_P1)=(FNS(I+IHW(J+1),K,J+1) &
615	& +FNS(I+IHE(J+1),K,J+1)) &
616	& *(UST(I,K,J1_P2)-UST(I,K,J1_00))
617	VEW(I,K)=(FEW(I,K,J-1)+FEW(I,K,J+1)) &
618	& *(VST(I+IHE(J),K,J1_00)-VST(I+IHW(J),K,J1_00))
619	VNS(I,K,J4_P1)=(FNS(I,K,J)+FNS(I,K,J+2)) &
620	& *(VST(I,K,J1_P2)-VST(I,K,J1_00))
621	!
622	!-----------------------------------------------------------------------
623	!*** THE FOLLOWING NE AND SE FLUXES ARE TIED TO V POINTS AND ARE
624	!*** LOCATED JUST TO THE NE AND SE OF THE GIVEN I,J.
625	!-----------------------------------------------------------------------
626	!
627	UNE(I,K,J5_00)=(FNE(I+IVW(J),K,J)+FNE(I+IVE(J),K,J)) &
628	& *(UST(I+IVE(J),K,J1_P1)-UST(I,K,J1_00))
629	USE(I,K,J6_P1)=(FSE(I+IVW(J+1),K,J+1) &
630	& +FSE(I+IVE(J+1),K,J+1)) &
631	& *(UST(I+IVE(J+1),K,J1_00)-UST(I,K,J1_P1))
632	VNE(I,K,J5_00)=(FNE(I,K,J-1)+FNE(I,K,J+1)) &
633	& *(VST(I+IVE(J),K,J1_P1)-VST(I,K,J1_00))
634	VSE(I,K,J6_P1)=(FSE(I,K,J)+FSE(I,K,J+2)) &
635	& *(VST(I+IVE(J+1),K,J1_00)-VST(I,K,J1_P1))
636	ENDDO
637	!
638	!-----------------------------------------------------------------------
639	!
640	ENDDO vertical_loop_1
641	!
642	!-----------------------------------------------------------------------
643	!*** COMPUTE THE ADVECTION TENDENCIES FOR T.
644	!*** THE AD ARRAYS ARE ON H POINTS.
645	!*** SKIP TO UPSTREAM IF THESE ROWS HAVE ONLY UPSTREAM POINTS.
646	!-----------------------------------------------------------------------
647	!
648
649	JGLOBAL=J+MY_JS_GLB-1
650	IF(JGLOBAL>=6.AND.JGLOBAL<=JDE-5)THEN
651	!
652	JJ=J+MY_JS_GLB-1 ! okay because MY_JS_GLB is 1
653	IF(ITS==IDS)ISTART=3+MOD(JJ,2) ! need to think about this
654	! more in terms of how to
655	! convert to global indexing
656	!
657	!$omp parallel do &
658	!$omp& private(i,k,rdpd)
659	DO K=KTS,KTE
660	DO I=ISTART,IEND
661	RDPD=1./DPDE(I,K,J0_00)
662	!
663	ADT(I,K,J)=(TEW(I+IHW(J),K)+TEW(I+IHE(J),K) &
664	& +TNS(I,K,J4_M1)+TNS(I,K,J4_P1) &
665	& +TNE(I+IHW(J),K,J5_M1)+TNE(I,K,J5_00) &
666	& +TSE(I,K,J6_00)+TSE(I+IHW(J),K,J6_P1)) &
667	& RDPDFAD(I,J)
668	!
669	ENDDO
670	ENDDO
671	!
672	!-----------------------------------------------------------------------
673	!*** COMPUTE THE ADVECTION TENDENCIES FOR U AND V.
674	!*** THE AD ARRAYS ARE ON VELOCITY POINTS.
675	!-----------------------------------------------------------------------
676	!
677	IF(ITS==IDS)ISTART=3+MOD(JJ+1,2)
678	!
679	!$omp parallel do &
680	!$omp& private(i,k,rdpdx,rdpdy)
681	DO K=KTS,KTE
682	DO I=ISTART,IEND
683	RDPDX=1./(DPDE(I+IVW(J),K,J0_00)+DPDE(I+IVE(J),K,J0_00))
684	RDPDY=1./(DPDE(I,K,J0_M1)+DPDE(I,K,J0_P1))
685	!
686	ADU(I,K,J)=(UEW(I+IVW(J),K)+UEW(I+IVE(J),K) &
687	& +UNS(I,K,J4_M1)+UNS(I,K,J4_P1) &
688	& +UNE(I+IVW(J),K,J5_M1)+UNE(I,K,J5_00) &
689	& +USE(I,K,J6_00)+USE(I+IVW(J),K,J6_P1)) &
690	& RDPDXFAD(I+IVW(J),J)
691	!
692	ADV(I,K,J)=(VEW(I+IVW(J),K)+VEW(I+IVE(J),K) &
693	& +VNS(I,K,J4_M1)+VNS(I,K,J4_P1) &
694	& +VNE(I+IVW(J),K,J5_M1)+VNE(I,K,J5_00) &
695	& +VSE(I,K,J6_00)+VSE(I+IVW(J),K,J6_P1)) &
696	& RDPDYFAD(I+IVW(J),J)
697	!
698	ENDDO
699	ENDDO
700	!
701	ENDIF
702	!
703	!-----------------------------------------------------------------------
704	!-----------------------------------------------------------------------
705	!
706	!*** END OF JANJIC HORIZONTAL ADVECTION
707	!
708	!-----------------------------------------------------------------------
709	!-----------------------------------------------------------------------
710	!*** UPSTREAM ADVECTION OF T, U, AND V
711	!-----------------------------------------------------------------------
712	!-----------------------------------------------------------------------
713	!
714	upstream : IF(UPSTRM)THEN
715	!
716	!-----------------------------------------------------------------------
717	!***
718	!*** COMPUTE UPSTREAM COMPUTATIONS ON THIS TASK'S ROWS.
719	!***
720	!-----------------------------------------------------------------------
721	!
722	N_IUPH_J=N_IUP_H(J) ! See explanation in INIT
723	!
724	!$omp parallel do &
725	!$omp& private(array3_x,i,k,pp,qp,tta,ttb)
726	DO K=KTS,KTE
727	!
728	DO II=0,N_IUPH_J-1
729	I=IUP_H(IMS+II,J)
730	TTA=EMT_LOC(J)*(UST(I,K,J1_M1)+UST(I+IHW(J),K,J1_00) &
731	& +UST(I+IHE(J),K,J1_00)+UST(I,K,J1_P1))
732	TTB=ENT *(VST(I,K,J1_M1)+VST(I+IHW(J),K,J1_00) &
733	& +VST(I+IHE(J),K,J1_00)+VST(I,K,J1_P1))
734	PP=-TTA-TTB
735	QP= TTA-TTB
736	!
737	IF(PP<0.)THEN
738	ISPA(I,K)=-1
739	ELSE
740	ISPA(I,K)= 1
741	ENDIF
742	!
743	IF(QP<0.)THEN
744	ISQA(I,K)=-1
745	ELSE
746	ISQA(I,K)= 1
747	ENDIF
748	!
749	PP=ABS(PP)
750	QP=ABS(QP)
751	ARRAY3_X=PP*QP
752	ARRAY0(I,K)=ARRAY3_X-PP-QP
753	ARRAY1(I,K)=PP-ARRAY3_X
754	ARRAY2(I,K)=QP-ARRAY3_X
755	ARRAY3(I,K)=ARRAY3_X
756	ENDDO
757	!
758	ENDDO
759	!-----------------------------------------------------------------------
760	!
761	N_IUPADH_J=N_IUP_ADH(J)
762	!
763	!$omp parallel do &
764	!$omp& private(f0,f1,f2,f3,i,ifp,ifq,ipq,isp,isq,iup_adh_j,k,knti_adh)
765	DO K=KTS,KTE
766	!
767	KNTI_ADH=1
768	IUP_ADH_J=IUP_ADH(IMS,J)
769	!
770	DO II=0,N_IUPH_J-1
771	I=IUP_H(IMS+II,J)
772	!
773	ISP=ISPA(I,K)
774	ISQ=ISQA(I,K)
775	IFP=(ISP-1)/2
776	IFQ=(-ISQ-1)/2
777	IPQ=(ISP-ISQ)/2
778	!
779	IF(HTM(I+IHE(J)+IFP,K,J+ISP) &
780	& *HTM(I+IHE(J)+IFQ,K,J+ISQ) &
781	& *HTM(I+IPQ,K,J+ISP+ISQ)>0.1)THEN
782	GO TO 150
783	ENDIF
784	!
785	IF(HTM(I+IHE(J)+IFP,K,J+ISP) &
786	& +HTM(I+IHE(J)+IFQ,K,J+ISQ) &
787	& +HTM(I+IPQ,K,J+ISP+ISQ)<0.1)THEN
788	!
789	T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)
790	T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)
791	T(I+IPQ,K,J+ISP+ISQ)=T(I,K,J)
792	!
793	ELSEIF &
794	& (HTM(I+IHE(J)+IFP,K,J+ISP)+HTM(I+IPQ,K,J+ISP+ISQ) &
795	& <0.99)THEN
796	!
797	T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)
798	T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFQ,K,J+ISQ)
799	!
800	ELSEIF &
801	& (HTM(I+IHE(J)+IFQ,K,J+ISQ)+HTM(I+IPQ,K,J+ISP+ISQ) &
802	<0.99)THEN
803	!
804	T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)
805	T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)
806	!
807	ELSEIF &
808	& (HTM(I+IHE(J)+IFP,K,J+ISP) &
809	& +HTM(I+IHE(J)+IFQ,K,J+ISQ)<0.99)THEN
810	T(I+IHE(J)+IFP,K,J+ISP)=0.5*(T(I,K,J) &
811	& +T(I+IPQ,K,J+ISP+ISQ))
812	T(I+IHE(J)+IFQ,K,J+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)
813	!
814	ELSEIF(HTM(I+IHE(J)+IFP,K,J+ISP)<0.99)THEN
815	T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J) &
816	& +T(I+IPQ,K,J+ISP+ISQ) &
817	& -T(I+IHE(J)+IFQ,K,J+ISQ)
818	!
819	ELSEIF(HTM(I+IHE(J)+IFQ,K,J+ISQ)<0.99)THEN
820	T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J) &
821	& +T(I+IPQ,K,J+ISP+ISQ) &
822	& -T(I+IHE(J)+IFP,K,J+ISP)
823	!
824	ELSE
825	T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFP,K,J+ISP) &
826	& +T(I+IHE(J)+IFQ,K,J+ISQ) &
827	& -T(I,K,J)
828	!
829	ENDIF
830	!
831	150 CONTINUE
832	!
833	!-----------------------------------------------------------------------
834	!
835	IF(I==IUP_ADH_J)THEN ! Update advection H tendencies
836	!
837	ISP=ISPA(I,K)
838	ISQ=ISQA(I,K)
839	IFP=(ISP-1)/2
840	IFQ=(-ISQ-1)/2
841	IPQ=(ISP-ISQ)/2
842	!
843	F0=ARRAY0(I,K)
844	F1=ARRAY1(I,K)
845	F2=ARRAY2(I,K)
846	F3=ARRAY3(I,K)
847	!
848	ADT(I,K,J)=F0*T(I,K,J) &
849	& +F1*T(I+IHE(J)+IFP,K,J+ISP) &
850	& +F2*T(I+IHE(J)+IFQ,K,J+ISQ) &
851	+F3*T(I+IPQ,K,J+ISP+ISQ)
852	!
853	!-----------------------------------------------------------------------
854	!
855	IF(KNTI_ADH<N_IUPADH_J)THEN
856	IUP_ADH_J=IUP_ADH(IMS+KNTI_ADH,J)
857	KNTI_ADH=KNTI_ADH+1
858	ENDIF
859	!
860	ENDIF ! End of advection H tendency IF block
861	!
862	ENDDO ! End of II loop
863	!
864	ENDDO ! End of K loop
865	!
866	!-----------------------------------------------------------------------
867	!-----------------------------------------------------------------------
868	!*** UPSTREAM ADVECTION OF VELOCITY COMPONENTS
869	!-----------------------------------------------------------------------
870	!-----------------------------------------------------------------------
871	!
872	N_IUPADV_J=N_IUP_ADV(J)
873	!
874	!$omp parallel do &
875	!$omp& private(f0,f1,f2,f3,i,ifp,ifq,ipq,isp,isq,k,pp,qp,tta,ttb)
876	DO K=KTS,KTE
877	!
878	DO II=0,N_IUPADV_J-1
879	I=IUP_ADV(IMS+II,J)
880	!
881	TTA=EM_LOC(J)*UST(I,K,J1_00)
882	TTB=EN *VST(I,K,J1_00)
883	PP=-TTA-TTB
884	QP=TTA-TTB
885	!
886	IF(PP<0.)THEN
887	ISP=-1
888	ELSE
889	ISP= 1
890	ENDIF
891	!
892	IF(QP<0.)THEN
893	ISQ=-1
894	ELSE
895	ISQ= 1
896	ENDIF
897	!
898	IFP=(ISP-1)/2
899	IFQ=(-ISQ-1)/2
900	IPQ=(ISP-ISQ)/2
901	PP=ABS(PP)
902	QP=ABS(QP)
903	F3=PP*QP
904	F0=F3-PP-QP
905	F1=PP-F3
906	F2=QP-F3
907	!
908	ADU(I,K,J)=F0*U(I,K,J) &
909	& +F1*U(I+IVE(J)+IFP,K,J+ISP) &
910	& +F2*U(I+IVE(J)+IFQ,K,J+ISQ) &
911	& +F3*U(I+IPQ,K,J+ISP+ISQ)
912	!
913	ADV(I,K,J)=F0*V(I,K,J) &
914	& +F1*V(I+IVE(J)+IFP,K,J+ISP) &
915	& +F2*V(I+IVE(J)+IFQ,K,J+ISQ) &
916	& +F3*V(I+IPQ,K,J+ISP+ISQ)
917	!
918	ENDDO
919	!
920	ENDDO ! End of K loop
921	!
922	!-----------------------------------------------------------------------
923	!
924	ENDIF upstream
925	!
926	!-----------------------------------------------------------------------
927	!-----------------------------------------------------------------------
928	!*** END OF THIS UPSTREAM REGION
929	!-----------------------------------------------------------------------
930	!-----------------------------------------------------------------------
931	!
932	!*** COMPUTE VERTICAL ADVECTION TENDENCIES USING CRANK-NICHOLSON.
933	!
934	!-----------------------------------------------------------------------
935	!*** FIRST THE TEMPERATURE
936	!-----------------------------------------------------------------------
937	!
938	!$omp parallel do &
939	!$omp& private(cft,cmt,crt,i,k,lmhk,pdop,pvvlo,pvvup,rcmt,rdp,rstt,tn &
940	!$omp& ,vvlo,vvup &
941	!!!$omp& ,adtp,ttlo,ttup &
942	!$omp& )
943	iloop_for_t: DO I=MYIS1,MYIE1
944	!
945	PDOP=PDSLO(I,J)
946	PVVLO=PETDT(I,KTE-1,J)*DTQ
947	VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
948	CMT=-VVLO*WGT2+1.
949	RCMT(KTE)=1./CMT
950	CRT(KTE)=VVLO*WGT2
951	RSTT(KTE)=-VVLOWGT1(T(I,KTE-1,J)-T(I,KTE,J))+T(I,KTE,J)
952	!
953	LMHK=KTE-LMH(I,J)+1
954	DO K=KTE-1,LMHK+1,-1
955	RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
956	PVVUP=PVVLO
957	PVVLO=PETDT(I,K-1,J)*DTQ
958	VVUP=PVVUP*RDP
959	VVLO=PVVLO*RDP
960	CFT=-VVUPWGT2RCMT(K+1)
961	CMT=-CRT(K+1)CFT+((VVUP-VVLO)WGT2+1.)
962	RCMT(K)=1./CMT
963	CRT(K)=VVLO*WGT2
964	RSTT(K)=-RSTT(K+1)*CFT+T(I,K,J) &
965	& -(T(I,K,J)-T(I,K+1,J))VVUPWGT1 &
966	& -(T(I,K-1,J)-T(I,K,J))VVLOWGT1
967	ENDDO
968	!
969	PVVUP=PVVLO
970	VVUP=PVVUP/(DETA1_PDTOP(LMHK)+DETA2(LMHK)*PDOP)
971	CFT=-VVUPWGT2RCMT(LMHK+1)
972	CMT=-CRT(LMHK+1)CFT+VVUPWGT2+1.
973	CRT(LMHK)=0.
974	RSTT(LMHK)=-(T(I,LMHK,J)-T(I,LMHK+1,J))VVUPWGT1 &
975	& -RSTT(LMHK+1)*CFT+T(I,LMHK,J)
976	TN(LMHK)=RSTT(LMHK)/CMT
977	VAD_TEND_T(I,LMHK)=TN(LMHK)-T(I,LMHK,J)
978	!
979	DO K=LMHK+1,KTE
980	TN(K)=(-CRT(K)TN(K-1)+RSTT(K))RCMT(K)
981	VAD_TEND_T(I,K)=TN(K)-T(I,K,J)
982	ENDDO
983	!
984	!-----------------------------------------------------------------------
985	!*** The following section is only for checking the implicit solution
986	!*** using back-substitution. Remove this section otherwise.
987	!-----------------------------------------------------------------------
988	! if(ntsd<=10.or.ntsd>=6000)then
989	! IF(I==ITEST.AND.J==JTEST)THEN
990	!!
991	! PVVLO=PETDT(I,KTE-1,J)DT0.25
992	! VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
993	! TTLO=VVLO*(T(I,KTE-1,J)-T(I,KTE,J) &
994	! & +TN(KTE-1)-TN(KTE))
995	! ADTP=TTLO+TN(KTE)-T(I,KTE,J)
996	! WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',KTE &
997	! &, ' ADTP=',ADTP
998	! WRITE(0,*)' T=',T(I,KTE,J),' TN=',TN(KTE) &
999	! &, ' VAD_TEND_T=',VAD_TEND_T(I,KTE)
1000	! WRITE(0,*)' '
1001	!!
1002	! DO K=KTE-1,LMHK+1,-1
1003	! RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
1004	! PVVUP=PVVLO
1005	! PVVLO=PETDT(I,K-1,J)DT0.25
1006	! VVUP=PVVUP*RDP
1007	! VVLO=PVVLO*RDP
1008	! TTUP=VVUP*(T(I,K,J)-T(I,K+1,J)+TN(K)-TN(K+1))
1009	! TTLO=VVLO*(T(I,K-1,J)-T(I,K,J)+TN(K-1)-TN(K))
1010	! ADTP=TTLO+TTUP+TN(K)-T(I,K,J)
1011	! WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',K &
1012	! &, ' ADTP=',ADTP
1013	! WRITE(0,*)' T=',T(I,K,J),' TN=',TN(K) &
1014	! &, ' VAD_TEND_T=',VAD_TEND_T(I,K)
1015	! WRITE(0,*)' '
1016	! ENDDO
1017	!!
1018	! IF(LMHK==KTS)THEN
1019	! PVVUP=PVVLO
1020	! VVUP=PVVUP/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOP)
1021	! TTUP=VVUP*(T(I,KTS,J)-T(I,KTS+1,J)+TN(KTS)-TN(KTS+1))
1022	! ADTP=TTUP+TN(KTS)-T(I,KTS,J)
1023	! WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',KTS &
1024	! &, ' ADTP=',ADTP
1025	! WRITE(0,*)' T=',T(I,KTS,J),' TN=',TN(KTS) &
1026	! &, ' VAD_TEND_T=',VAD_TEND_T(I,KTS)
1027	! WRITE(0,*)' '
1028	! ENDIF
1029	! ENDIF
1030	! endif
1031	!
1032	!-----------------------------------------------------------------------
1033	!*** End of check.
1034	!-----------------------------------------------------------------------
1035	!
1036	ENDDO iloop_for_t
1037	!
1038	!-----------------------------------------------------------------------
1039	!*** NOW VERTICAL ADVECTION OF WIND COMPONENTS
1040	!-----------------------------------------------------------------------
1041	!
1042	!$omp parallel do &
1043	!$omp& private(cfu,cfv,cmu,cmv,cru,crv,i,k,lmvk,pdopu,pdopv &
1044	!$omp& ,pvvlou,pvvlov,pvvupu,pvvupv,rcmu,rcmv,rdpu,rdpv &
1045	!$omp& ,rstu,rstv,un,vn,vvlou,vvlov,vvupu,vvupv &
1046	!!!$omp& ,adup,advp,tulo,tuup,tvlo,tvup &
1047	!$omp& )
1048	iloop_for_uv: DO I=MYIS1,MYIE1
1049	!
1050	PDOPU=(PDSLO(I+IVW(J),J)+PDSLO(I+IVE(J),J))*0.5
1051	PDOPV=(PDSLO(I,J-1)+PDSLO(I,J+1))*0.5
1052	PVVLOU=(PETDT(I+IVW(J),KTE-1,J)+PETDT(I+IVE(J),KTE-1,J))*DTE
1053	PVVLOV=(PETDT(I,KTE-1,J-1)+PETDT(I,KTE-1,J+1))*DTE
1054	VVLOU=PVVLOU/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPU)
1055	VVLOV=PVVLOV/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPV)
1056	CMU=-VVLOU*WGT2+1.
1057	CMV=-VVLOV*WGT2+1.
1058	RCMU(KTE)=1./CMU
1059	RCMV(KTE)=1./CMV
1060	CRU(KTE)=VVLOU*WGT2
1061	CRV(KTE)=VVLOV*WGT2
1062	RSTU(KTE)=-VVLOUWGT1(U(I,KTE-1,J)-U(I,KTE,J))+U(I,KTE,J)
1063	RSTV(KTE)=-VVLOVWGT1(V(I,KTE-1,J)-V(I,KTE,J))+V(I,KTE,J)
1064	!
1065	LMVK=KTE-LMV(I,J)+1
1066	DO K=KTE-1,LMVK+1,-1
1067	RDPU=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPU)
1068	RDPV=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPV)
1069	PVVUPU=PVVLOU
1070	PVVUPV=PVVLOV
1071	PVVLOU=(PETDT(I+IVW(J),K-1,J)+PETDT(I+IVE(J),K-1,J))*DTE
1072	PVVLOV=(PETDT(I,K-1,J-1)+PETDT(I,K-1,J+1))*DTE
1073	VVUPU=PVVUPU*RDPU
1074	VVUPV=PVVUPV*RDPV
1075	VVLOU=PVVLOU*RDPU
1076	VVLOV=PVVLOV*RDPV
1077	CFU=-VVUPUWGT2RCMU(K+1)
1078	CFV=-VVUPVWGT2RCMV(K+1)
1079	CMU=-CRU(K+1)CFU+(VVUPU-VVLOU)WGT2+1.
1080	CMV=-CRV(K+1)CFV+(VVUPV-VVLOV)WGT2+1.
1081	RCMU(K)=1./CMU
1082	RCMV(K)=1./CMV
1083	CRU(K)=VVLOU*WGT2
1084	CRV(K)=VVLOV*WGT2
1085	RSTU(K)=-RSTU(K+1)*CFU+U(I,K,J) &
1086	& -(U(I,K,J)-U(I,K+1,J))VVUPUWGT1 &
1087	& -(U(I,K-1,J)-U(I,K,J))VVLOUWGT1
1088	RSTV(K)=-RSTV(K+1)*CFV+V(I,K,J) &
1089	& -(V(I,K,J)-V(I,K+1,J))VVUPVWGT1 &
1090	& -(V(I,K-1,J)-V(I,K,J))VVLOVWGT1
1091	ENDDO
1092	!
1093	RDPU=1./(DETA1_PDTOP(LMVK)+DETA2(LMVK)*PDOPU)
1094	RDPV=1./(DETA1_PDTOP(LMVK)+DETA2(LMVK)*PDOPV)
1095	PVVUPU=PVVLOU
1096	PVVUPV=PVVLOV
1097	VVUPU=PVVUPU*RDPU
1098	VVUPV=PVVUPV*RDPV
1099	CFU=-VVUPUWGT2RCMU(LMVK+1)
1100	CFV=-VVUPVWGT2RCMV(LMVK+1)
1101	CMU=-CRU(LMVK+1)CFU+VVUPUWGT2+1.
1102	CMV=-CRV(LMVK+1)CFV+VVUPVWGT2+1.
1103	CRU(LMVK)=0.
1104	CRV(LMVK)=0.
1105	RSTU(LMVK)=-(U(I,LMVK,J)-U(I,LMVK+1,J))VVUPUWGT1 &
1106	& -RSTU(LMVK+1)*CFU+U(I,LMVK,J)
1107	RSTV(LMVK)=-(V(I,LMVK,J)-V(I,LMVK+1,J))VVUPVWGT1 &
1108	& -RSTV(LMVK+1)*CFV+V(I,LMVK,J)
1109	UN(LMVK)=RSTU(LMVK)/CMU
1110	VN(LMVK)=RSTV(LMVK)/CMV
1111	VAD_TEND_U(I,LMVK)=UN(LMVK)-U(I,LMVK,J)
1112	VAD_TEND_V(I,LMVK)=VN(LMVK)-V(I,LMVK,J)
1113	!
1114	DO K=LMVK+1,KTE
1115	UN(K)=(-CRU(K)UN(K-1)+RSTU(K))RCMU(K)
1116	VN(K)=(-CRV(K)VN(K-1)+RSTV(K))RCMV(K)
1117	VAD_TEND_U(I,K)=UN(K)-U(I,K,J)
1118	VAD_TEND_V(I,K)=VN(K)-V(I,K,J)
1119	ENDDO
1120	!
1121	!-----------------------------------------------------------------------
1122	!*** The following section is only for checking the implicit solution
1123	!*** using back-substitution. Remove this section otherwise.
1124	!-----------------------------------------------------------------------
1125	!
1126	! if(ntsd<=10.or.ntsd>=6000)then
1127	! IF(I==ITEST.AND.J==JTEST)THEN
1128	!!
1129	! PDOPU=(PDSLO(I+IVW(J),J)+PDSLO(I+IVE(J),J))*0.5
1130	! PDOPV=(PDSLO(I,J-1)+PDSLO(I,J+1))*0.5
1131	! PVVLOU=(PETDT(I+IVW(J),KTE-1,J) &
1132	! & +PETDT(I+IVE(J),KTE-1,J))*DTE
1133	! PVVLOV=(PETDT(I,KTE-1,J-1) &
1134	! & +PETDT(I,KTE-1,J+1))*DTE
1135	! VVLOU=PVVLOU/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPU)
1136	! VVLOV=PVVLOV/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPV)
1137	! TULO=VVLOU*(U(I,KTE-1,J)-U(I,KTE,J)+UN(KTE-1)-UN(KTE))
1138	! TVLO=VVLOV*(V(I,KTE-1,J)-V(I,KTE,J)+VN(KTE-1)-VN(KTE))
1139	! ADUP=TULO+UN(KTE)-U(I,KTE,J)
1140	! ADVP=TVLO+VN(KTE)-V(I,KTE,J)
1141	! WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',KTE &
1142	! &, ' ADUP=',ADUP,' ADVP=',ADVP
1143	! WRITE(0,*)' U=',U(I,KTE,J),' UN=',UN(KTE) &
1144	! &, ' VAD_TEND_U=',VAD_TEND_U(I,KTE) &
1145	! &, ' V=',V(I,KTE,J),' VN=',VN(KTE) &
1146	! &, ' VAD_TEND_V=',VAD_TEND_V(I,KTE)
1147	! WRITE(0,*)' '
1148	!!
1149	! DO K=KTE-1,LMVK+1,-1
1150	! RDPU=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPU)
1151	! RDPV=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPV)
1152	! PVVUPU=PVVLOU
1153	! PVVUPV=PVVLOV
1154	! PVVLOU=(PETDT(I+IVW(J),K-1,J) &
1155	! & +PETDT(I+IVE(J),K-1,J))*DTE
1156	! PVVLOV=(PETDT(I,K-1,J-1)+PETDT(I,K-1,J+1))*DTE
1157	! VVUPU=PVVUPU*RDPU
1158	! VVUPV=PVVUPV*RDPV
1159	! VVLOU=PVVLOU*RDPU
1160	! VVLOV=PVVLOV*RDPV
1161	! TUUP=VVUPU*(U(I,K,J)-U(I,K+1,J)+UN(K)-UN(K+1))
1162	! TVUP=VVUPV*(V(I,K,J)-V(I,K+1,J)+VN(K)-VN(K+1))
1163	! TULO=VVLOU*(U(I,K-1,J)-U(I,K,J)+UN(K-1)-UN(K))
1164	! TVLO=VVLOV*(V(I,K-1,J)-V(I,K,J)+VN(K-1)-VN(K))
1165	! ADUP=TUUP+TULO+UN(K)-U(I,K,J)
1166	! ADVP=TVUP+TVLO+VN(K)-V(I,K,J)
1167	! WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',K &
1168	! &, ' ADUP=',ADUP,' ADVP=',ADVP
1169	! WRITE(0,*)' U=',U(I,K,J),' UN=',UN(K) &
1170	! &, ' VAD_TEND_U=',VAD_TEND_U(I,K) &
1171	! &, ' V=',V(I,K,J),' VN=',VN(K) &
1172	! &, ' VAD_TEND_V=',VAD_TEND_V(I,K)
1173	! WRITE(0,*)' '
1174	! ENDDO
1175	!!
1176	! IF(LMVK==KTS)THEN
1177	! PVVUPU=PVVLOU
1178	! PVVUPV=PVVLOV
1179	! VVUPU=PVVUPU/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPU)
1180	! VVUPV=PVVUPV/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPV)
1181	! TUUP=VVUPU*(U(I,KTS,J)-U(I,KTS+1,J)+UN(KTS)-UN(KTS+1))
1182	! TVUP=VVUPV*(V(I,KTS,J)-V(I,KTS+1,J)+VN(KTS)-VN(KTS+1))
1183	! ADUP=TUUP+UN(KTS)-U(I,KTS,J)
1184	! ADVP=TVUP+VN(KTS)-V(I,KTS,J)
1185	! WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',KTS &
1186	! &, ' ADUP=',ADUP,' ADVP=',ADVP
1187	! WRITE(0,*)' U=',U(I,KTS,J),' UN=',UN(KTS) &
1188	! &, ' VAD_TEND_U=',VAD_TEND_U(I,KTS) &
1189	! &, ' V=',V(I,KTS,J),' VN=',VN(KTS) &
1190	! &, ' VAD_TEND_V=',VAD_TEND_V(I,KTS)
1191	! WRITE(0,*)' '
1192	! ENDIF
1193	! ENDIF
1194	! endif
1195	!
1196	!-----------------------------------------------------------------------
1197	!*** End of check.
1198	!-----------------------------------------------------------------------
1199	!
1200	ENDDO iloop_for_uv
1201	!
1202	!-----------------------------------------------------------------------
1203	!
1204	!*** NOW SUM THE VERTICAL AND HORIZONTAL TENDENCIES,
1205	!*** CURVATURE AND CORIOLIS TERMS
1206	!
1207	!-----------------------------------------------------------------------
1208	!
1209	!$omp parallel do &
1210	!$omp& private(fpp,hm,i,k,vm)
1211	DO K=KTS,KTE
1212	DO I=MYIS1,MYIE1
1213	HM=HTM(I,K,J)*HBM2(I,J)
1214	VM=VTM(I,K,J)*VBM2(I,J)
1215	ADT(I,K,J)=(VAD_TEND_T(I,K)+2.ADT(I,K,J))HM
1216	!
1217	FPP=CURV(I,J)2.UST(I,K,J1_00)+F(I,J)*2.
1218	ADU(I,K,J)=(VAD_TEND_U(I,K)+2.ADU(I,K,J)+VST(I,K,J1_00)FPP) &
1219	& *VM
1220	ADV(I,K,J)=(VAD_TEND_V(I,K)+2.ADV(I,K,J)-UST(I,K,J1_00)FPP) &
1221	& *VM
1222	ENDDO
1223	ENDDO
1224	!-----------------------------------------------------------------------
1225	!-----------------------------------------------------------------------
1226	!
1227	ENDDO main_integration
1228	!
1229	!-----------------------------------------------------------------------
1230	!-----------------------------------------------------------------------
1231	!
1232	!-----------------------------------------------------------------------
1233	!*** SAVE THE OLD VALUES FOR TIMESTEPPING
1234	!-----------------------------------------------------------------------
1235	!
1236	!$omp parallel do &
1237	!$omp& private(i,j,k)
1238	DO J=MYJS_P4,MYJE_P4
1239	DO K=KTS,KTE
1240	DO I=MYIS_P4,MYIE_P4
1241	TOLD(I,K,J)=T(I,K,J)
1242	UOLD(I,K,J)=U(I,K,J)
1243	VOLD(I,K,J)=V(I,K,J)
1244	ENDDO
1245	ENDDO
1246	ENDDO
1247	!
1248	!-----------------------------------------------------------------------
1249	!*** FINALLY UPDATE THE PROGNOSTIC VARIABLES
1250	!-----------------------------------------------------------------------
1251	!
1252	!$omp parallel do &
1253	!$omp& private(i,j,k)
1254	DO J=MYJS2,MYJE2
1255	DO K=KTS,KTE
1256	DO I=MYIS1,MYIE1
1257	T(I,K,J)=ADT(I,K,J)+T(I,K,J)
1258	U(I,K,J)=ADU(I,K,J)+U(I,K,J)
1259	V(I,K,J)=ADV(I,K,J)+V(I,K,J)
1260	ENDDO
1261	ENDDO
1262	ENDDO
1263	!-----------------------------------------------------------------------
1264	END SUBROUTINE ADVE
1265	!-----------------------------------------------------------------------
1266	!
1267	!***********************************************************************
1268	SUBROUTINE VAD2(NTSD,DT,IDTAD,DX,DY &
1269	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
1270	& ,HBM2,LMH &
1271	& ,Q,Q2,CWM,PETDT &
1272	& ,N_IUP_H,N_IUP_V &
1273	& ,N_IUP_ADH,N_IUP_ADV &
1274	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
1275	& ,IHE,IHW,IVE,IVW,INDX3_WRK &
1276	& ,IDS,IDE,JDS,JDE,KDS,KDE &
1277	& ,IMS,IME,JMS,JME,KMS,KME &
1278	& ,ITS,ITE,JTS,JTE,KTS,KTE)
1279	!***********************************************************************
1280	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
1281	! . . .
1282	! SUBPROGRAM: VAD2 VERTICAL ADVECTION OF H2O SUBSTANCE AND TKE
1283	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
1284	!
1285	! ABSTRACT:
1286	! VAD2 CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION
1287	! TO THE TENDENCIES OF WATER SUBSTANCE AND TKE AND THEN UPDATES
1288	! THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
1289	!
1290	! PROGRAM HISTORY LOG:
1291	! 96-07-19 JANJIC - ORIGINATOR
1292	! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
1293	! 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
1294	! 02-02-06 BLACK - CONVERTED TO WRF FORMAT
1295	! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
1296	! 04-11-23 BLACK - THREADED
1297	!
1298	! USAGE: CALL VAD2 FROM SUBROUTINE SOLVE_NMM
1299	! INPUT ARGUMENT LIST:
1300	!
1301	! OUTPUT ARGUMENT LIST
1302	!
1303	! OUTPUT FILES:
1304	! NONE
1305	! SUBPROGRAMS CALLED:
1306	!
1307	! UNIQUE: NONE
1308	!
1309	! LIBRARY: NONE
1310	!
1311	! ATTRIBUTES:
1312	! LANGUAGE: FORTRAN 90
1313	! MACHINE : IBM SP
1314	!$$$
1315	!***********************************************************************
1316	!----------------------------------------------------------------------
1317	!
1318	IMPLICIT NONE
1319	!
1320	!----------------------------------------------------------------------
1321	!
1322	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
1323	& ,IMS,IME,JMS,JME,KMS,KME &
1324	,ITS,ITE,JTS,JTE,KTS,KTE
1325	!
1326	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
1327	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
1328	& ,N_IUP_ADH,N_IUP_ADV
1329	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
1330	& ,IUP_ADH,IUP_ADV
1331	! NMM_MAX_DIM is set in configure.wrf and must agree with
1332	! the value of dimspec q in the Registry/Registry
1333	INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
1334	!
1335	INTEGER,INTENT(IN) :: IDTAD,NTSD
1336	!
1337	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
1338	!
1339	REAL,INTENT(IN) :: DT,DY,PDTOP
1340	!
1341	REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
1342	!
1343	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
1344	!
1345	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
1346	!
1347	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CWM,Q,Q2
1348	!
1349	!----------------------------------------------------------------------
1350	!
1351	!*** LOCAL VARIABLES
1352	!
1353	REAL,PARAMETER :: FF1=0.525
1354	!
1355	LOGICAL :: BOT,TOP
1356	!
1357	INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP
1358	!
1359	INTEGER,DIMENSION(KTS:KTE) :: LA
1360	!
1361	REAL*8 :: ADDT,AFRP,D2PQE,D2PQQ,D2PQW,DEP,DETAP,DPDN,DPUP,DQP &
1362	& ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ &
1363	& ,Q00,Q4P,QP,QP0 &
1364	& ,RFACEK,RFACQK,RFACWK,RFC,RR &
1365	& ,SUMNE,SUMNQ,SUMNW,SUMPE,SUMPQ,SUMPW &
1366	& ,W00,W4P,WP,WP0
1367	!
1368	REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4,PETDTK &
1369	& ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
1370	!
1371	!***********************************************************************
1372	!-----------------------------------------------------------------------
1373	!
1374	ADDT=REAL(IDTAD)*DT
1375	!
1376	!-----------------------------------------------------------------------
1377	!
1378	!$omp parallel do &
1379	!$omp& private(afr,afrp,bot,d2pqe,d2pqq,d2pqw,del,dep,detap,dpdn,dpup &
1380	!$omp& ,dql,dqp,dwl,dwp,e00,e3,e4,e4p,ep,ep0,haddt,i,j,k,koff &
1381	!$omp& ,la,lap,llap,petdtk,q00,q3,q4,q4p,qp,qp0,rfacek,rfacqk &
1382	!$omp& ,rfacwk,rfc,rr,sumne,sumnq,sumnw,sumpe,sumpq,sumpw,top &
1383	!$omp& ,w00,w3,w4,w4p,wp,wp0)
1384	main_integration : DO J=MYJS2,MYJE2
1385	!
1386	DO I=MYIS1_P1,MYIE1_P1
1387	!-----------------------------------------------------------------------
1388	KOFF=KTE-LMH(I,J)
1389	!
1390	E3(KTE)=Q2(I,KTE,J)*0.5
1391	!
1392	DO K=KTE-1,KOFF+1,-1
1393	E3(K)=MAX((Q2(I,K+1,J)+Q2(I,K,J))*0.5,EPSQ2)
1394	ENDDO
1395	!
1396	DO K=KOFF+1,KTE
1397	Q3(K)=MAX(Q(I,K,J),EPSQ)
1398	W3(K)=MAX(CWM(I,K,J),CLIMIT)
1399	E4(K)=E3(K)
1400	Q4(K)=Q3(K)
1401	W4(K)=W3(K)
1402	ENDDO
1403	!
1404	PETDTK(KTE)=PETDT(I,KTE-1,J)*0.5
1405	!
1406	DO K=KTE-1,KOFF+2,-1
1407	PETDTK(K)=(PETDT(I,K,J)+PETDT(I,K-1,J))*0.5
1408	ENDDO
1409	!
1410	PETDTK(KOFF+1)=PETDT(I,KOFF+1,J)*0.5
1411	!-----------------------------------------------------------------------
1412	HADDT=-ADDT*HBM2(I,J)
1413	!
1414	DO K=KTE,KOFF+1,-1
1415	RR=PETDTK(K)*HADDT
1416	!
1417	IF(RR<0.)THEN
1418	LAP=1
1419	ELSE
1420	LAP=-1
1421	ENDIF
1422	!
1423	LA(K)=LAP
1424	LLAP=K+LAP
1425	!
1426	TOP=.FALSE.
1427	BOT=.FALSE.
1428	!
1429	IF(LLAP>KOFF.AND.LLAP<KTE+1.AND.LAP/=0)THEN
1430	RR=ABS(RR/((AETA1(LLAP)-AETA1(K))*PDTOP &
1431	& +(AETA2(LLAP)-AETA2(K))*PDSL(I,J)))
1432	!
1433	AFR(K)=(((FF4RR+FF3)RR+FF2)RR+FF1)RR
1434	DQP=(Q3(LLAP)-Q3(K))*RR
1435	DWP=(W3(LLAP)-W3(K))*RR
1436	DEP=(E3(LLAP)-E3(K))*RR
1437	DQL(K)=DQP
1438	DWL(K)=DWP
1439	DEL(K)=DEP
1440	ELSE
1441	TOP=LLAP==KTE+1
1442	BOT=LLAP==KOFF
1443	!
1444	RR=0.
1445	AFR(K)=0.
1446	DQL(K)=0.
1447	DWL(K)=0.
1448	DEL(K)=0.
1449	ENDIF
1450	ENDDO
1451	!-----------------------------------------------------------------------
1452	IF(TOP)THEN
1453	IF(LA(KTE-1)>0)THEN
1454	RFC=(DETA1(KTE-1)PDTOP+DETA2(KTE-1)PDSL(I,J)) &
1455	& /(DETA1(KTE )PDTOP+DETA2(KTE )PDSL(I,J))
1456	DQL(KTE)=-DQL(KTE+1)*RFC
1457	DWL(KTE)=-DWL(KTE+1)*RFC
1458	DEL(KTE)=-DEL(KTE+1)*RFC
1459	ENDIF
1460	ENDIF
1461	!
1462	IF(BOT)THEN
1463	IF(LA(KOFF+2)<0)THEN
1464	RFC=(DETA1(KOFF+2)PDTOP+DETA2(KOFF+2)PDSL(I,J)) &
1465	& /(DETA1(KOFF+1)PDTOP+DETA2(KOFF+1)PDSL(I,J))
1466	DQL(KOFF+1)=-DQL(KOFF+2)*RFC
1467	DWL(KOFF+1)=-DWL(KOFF+2)*RFC
1468	DEL(KOFF+1)=-DEL(KOFF+2)*RFC
1469	ENDIF
1470	ENDIF
1471	!
1472	DO K=KOFF+1,KTE
1473	Q4(K)=Q3(K)+DQL(K)
1474	W4(K)=W3(K)+DWL(K)
1475	E4(K)=E3(K)+DEL(K)
1476	ENDDO
1477	!-----------------------------------------------------------------------
1478	!*** ANTI-FILTERING STEP
1479	!-----------------------------------------------------------------------
1480	SUMPQ=0.
1481	SUMNQ=0.
1482	SUMPW=0.
1483	SUMNW=0.
1484	SUMPE=0.
1485	SUMNE=0.
1486	!
1487	!*** ANTI-FILTERING LIMITERS
1488	!
1489	DO 50 K=KTE-1,KOFF+2,-1
1490	!
1491	DETAP=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
1492	!
1493	Q4P=Q4(K)
1494	W4P=W4(K)
1495	E4P=E4(K)
1496	!
1497	LAP=LA(K)
1498	!
1499	IF(LAP.NE.0)THEN
1500	DPDN=(AETA1(K+LAP)-AETA1(K))*PDTOP &
1501	& +(AETA2(K+LAP)-AETA2(K))*PDSL(I,J)
1502	DPUP=(AETA1(K)-AETA1(K-LAP))*PDTOP &
1503	& +(AETA2(K)-AETA2(K-LAP))*PDSL(I,J)
1504	!
1505	AFRP=2.AFR(K)DPDN*DPDN/(DPDN+DPUP)
1506	D2PQQ=((Q4(K+LAP)-Q4P)/DPDN &
1507	& -(Q4P-Q4(K-LAP))/DPUP)*AFRP
1508	D2PQW=((W4(K+LAP)-W4P)/DPDN &
1509	& -(W4P-W4(K-LAP))/DPUP)*AFRP
1510	D2PQE=((E4(K+LAP)-E4P)/DPDN &
1511	& -(E4P-E4(K-LAP))/DPUP)*AFRP
1512	ELSE
1513	D2PQQ=0.
1514	D2PQW=0.
1515	D2PQE=0.
1516	ENDIF
1517	!
1518	QP=Q4P-D2PQQ
1519	WP=W4P-D2PQW
1520	EP=E4P-D2PQE
1521	!
1522	Q00=Q3(K)
1523	QP0=Q3(K+LAP)
1524	!
1525	W00=W3(K)
1526	WP0=W3(K+LAP)
1527	!
1528	E00=E3(K)
1529	EP0=E3(K+LAP)
1530	!
1531	IF(LAP/=0)THEN
1532	QP=MAX(QP,MIN(Q00,QP0))
1533	QP=MIN(QP,MAX(Q00,QP0))
1534	WP=MAX(WP,MIN(W00,WP0))
1535	WP=MIN(WP,MAX(W00,WP0))
1536	EP=MAX(EP,MIN(E00,EP0))
1537	EP=MIN(EP,MAX(E00,EP0))
1538	ENDIF
1539	!
1540	DQP=QP-Q00
1541	DWP=WP-W00
1542	DEP=EP-E00
1543	!
1544	DQL(K)=DQP
1545	DWL(K)=DWP
1546	DEL(K)=DEP
1547	!
1548	DQP=DQP*DETAP
1549	DWP=DWP*DETAP
1550	DEP=DEP*DETAP
1551	!
1552	IF(DQP>0.)THEN
1553	SUMPQ=SUMPQ+DQP
1554	ELSE
1555	SUMNQ=SUMNQ+DQP
1556	ENDIF
1557	!
1558	IF(DWP>0.)THEN
1559	SUMPW=SUMPW+DWP
1560	ELSE
1561	SUMNW=SUMNW+DWP
1562	ENDIF
1563	!
1564	IF(DEP>0.)THEN
1565	SUMPE=SUMPE+DEP
1566	ELSE
1567	SUMNE=SUMNE+DEP
1568	ENDIF
1569	!
1570	50 CONTINUE
1571	!-----------------------------------------------------------------------
1572	DQL(KOFF+1)=0.
1573	DWL(KOFF+1)=0.
1574	DEL(KOFF+1)=0.
1575	!
1576	DQL(KTE)=0.
1577	DWL(KTE)=0.
1578	DEL(KTE)=0.
1579	!-----------------------------------------------------------------------
1580	!*** FIRST MOMENT CONSERVING FACTOR
1581	!-----------------------------------------------------------------------
1582	IF(SUMPQ>1.E-9)THEN
1583	RFACQK=-SUMNQ/SUMPQ
1584	ELSE
1585	RFACQK=1.
1586	ENDIF
1587	!
1588	IF(SUMPW>1.E-9)THEN
1589	RFACWK=-SUMNW/SUMPW
1590	ELSE
1591	RFACWK=1.
1592	ENDIF
1593	!
1594	IF(SUMPE>1.E-9)THEN
1595	RFACEK=-SUMNE/SUMPE
1596	ELSE
1597	RFACEK=1.
1598	ENDIF
1599	!
1600	IF(RFACQK<CONSERVE_MIN.OR.RFACQK>CONSERVE_MAX)RFACQK=1.
1601	IF(RFACWK<CONSERVE_MIN.OR.RFACWK>CONSERVE_MAX)RFACWK=1.
1602	IF(RFACEK<CONSERVE_MIN.OR.RFACEK>CONSERVE_MAX)RFACEK=1.
1603	!-----------------------------------------------------------------------
1604	!*** IMPOSE CONSERVATION ON ANTI-FILTERING
1605	!-----------------------------------------------------------------------
1606	DO K=KTE,KOFF+1,-1
1607	DQP=DQL(K)
1608	IF(DQP>=0.)DQP=DQP*RFACQK
1609	Q(I,K,J)=Q3(K)+DQP
1610	ENDDO
1611	!-----------------------------------------------------------------------
1612	DO K=KTE,KOFF+1,-1
1613	DWP=DWL(K)
1614	IF(DWP>=0.)DWP=DWP*RFACWK
1615	CWM(I,K,J)=W3(K)+DWP
1616	ENDDO
1617	!-----------------------------------------------------------------------
1618	DO K=KTE,KOFF+1,-1
1619	DEP=DEL(K)
1620	IF(DEP>=0.)DEP=DEP*RFACEK
1621	E3(K)=E3(K)+DEP
1622	ENDDO
1623	!
1624	HBM2IJ=HBM2(I,J)
1625	Q2(I,KTE,J)=MAX(E3(KTE)+E3(KTE)-EPSQ2,EPSQ2)*HBM2IJ &
1626	& +Q2(I,KTE,J)*(1.-HBM2IJ)
1627	DO K=KTE-1,KOFF+2,-1
1628	Q2(I,K,J)=MAX(E3(K)+E3(K)-Q2(I,K+1,J),EPSQ2)*HBM2IJ &
1629	& +Q2(I,K,J)*(1.-HBM2IJ)
1630	ENDDO
1631	!-----------------------------------------------------------------------
1632	!-----------------------------------------------------------------------
1633	ENDDO
1634	!
1635	ENDDO main_integration
1636	!-----------------------------------------------------------------------
1637	!-----------------------------------------------------------------------
1638	END SUBROUTINE VAD2
1639	!-----------------------------------------------------------------------
1640	!
1641	!***********************************************************************
1642	SUBROUTINE HAD2( &
1643	#if defined(DM_PARALLEL)
1644	& domdesc , &
1645	#endif
1646	& NTSD,DT,IDTAD,DX,DY &
1647	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
1648	& ,HTM,HBM2,HBM3,LMH &
1649	& ,Q,Q2,CWM,U,V,Z,HYDRO &
1650	& ,N_IUP_H,N_IUP_V &
1651	& ,N_IUP_ADH,N_IUP_ADV &
1652	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
1653	& ,IHE,IHW,IVE,IVW,INDX3_WRK &
1654	& ,IDS,IDE,JDS,JDE,KDS,KDE &
1655	& ,IMS,IME,JMS,JME,KMS,KME &
1656	& ,ITS,ITE,JTS,JTE,KTS,KTE)
1657	!***********************************************************************
1658	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
1659	! . . .
1660	! SUBPROGRAM: HAD2 HORIZONTAL ADVECTION OF H2O AND TKE
1661	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
1662	!
1663	! ABSTRACT:
1664	! HAD2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
1665	! TO THE TENDENCIES OF WATER SUBSTANCE AND TKE AND THEN
1666	! UPDATES THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
1667	!
1668	! PROGRAM HISTORY LOG:
1669	! 96-07-19 JANJIC - ORIGINATOR
1670	! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
1671	! 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
1672	! 02-02-06 BLACK - CONVERTED TO WRF FORMAT
1673	! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
1674	! 03-05-23 JANJIC - ADDED SLOPE FACTOR
1675	! 04-11-23 BLACK - THREADED
1676	!
1677	! USAGE: CALL HAD2 FROM SUBROUTINE SOLVE_NMM
1678	! INPUT ARGUMENT LIST:
1679	!
1680	! OUTPUT ARGUMENT LIST
1681	!
1682	! OUTPUT FILES:
1683	! NONE
1684	! SUBPROGRAMS CALLED:
1685	!
1686	! UNIQUE: NONE
1687	!
1688	! LIBRARY: NONE
1689	!
1690	! ATTRIBUTES:
1691	! LANGUAGE: FORTRAN 90
1692	! MACHINE : IBM SP
1693	!$$$
1694	!***********************************************************************
1695	!-----------------------------------------------------------------------
1696	!
1697	IMPLICIT NONE
1698	!
1699	!-----------------------------------------------------------------------
1700	!
1701	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
1702	& ,IMS,IME,JMS,JME,KMS,KME &
1703	& ,ITS,ITE,JTS,JTE,KTS,KTE
1704	!
1705	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
1706	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
1707	& ,N_IUP_ADH,N_IUP_ADV
1708	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
1709	& ,IUP_ADH,IUP_ADV
1710	!-----------------------------------------------------------------------
1711	!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1712	! NMM_MAX_DIM is set in configure.wrf and must agree with the value of
1713	! dimspec q in Registry/Registry.
1714	!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1715	!-----------------------------------------------------------------------
1716	INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
1717	!
1718	INTEGER,INTENT(IN) :: IDTAD,NTSD
1719	!
1720	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
1721	!
1722	REAL,INTENT(IN) :: DT,DY,PDTOP
1723	!
1724	REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
1725	!
1726	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
1727	!
1728	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,U,V,Z
1729	!
1730	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CWM,Q,Q2
1731	!
1732	LOGICAL,INTENT(IN) :: HYDRO
1733	!
1734	!-----------------------------------------------------------------------
1735	!
1736	!*** LOCAL VARIABLES
1737	!
1738	REAL,PARAMETER :: FF1=0.530
1739	!
1740	#ifdef DM_PARALLEL
1741	INTEGER :: DOMDESC
1742	#endif
1743	!
1744	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
1745	LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
1746	INTEGER :: N
1747	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,6) :: XSUMS_L
1748	REAL,DIMENSION(IDS:IDE,KDS:KDE,JDS:JDE,6) :: XSUMS_G
1749	#endif
1750	!
1751	LOGICAL :: BOT,TOP
1752	!
1753	INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP,MPI_COMM_COMP
1754	!
1755	INTEGER,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: IFPA,IFPF &
1756	& ,IFQA,IFQF &
1757	& ,JFPA,JFPF &
1758	& ,JFQA,JFQF
1759	!
1760	REAL :: ADDT,AFRP,CRIT,D2PQE,D2PQQ,D2PQW,DEP,DESTIJ,DQP,DQSTIJ &
1761	& ,DVOLP,DWP,DWSTIJ,DZA,DZB,E00,E0Q,E1X,E2IJ,E4P,ENH,EP,EP0 &
1762	& ,ESTIJ,FPQ,HAFP,HAFQ,HBM2IJ,HM,HTMIKJ,PP,PPQ00,Q00,Q0Q &
1763	& ,Q1IJ,Q4P,QP,QP0,QSTIJ,RDY,RFACEK,RFACQK,RFACWK,RFC &
1764	& ,RFEIJ,RFQIJ,RFWIJ,RR,SLOPAC,SPP,SQP,SSA,SSB,SUMNE,SUMNQ &
1765	& ,SUMNW,SUMPE,SUMPQ,SUMPW,TTA,TTB,W00,W0Q,W1IJ,W4P,WP,WP0 &
1766	& ,WSTIJ
1767	!
1768	DOUBLE PRECISION,DIMENSION(6,KTE-KTS+1) :: GSUMS,XSUMS
1769	!
1770	REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4 &
1771	& ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
1772	!
1773	REAL,DIMENSION(IMS:IME,JMS:JME) :: DARE,EMH
1774	!
1775	REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,JTS-5:JTE+5) :: AFP,AFQ,DEST &
1776	& ,DQST,DVOL,DWST &
1777	& ,E1,E2,Q1,W1
1778	integer :: nunit,ier
1779	save nunit
1780	!***********************************************************************
1781	!-----------------------------------------------------------------------
1782	!
1783	RDY=1./DY
1784	SLOPAC=SLOPHTSQRT(2.)0.5*50.
1785	CRIT=SLOPACREAL(IDTAD)DTRDY1000.
1786	!
1787	ADDT=REAL(IDTAD)*DT
1788	ENH=ADDT/(08.*DY)
1789	!
1790	!-----------------------------------------------------------------------
1791	!$omp parallel do &
1792	!$omp& private(i,j)
1793	DO J=MYJS_P3,MYJE_P3
1794	DO I=MYIS_P2,MYIE_P2
1795	EMH (I,J)=ADDT/(08.*DX(I,J))
1796	DARE(I,J)=HBM3(I,J)DX(I,J)DY
1797	E1(I,KTE,J)=MAX(Q2(I,KTE,J)*0.5,EPSQ2)
1798	E2(I,KTE,J)=E1(I,KTE,J)
1799	ENDDO
1800	ENDDO
1801	!-----------------------------------------------------------------------
1802	!
1803	!$omp parallel do &
1804	!$omp& private(e1x,htmikj,i,j,k)
1805	DO J=MYJS_P3,MYJE_P3
1806	DO K=KTS,KTE
1807	DO I=MYIS_P2,MYIE_P2
1808	DVOL(I,K,J)=DARE(I,J)(DETA1(K)PDTOP+DETA2(K)*PDSL(I,J))
1809	HTMIKJ=HTM(I,K,J)
1810	Q (I,K,J)=MAX(Q (I,K,J),EPSQ)*HTMIKJ
1811	CWM(I,K,J)=MAX(CWM(I,K,J),CLIMIT)*HTMIKJ
1812	Q1 (I,K,J)=Q (I,K,J)
1813	W1 (I,K,J)=CWM(I,K,J)
1814	ENDDO
1815	ENDDO
1816	!
1817	DO K=KTE-1,KTS,-1
1818	DO I=MYIS_P2,MYIE_P2
1819	E1X=(Q2(I,K+1,J)+Q2(I,K,J))*0.5
1820	E1(I,K,J)=MAX(E1X,EPSQ2)
1821	E2(I,K,J)=E1(I,K,J)
1822	ENDDO
1823	ENDDO
1824	!
1825	ENDDO
1826	!-----------------------------------------------------------------------
1827	!$omp parallel do &
1828	!$omp& private(dza,dzb,fpq,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp,tta,ttb)
1829	DO J=MYJS2_P1,MYJE2_P1
1830	DO K=KTS,KTE
1831	DO I=MYIS1_P1,MYIE1_P1
1832	!
1833	TTA=(U(I,K,J-1)+U(I+IHW(J),K,J)+U(I+IHE(J),K,J)+U(I,K,J+1)) &
1834	& EMH(I,J)HBM2(I,J)
1835	TTB=(V(I,K,J-1)+V(I+IHW(J),K,J)+V(I+IHE(J),K,J)+V(I,K,J+1)) &
1836	& ENHHBM2(I,J)
1837	!
1838	SPP=-TTA-TTB
1839	SQP= TTA-TTB
1840	!
1841	IF(SPP<0.)THEN
1842	JFP=-1
1843	ELSE
1844	JFP=1
1845	ENDIF
1846	IF(SQP<0.)THEN
1847	JFQ=-1
1848	ELSE
1849	JFQ=1
1850	ENDIF
1851	!
1852	IFPA(I,K,J)=IHE(J)+I+( JFP-1)/2
1853	IFQA(I,K,J)=IHE(J)+I+(-JFQ-1)/2
1854	!
1855	JFPA(I,K,J)=J+JFP
1856	JFQA(I,K,J)=J+JFQ
1857	!
1858	IFPF(I,K,J)=IHE(J)+I+(-JFP-1)/2
1859	IFQF(I,K,J)=IHE(J)+I+( JFQ-1)/2
1860	!
1861	JFPF(I,K,J)=J-JFP
1862	JFQF(I,K,J)=J-JFQ
1863	!
1864	!-----------------------------------------------------------------------
1865	IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
1866	DZA=(Z(IFPA(I,K,J),K,JFPA(I,K,J))-Z(I,K,J))*RDY
1867	DZB=(Z(IFQA(I,K,J),K,JFQA(I,K,J))-Z(I,K,J))*RDY
1868	!
1869	IF(ABS(DZA)>SLOPAC)THEN
1870	SSA=DZA*SPP
1871	IF(SSA>CRIT)THEN
1872	SPP=0. !spp*.1
1873	ENDIF
1874	ENDIF
1875	!
1876	IF(ABS(DZB)>SLOPAC)THEN
1877	SSB=DZB*SQP
1878	IF(SSB>CRIT)THEN
1879	SQP=0. !sqp*.1
1880	ENDIF
1881	ENDIF
1882	!
1883	ENDIF
1884	!-----------------------------------------------------------------------
1885	SPP=SPP*HTM(IFPA(I,K,J),K,JFPA(I,K,J))
1886	SQP=SQP*HTM(IFQA(I,K,J),K,JFQA(I,K,J))
1887	FPQ=SPPSQPHTM(I,K,J-2)*HTM(I-1,K,J) &
1888	& HTM(I+1,K,J)HTM(I,K,J+2)*0.25
1889	PP=ABS(SPP)
1890	QP=ABS(SQP)
1891	!
1892	AFP(I,K,J)=(((FF4PP+FF3)PP+FF2)PP+FF1)PP
1893	AFQ(I,K,J)=(((FF4QP+FF3)QP+FF2)QP+FF1)QP
1894	!
1895	Q1(I,K,J)=(Q (IFPA(I,K,J),K,JFPA(I,K,J))-Q (I,K,J))*PP &
1896	& +(Q (IFQA(I,K,J),K,JFQA(I,K,J))-Q (I,K,J))*QP &
1897	& +(Q (I,K,J-2)+Q (I,K,J+2) &
1898	& -Q (I-1,K,J)-Q (I+1,K,J))*FPQ &
1899	& +Q(I,K,J)
1900	!
1901	W1(I,K,J)=(CWM(IFPA(I,K,J),K,JFPA(I,K,J))-CWM(I,K,J))*PP &
1902	& +(CWM(IFQA(I,K,J),K,JFQA(I,K,J))-CWM(I,K,J))*QP &
1903	& +(CWM(I,K,J-2)+CWM(I,K,J+2) &
1904	& -CWM(I-1,K,J)-CWM(I+1,K,J))*FPQ &
1905	& +CWM(I,K,J)
1906	!
1907	E2(I,K,J)=(E1 (IFPA(I,K,J),K,JFPA(I,K,J))-E1 (I,K,J))*PP &
1908	& +(E1 (IFQA(I,K,J),K,JFQA(I,K,J))-E1 (I,K,J))*QP &
1909	& +(E1 (I,K,J-2)+E1 (I,K,J+2) &
1910	& -E1 (I-1,K,J)-E1 (I+1,K,J))*FPQ &
1911	& +E1(I,K,J)
1912	!
1913	ENDDO
1914	ENDDO
1915	ENDDO
1916	!
1917	!-----------------------------------------------------------------------
1918	!*** ANTI-FILTERING STEP
1919	!-----------------------------------------------------------------------
1920	!
1921	DO K=KTS,KTE
1922	XSUMS(1,K)=0.
1923	XSUMS(2,K)=0.
1924	XSUMS(3,K)=0.
1925	XSUMS(4,K)=0.
1926	XSUMS(5,K)=0.
1927	XSUMS(6,K)=0.
1928	ENDDO
1929	!-----------------------------------------------------------------------
1930	!
1931	!*** ANTI-FILTERING LIMITERS
1932	!
1933	!-----------------------------------------------------------------------
1934	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
1935	DO N=1,6
1936	!
1937	!$omp parallel do &
1938	!$omp& private(i,j,k)
1939	DO J=JMS,JME
1940	DO K=KMS,KME
1941	DO I=IMS,IME
1942	XSUMS_L(I,K,J,N)=0.
1943	ENDDO
1944	ENDDO
1945	ENDDO
1946	!
1947	!$omp parallel do &
1948	!$omp& private(i,j,k)
1949	DO J=JDS,JDE
1950	DO K=KDS,KDE
1951	DO I=IDS,IDE
1952	XSUMS_G(I,K,J,N)=0.
1953	ENDDO
1954	ENDDO
1955	ENDDO
1956	!
1957	ENDDO
1958	!
1959	#endif
1960	!-----------------------------------------------------------------------
1961	DO 150 J=MYJS2,MYJE2
1962	DO 150 K=KTS,KTE
1963	DO 150 I=MYIS1,MYIE1
1964	!
1965	DVOLP=DVOL(I,K,J)
1966	Q1IJ =Q1(I,K,J)
1967	W1IJ =W1(I,K,J)
1968	E2IJ =E2(I,K,J)
1969	!
1970	HAFP=HTM(IFPF(I,K,J),K,JFPF(I,K,J))*AFP(I,K,J)
1971	HAFQ=HTM(IFQF(I,K,J),K,JFQF(I,K,J))*AFQ(I,K,J)
1972	!
1973	D2PQQ=(Q1(IFPA(I,K,J),K,JFPA(I,K,J))-Q1IJ &
1974	& -Q1IJ+Q1(IFPF(I,K,J),K,JFPF(I,K,J))) &
1975	& *HAFP &
1976	& +(Q1(IFQA(I,K,J),K,JFQA(I,K,J))-Q1IJ &
1977	& -Q1IJ+Q1(IFQF(I,K,J),K,JFQF(I,K,J))) &
1978	& *HAFQ
1979	!
1980	D2PQW=(W1(IFPA(I,K,J),K,JFPA(I,K,J))-W1IJ &
1981	& -W1IJ+W1(IFPF(I,K,J),K,JFPF(I,K,J))) &
1982	& *HAFP &
1983	& +(W1(IFQA(I,K,J),K,JFQA(I,K,J))-W1IJ &
1984	& -W1IJ+W1(IFQF(I,K,J),K,JFQF(I,K,J))) &
1985	& *HAFQ
1986	!
1987	D2PQE=(E2(IFPA(I,K,J),K,JFPA(I,K,J))-E2IJ &
1988	& -E2IJ+E2(IFPF(I,K,J),K,JFPF(I,K,J))) &
1989	& *HAFP &
1990	& +(E2(IFQA(I,K,J),K,JFQA(I,K,J))-E2IJ &
1991	& -E2IJ+E2(IFQF(I,K,J),K,JFQF(I,K,J))) &
1992	& *HAFQ
1993	!
1994	QSTIJ=Q1IJ-D2PQQ
1995	WSTIJ=W1IJ-D2PQW
1996	ESTIJ=E2IJ-D2PQE
1997	!
1998	Q00=Q (I ,K ,J)
1999	QP0=Q (IFPA(I,K,J),K,JFPA(I,K,J))
2000	Q0Q=Q (IFQA(I,K,J),K,JFQA(I,K,J))
2001	!
2002	W00=CWM(I ,K ,J)
2003	WP0=CWM(IFPA(I,K,J),K,JFPA(I,K,J))
2004	W0Q=CWM(IFQA(I,K,J),K,JFQA(I,K,J))
2005	!
2006	E00=E1 (I ,K ,J)
2007	EP0=E1 (IFPA(I,K,J),K,JFPA(I,K,J))
2008	E0Q=E1 (IFQA(I,K,J),K,JFQA(I,K,J))
2009	!
2010	QSTIJ=MAX(QSTIJ,MIN(Q00,QP0,Q0Q))
2011	QSTIJ=MIN(QSTIJ,MAX(Q00,QP0,Q0Q))
2012	WSTIJ=MAX(WSTIJ,MIN(W00,WP0,W0Q))
2013	WSTIJ=MIN(WSTIJ,MAX(W00,WP0,W0Q))
2014	ESTIJ=MAX(ESTIJ,MIN(E00,EP0,E0Q))
2015	ESTIJ=MIN(ESTIJ,MAX(E00,EP0,E0Q))
2016	!
2017	DQSTIJ=QSTIJ-Q(I,K,J)
2018	DWSTIJ=WSTIJ-CWM(I,K,J)
2019	DESTIJ=ESTIJ-E1(I,K,J)
2020	!
2021	DQST(I,K,J)=DQSTIJ
2022	DWST(I,K,J)=DWSTIJ
2023	DEST(I,K,J)=DESTIJ
2024	!
2025	DQSTIJ=DQSTIJ*DVOLP
2026	DWSTIJ=DWSTIJ*DVOLP
2027	DESTIJ=DESTIJ*DVOLP
2028	!
2029	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
2030	DO N=1,6
2031	XSUMS_L(I,K,J,N)=0.
2032	ENDDO
2033	!
2034	IF(DQSTIJ>0.)THEN
2035	XSUMS_L(I,K,J,1)=DQSTIJ
2036	ELSE
2037	XSUMS_L(I,K,J,2)=DQSTIJ
2038	ENDIF
2039	!
2040	IF(DWSTIJ>0.)THEN
2041	XSUMS_L(I,K,J,3)=DWSTIJ
2042	ELSE
2043	XSUMS_L(I,K,J,4)=DWSTIJ
2044	ENDIF
2045	!
2046	IF(DESTIJ>0.)THEN
2047	XSUMS_L(I,K,J,5)=DESTIJ
2048	ELSE
2049	XSUMS_L(I,K,J,6)=DESTIJ
2050	ENDIF
2051	#else
2052	IF(DQSTIJ>0.)THEN
2053	XSUMS(1,K)=XSUMS(1,K)+DQSTIJ
2054	ELSE
2055	XSUMS(2,K)=XSUMS(2,K)+DQSTIJ
2056	ENDIF
2057	!
2058	IF(DWSTIJ>0.)THEN
2059	XSUMS(3,K)=XSUMS(3,K)+DWSTIJ
2060	ELSE
2061	XSUMS(4,K)=XSUMS(4,K)+DWSTIJ
2062	ENDIF
2063	!
2064	IF(DESTIJ>0.)THEN
2065	XSUMS(5,K)=XSUMS(5,K)+DESTIJ
2066	ELSE
2067	XSUMS(6,K)=XSUMS(6,K)+DESTIJ
2068	ENDIF
2069	#endif
2070	!
2071	150 CONTINUE
2072	!
2073	!-----------------------------------------------------------------------
2074	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
2075	DO N=1,6
2076	CALL WRF_PATCH_TO_GLOBAL_REAL( XSUMS_L(IMS,KMS,JMS,N) &
2077	&, XSUMS_G(1,1,1,N),DOMDESC &
2078	&, 'xyz','xzy' &
2079	&, IDS,IDE,KDS,KDE,JDS,JDE &
2080	&, IMS,IME,KMS,KME,JMS,JME &
2081	&, ITS,ITE,KTS,KTE,JTS,JTE )
2082	ENDDO
2083	!
2084	GSUMS=0.
2085	!
2086	IF(WRF_DM_ON_MONITOR())THEN
2087	DO N=1,6
2088	!$omp parallel do &
2089	!$omp& private(i,j,k)
2090	DO J=JDS,JDE
2091	DO K=KDS,KDE
2092	DO I=IDS,IDE
2093	GSUMS(N,K)=GSUMS(N,K)+XSUMS_G(I,K,J,N)
2094	ENDDO
2095	ENDDO
2096	ENDDO
2097	ENDDO
2098	ENDIF
2099
2100	CALL WRF_DM_BCAST_BYTES(GSUMS,2RWORDSIZE6*(KDE-KDS+1) )
2101
2102	#else
2103	!-----------------------------------------------------------------------
2104	!
2105	!-----------------------------------------------------------------------
2106	!*** GLOBAL REDUCTION
2107	!-----------------------------------------------------------------------
2108	!
2109	# ifdef DM_PARALLEL
2110	CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
2111	CALL MPI_ALLREDUCE(XSUMS,GSUMS,6*(KTE-KTS+1) &
2112	& ,MPI_DOUBLE_PRECISION,MPI_SUM &
2113	& ,MPI_COMM_COMP,IRECV)
2114	# else
2115	GSUMS=XSUMS
2116	# endif
2117	#endif
2118	!
2119	!-----------------------------------------------------------------------
2120	!*** END OF GLOBAL REDUCTION
2121	!-----------------------------------------------------------------------
2122	!
2123	! if(mype==0)then
2124	! if(ntsd==0)then
2125	!! call int_get_fresh_handle(nunit)
2126	!! close(nunit)
2127	! nunit=56
2128	! open(unit=nunit,file='gsums',form='unformatted',iostat=ier)
2129	! endif
2130	! endif
2131	DO K=KTS,KTE
2132	! if(mype==0)then
2133	! write(nunit)(gsums(i,k),i=1,6)
2134	! endif
2135	!
2136	!-----------------------------------------------------------------------
2137	SUMPQ=GSUMS(1,K)
2138	SUMNQ=GSUMS(2,K)
2139	SUMPW=GSUMS(3,K)
2140	SUMNW=GSUMS(4,K)
2141	SUMPE=GSUMS(5,K)
2142	SUMNE=GSUMS(6,K)
2143	!
2144	!-----------------------------------------------------------------------
2145	!*** FIRST MOMENT CONSERVING FACTOR
2146	!-----------------------------------------------------------------------
2147	!
2148	IF(SUMPQ>1.)THEN
2149	RFACQK=-SUMNQ/SUMPQ
2150	ELSE
2151	RFACQK=1.
2152	ENDIF
2153	!
2154	IF(SUMPW>1.)THEN
2155	RFACWK=-SUMNW/SUMPW
2156	ELSE
2157	RFACWK=1.
2158	ENDIF
2159	!
2160	IF(SUMPE>1.)THEN
2161	RFACEK=-SUMNE/SUMPE
2162	ELSE
2163	RFACEK=1.
2164	ENDIF
2165	!
2166	IF(RFACQK<CONSERVE_MIN.OR.RFACQK>CONSERVE_MAX)RFACQK=1.
2167	IF(RFACWK<CONSERVE_MIN.OR.RFACWK>CONSERVE_MAX)RFACWK=1.
2168	IF(RFACEK<CONSERVE_MIN.OR.RFACEK>CONSERVE_MAX)RFACEK=1.
2169	!
2170	RFACQ(K)=RFACQK
2171	RFACW(K)=RFACWK
2172	RFACE(K)=RFACEK
2173	!
2174	ENDDO
2175	! if(mype==0.and.ntsd==181)close(nunit)
2176	!
2177	!-----------------------------------------------------------------------
2178	!*** IMPOSE CONSERVATION ON ANTI-FILTERING
2179	!-----------------------------------------------------------------------
2180	!$omp parallel do &
2181	!$omp& private(dqstij,i,j,k,rfacqk,rfqij)
2182	DO J=MYJS2,MYJE2
2183	DO K=KTS,KTE
2184	RFACQK=RFACQ(K)
2185	IF(RFACQK<1.)THEN
2186	DO I=MYIS1,MYIE1
2187	DQSTIJ=DQST(I,K,J)
2188	RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
2189	IF(DQSTIJ>=0.)DQSTIJ=DQSTIJ*RFQIJ
2190	Q(I,K,J)=Q(I,K,J)+DQSTIJ
2191	ENDDO
2192	ELSE
2193	DO I=MYIS1,MYIE1
2194	DQSTIJ=DQST(I,K,J)
2195	RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
2196	IF(DQSTIJ<0.)DQSTIJ=DQSTIJ/RFQIJ
2197	Q(I,K,J)=Q(I,K,J)+DQSTIJ
2198	ENDDO
2199	ENDIF
2200	ENDDO
2201	ENDDO
2202	!-----------------------------------------------------------------------
2203	!$omp parallel do &
2204	!$omp& private(dwstij,i,j,k,rfacwk,rfwij)
2205	DO J=MYJS2,MYJE2
2206	DO K=KTS,KTE
2207	RFACWK=RFACW(K)
2208	IF(RFACWK<1.)THEN
2209	DO I=MYIS1,MYIE1
2210	DWSTIJ=DWST(I,K,J)
2211	RFWIJ=HBM2(I,J)*(RFACWK-1.)+1.
2212	IF(DWSTIJ>=0.)DWSTIJ=DWSTIJ*RFWIJ
2213	CWM(I,K,J)=CWM(I,K,J)+DWSTIJ
2214	ENDDO
2215	ELSE
2216	DO I=MYIS1,MYIE1
2217	DWSTIJ=DWST(I,K,J)
2218	RFWIJ=HBM2(I,J)*(RFACWK-1.)+1.
2219	IF(DWSTIJ<0.)DWSTIJ=DWSTIJ/RFWIJ
2220	CWM(I,K,J)=CWM(I,K,J)+DWSTIJ
2221	ENDDO
2222	ENDIF
2223	ENDDO
2224	ENDDO
2225	!-----------------------------------------------------------------------
2226	!$omp parallel do &
2227	!$omp& private(destij,i,j,k,rfacek,rfeij)
2228	DO J=MYJS2,MYJE2
2229	DO K=KTS,KTE
2230	RFACEK=RFACE(K)
2231	IF(RFACEK<1.)THEN
2232	DO I=MYIS1,MYIE1
2233	DESTIJ=DEST(I,K,J)
2234	RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
2235	IF(DESTIJ>=0.)DESTIJ=DESTIJ*RFEIJ
2236	E1(I,K,J)=E1(I,K,J)+DESTIJ
2237	ENDDO
2238	ELSE
2239	DO I=MYIS1,MYIE1
2240	DESTIJ=DEST(I,K,J)
2241	RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
2242	IF(DESTIJ<0.)DESTIJ=DESTIJ/RFEIJ
2243	E1(I,K,J)=E1(I,K,J)+DESTIJ
2244	ENDDO
2245	ENDIF
2246	ENDDO
2247	ENDDO
2248	!-----------------------------------------------------------------------
2249	!$omp parallel do &
2250	!$omp& private(i,j,k)
2251	DO J=MYJS,MYJE
2252	DO K=KTS,KTE
2253	DO I=MYIS,MYIE
2254	Q (I,K,J)=MAX(Q (I,K,J),EPSQ)*HTM(I,K,J)
2255	CWM(I,K,J)=MAX(CWM(I,K,J),CLIMIT)*HTM(I,K,J)
2256	ENDDO
2257	ENDDO
2258	ENDDO
2259	!
2260	!$omp parallel do &
2261	!$omp& private(i,j)
2262	DO J=MYJS,MYJE
2263	DO I=MYIS,MYIE
2264	Q2(I,KTE,J)=MAX(E1(I,KTE,J)+E1(I,KTE,J)-EPSQ2,EPSQ2) &
2265	& *HTM(I,KTE,J)
2266	ENDDO
2267	ENDDO
2268	!
2269	!$omp parallel do &
2270	!$omp& private(i,j,k,koff)
2271	DO J=MYJS,MYJE
2272	DO K=KTE-1,KTS+1,-1
2273	DO I=MYIS,MYIE
2274	KOFF=KTE-LMH(I,J)
2275	IF(K>KOFF+1)THEN
2276	Q2(I,K,J)=MAX(E1(I,K,J)+E1(I,K,J)-Q2(I,K+1,J),EPSQ2) &
2277	& *HTM(I,K,J)
2278	ELSE
2279	Q2(I,K,J)=Q2(I,K+1,J)
2280	ENDIF
2281	ENDDO
2282	ENDDO
2283	ENDDO
2284	!-----------------------------------------------------------------------
2285	END SUBROUTINE HAD2
2286	!-----------------------------------------------------------------------
2287	!***********************************************************************
2288	SUBROUTINE VAD2_DRY(NTSD,DT,IDTAD,DX,DY &
2289	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
2290	& ,HBM2,LMH &
2291	& ,Q2,PETDT &
2292	& ,N_IUP_H,N_IUP_V &
2293	& ,N_IUP_ADH,N_IUP_ADV &
2294	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
2295	& ,IHE,IHW,IVE,IVW,INDX3_WRK &
2296	& ,IDS,IDE,JDS,JDE,KDS,KDE &
2297	& ,IMS,IME,JMS,JME,KMS,KME &
2298	& ,ITS,ITE,JTS,JTE,KTS,KTE)
2299	!***********************************************************************
2300	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
2301	! . . .
2302	! SUBPROGRAM: VAD2_DRY VERTICAL ADVECTION OF TKE
2303	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
2304	!
2305	! ABSTRACT:
2306	! VAD2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL AND VERTICAL
2307	! ADVECTION TO THE TENDENCY OF TKE AND THEN UPDATES IT.
2308	! AN ANTI-FILTERING TECHNIQUE IS USED.
2309	!
2310	! PROGRAM HISTORY LOG:
2311	! 96-07-19 JANJIC - ORIGINATOR
2312	! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
2313	! 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
2314	! 02-02-06 BLACK - CONVERTED TO WRF FORMAT
2315	! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
2316	! 04-11-23 BLACK - THREADED
2317	!
2318	! USAGE: CALL VAD2_DRY FROM SUBROUTINE DIGITAL_FILTER
2319	! INPUT ARGUMENT LIST:
2320	!
2321	! OUTPUT ARGUMENT LIST
2322	!
2323	! OUTPUT FILES:
2324	! NONE
2325	! SUBPROGRAMS CALLED:
2326	!
2327	! UNIQUE: NONE
2328	!
2329	! LIBRARY: NONE
2330	!
2331	! ATTRIBUTES:
2332	! LANGUAGE: FORTRAN 90
2333	! MACHINE : IBM SP
2334	!$$$
2335	!***********************************************************************
2336	!-----------------------------------------------------------------------
2337	!
2338	IMPLICIT NONE
2339	!
2340	!-----------------------------------------------------------------------
2341	!
2342	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
2343	& ,IMS,IME,JMS,JME,KMS,KME &
2344	& ,ITS,ITE,JTS,JTE,KTS,KTE
2345	!
2346	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
2347	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
2348	& ,N_IUP_ADH,N_IUP_ADV
2349	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
2350	& ,IUP_ADH,IUP_ADV
2351	! NMM_MAX_DIM is set in configure.wrf and must agree with
2352	! the value of dimspec q in the Registry/Registry
2353	INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
2354	!
2355	INTEGER,INTENT(IN) :: IDTAD,NTSD
2356	!
2357	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
2358	!
2359	REAL,INTENT(IN) :: DT,DY,PDTOP
2360	!
2361	REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
2362	!
2363	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
2364	!
2365	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
2366	!
2367	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: Q2
2368	!
2369	!-----------------------------------------------------------------------
2370	!
2371	!*** LOCAL VARIABLES
2372	!
2373	REAL,PARAMETER :: FF1=0.525
2374	!
2375	LOGICAL :: BOT,TOP
2376	!
2377	INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP
2378	!
2379	INTEGER,DIMENSION(KTS:KTE) :: LA
2380	!
2381	REAL :: ADDT,AFRP,D2PQE,DEP,DETAP,DPDN,DPUP,DQP &
2382	& ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ &
2383	& ,RFACEK,RFC,RR,SUMNE,SUMPE
2384	!
2385	REAL,DIMENSION(KTS:KTE) :: AFR,DEL,E3,E4,PETDTK,RFACE
2386	!
2387	!***********************************************************************
2388	!-----------------------------------------------------------------------
2389	!
2390	ADDT=REAL(IDTAD)*DT
2391	!
2392	!-----------------------------------------------------------------------
2393	!
2394	!$omp parallel do &
2395	!$omp& private(afr,afrp,bot,d2pqe,del,dep,detap,dpdn,dpup,e00,e3 &
2396	!$omp& ,e4,e4p,ep,ep0,hbm2ij,i,j,k,koff,la,lap,llap,petdtk &
2397	!$omp& ,rfacek,rfc,rr,sumne,sumpe,top)
2398	main_integration : DO J=MYJS2,MYJE2
2399	!
2400	DO I=MYIS1_P1,MYIE1_P1
2401	!-----------------------------------------------------------------------
2402	KOFF=KTE-LMH(I,J)
2403	!
2404	E3(KTE)=Q2(I,KTE,J)*0.5
2405	!
2406	DO K=KTE-1,KOFF+1,-1
2407	E3(K)=MAX((Q2(I,K+1,J)+Q2(I,K,J))*0.5,EPSQ2)
2408	ENDDO
2409	!
2410	DO K=KOFF+1,KTE
2411	E4(K)=E3(K)
2412	ENDDO
2413	!
2414	PETDTK(KTE)=PETDT(I,KTE-1,J)*0.5
2415	!
2416	DO K=KTE-1,KOFF+2,-1
2417	PETDTK(K)=(PETDT(I,K+1,J)+PETDT(I,K,J))*0.5
2418	ENDDO
2419	!
2420	PETDTK(KOFF+1)=PETDT(I,KOFF+1,J)*0.5
2421	!-----------------------------------------------------------------------
2422	HADDT=-ADDT*HBM2(I,J)
2423	!
2424	DO K=KTE,KOFF+1,-1
2425	RR=PETDTK(K)*HADDT
2426	!
2427	IF(RR<0.)THEN
2428	LAP=1
2429	ELSE
2430	LAP=-1
2431	ENDIF
2432	!
2433	LA(K)=LAP
2434	LLAP=K+LAP
2435	!
2436	TOP=.FALSE.
2437	BOT=.FALSE.
2438	!
2439	IF(LLAP>0.AND.LLAP<KTE+1.AND.LAP/=0)THEN
2440	RR=ABS(RR/((AETA1(LLAP)-AETA1(K))*PDTOP &
2441	& +(AETA2(LLAP)-AETA2(K))*PDSL(I,J)))
2442	!
2443	AFR(K)=(((FF4RR+FF3)RR+FF2)RR+FF1)RR
2444	DEP=(E3(LLAP)-E3(K))*RR
2445	DEL(K)=DEP
2446	ELSE
2447	TOP=LLAP==KTE+1
2448	BOT=LLAP==KOFF
2449	!
2450	RR=0.
2451	AFR(K)=0.
2452	DEL(K)=0.
2453	ENDIF
2454	ENDDO
2455	!-----------------------------------------------------------------------
2456	IF(TOP)THEN
2457	IF(LA(KTE-1)<0)THEN
2458	RFC=(DETA1(KTE-1)PDTOP+DETA2(KTE-1)PDSL(I,J)) &
2459	& /(DETA1(KTE )PDTOP+DETA2(KTE )PDSL(I,J))
2460	DEL(KTE)=-DEL(KTE+1)*RFC
2461	ENDIF
2462	ENDIF
2463	!
2464	IF(BOT)THEN
2465	IF(LA(KOFF+2)<0)THEN
2466	RFC=(DETA1(KOFF+2)PDTOP+DETA2(KOFF+2)PDSL(I,J)) &
2467	& /(DETA1(KOFF+1)PDTOP+DETA2(KOFF+1)PDSL(I,J))
2468	DEL(KOFF+1)=-DEL(KOFF+2)*RFC
2469	ENDIF
2470	ENDIF
2471	!
2472	DO K=KOFF+1,KTE
2473	E4(K)=E3(K)+DEL(K)
2474	ENDDO
2475	!-----------------------------------------------------------------------
2476	!*** ANTI-FILTERING STEP
2477	!-----------------------------------------------------------------------
2478	SUMPE=0.
2479	SUMNE=0.
2480	!
2481	!*** ANTI-FILTERING LIMITERS
2482	!
2483	DO 50 K=KTE-1,KOFF+2,-1
2484	!
2485	DETAP=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
2486	!
2487	E4P=E4(K)
2488	!
2489	LAP=LA(K)
2490	!
2491	IF(LAP/=0)THEN
2492	DPDN=(AETA1(K+LAP)-AETA1(K))*PDTOP &
2493	& +(AETA2(K+LAP)-AETA2(K))*PDSL(I,J)
2494	DPUP=(AETA1(K)-AETA1(K-LAP))*PDTOP &
2495	& +(AETA2(K)-AETA2(K-LAP))*PDSL(I,J)
2496	!
2497	AFRP=2.AFR(K)DPDN*DPDN/(DPDN+DPUP)
2498	D2PQE=((E4(K+LAP)-E4P)/DPDN &
2499	& -(E4P-E4(K-LAP))/DPUP)*AFRP
2500	ELSE
2501	D2PQE=0.
2502	ENDIF
2503	!
2504	EP=E4P-D2PQE
2505	!
2506	E00=E3(K)
2507	EP0=E3(K+LAP)
2508	!
2509	IF(LAP/=0)THEN
2510	EP=MAX(EP,MIN(E00,EP0))
2511	EP=MIN(EP,MAX(E00,EP0))
2512	ENDIF
2513	!
2514	DEP=EP-E00
2515	!
2516	DEL(K)=DEP
2517	!
2518	DEP=DEP*DETAP
2519	!
2520	IF(DEP>0.)THEN
2521	SUMPE=SUMPE+DEP
2522	ELSE
2523	SUMNE=SUMNE+DEP
2524	ENDIF
2525	!
2526	50 CONTINUE
2527	!-----------------------------------------------------------------------
2528	DEL(KTE)=0.
2529	!
2530	DEL(KOFF+1)=0.
2531	!-----------------------------------------------------------------------
2532	!*** FIRST MOMENT CONSERVING FACTOR
2533	!-----------------------------------------------------------------------
2534	IF(SUMPE>1.E-9)THEN
2535	RFACEK=-SUMNE/SUMPE
2536	ELSE
2537	RFACEK=1.
2538	ENDIF
2539	!
2540	IF(RFACEK<CONSERVE_MIN.OR.RFACEK>CONSERVE_MAX)RFACEK=1.
2541	!-----------------------------------------------------------------------
2542	!*** IMPOSE CONSERVATION ON ANTI-FILTERING
2543	!-----------------------------------------------------------------------
2544	DO K=KOFF+1,KTE
2545	DEP=DEL(K)
2546	IF(DEP>=0.)DEP=DEP*RFACEK
2547	E3(K)=E3(K)+DEP
2548	ENDDO
2549	!
2550	HBM2IJ=HBM2(I,J)
2551	Q2(I,KTE,J)=MAX(E3(KTE)+E3(KTE)-EPSQ2,EPSQ2)*HBM2IJ &
2552	& +Q2(I,KTE,J)*(1.-HBM2IJ)
2553	DO K=KTE-1,KOFF+2
2554	Q2(I,K,J)=MAX(E3(K)+E3(K)-Q2(I,K+1,J),EPSQ2)*HBM2IJ &
2555	& +Q2(I,K,J)*(1.-HBM2IJ)
2556	ENDDO
2557	!-----------------------------------------------------------------------
2558	!-----------------------------------------------------------------------
2559	ENDDO
2560	!
2561	ENDDO main_integration
2562	!-----------------------------------------------------------------------
2563	!----------------------------------------------------------------------
2564	END SUBROUTINE VAD2_DRY
2565	!----------------------------------------------------------------------
2566	!
2567	!***********************************************************************
2568	SUBROUTINE HAD2_DRY(NTSD,DT,IDTAD,DX,DY &
2569	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
2570	& ,HTM,HBM2,HBM3,LMH &
2571	& ,Q2,U,V,Z,HYDRO &
2572	& ,N_IUP_H,N_IUP_V &
2573	& ,N_IUP_ADH,N_IUP_ADV &
2574	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
2575	& ,IHE,IHW,IVE,IVW,INDX3_WRK &
2576	& ,IDS,IDE,JDS,JDE,KDS,KDE &
2577	& ,IMS,IME,JMS,JME,KMS,KME &
2578	& ,ITS,ITE,JTS,JTE,KTS,KTE)
2579	!***********************************************************************
2580	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
2581	! . . .
2582	! SUBPROGRAM: HAD2_DRY HORIZONTAL ADVECTION OF TKE
2583	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
2584	!
2585	! ABSTRACT:
2586	! HAD2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
2587	! TO THE TENDENCIES OF TKE AND UPDATES IT.
2588	! AN ANTI-FILTERING TECHNIQUE IS USED.
2589	!
2590	! PROGRAM HISTORY LOG:
2591	! 96-07-19 JANJIC - ORIGINATOR
2592	! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
2593	! 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
2594	! 02-02-06 BLACK - CONVERTED TO WRF FORMAT
2595	! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
2596	! 03-05-23 JANJIC - ADDED SLOPE FACTOR
2597	! 04-11-23 BLACK - THREADED
2598	!
2599	! USAGE: CALL HAD2_DRY FROM SUBROUTINE DIGITAL_FILTER
2600	! INPUT ARGUMENT LIST:
2601	!
2602	! OUTPUT ARGUMENT LIST
2603	!
2604	! OUTPUT FILES:
2605	! NONE
2606	! SUBPROGRAMS CALLED:
2607	!
2608	! UNIQUE: NONE
2609	!
2610	! LIBRARY: NONE
2611	!
2612	! ATTRIBUTES:
2613	! LANGUAGE: FORTRAN 90
2614	! MACHINE : IBM SP
2615	!$$$
2616	!**********************************************************************
2617	!----------------------------------------------------------------------
2618	!
2619	IMPLICIT NONE
2620	!
2621	!----------------------------------------------------------------------
2622	!
2623	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
2624	& ,IMS,IME,JMS,JME,KMS,KME &
2625	& ,ITS,ITE,JTS,JTE,KTS,KTE
2626	!
2627	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
2628	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
2629	& ,N_IUP_ADH,N_IUP_ADV
2630	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
2631	& ,IUP_ADH,IUP_ADV
2632	! NMM_MAX_DIM is set in configure.wrf and must agree with
2633	! the value of dimspec q in the Registry/Registry
2634	INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
2635	!
2636	INTEGER,INTENT(IN) :: IDTAD,NTSD
2637	!
2638	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
2639	!
2640	REAL,INTENT(IN) :: DT,DY,PDTOP
2641	!
2642	REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
2643	!
2644	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
2645	!
2646	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,U,V,Z
2647	!
2648	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: Q2
2649	!
2650	LOGICAL,INTENT(IN) :: HYDRO
2651	!
2652	!----------------------------------------------------------------------
2653	!
2654	!*** LOCAL VARIABLES
2655	!
2656	REAL,PARAMETER :: FF1=0.530
2657	!
2658	LOGICAL :: BOT,TOP
2659	!
2660	INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP,MPI_COMM_COMP
2661	!
2662	INTEGER,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: IFPA,IFPF &
2663	& ,IFQA,IFQF &
2664	& ,JFPA,JFPF &
2665	& ,JFQA,JFQF
2666	!
2667	REAL :: ADDT,AFRP,CRIT,D2PQE,DEP,DESTIJ,DVOLP,DZA,DZB &
2668	& ,E00,E0Q,E2IJ,E4P,ENH,EP,EP0,ESTIJ,FPQ &
2669	& ,HAFP,HAFQ,HBM2IJ,HM,HTMIKJ,PP,PPQ00 &
2670	& ,QP,RDY,RFACEK,RFC,RFEIJ,RR &
2671	& ,SLOPAC,SPP,SQP,SSA,SSB,SUMNE,SUMPE,TTA,TTB
2672	!
2673	REAL,DIMENSION(2,KTE-KTS+1) :: GSUMS,XSUMS
2674	!
2675	REAL,DIMENSION(KTS:KTE) :: AFR,DEL,E3,E4,RFACE
2676	!
2677	REAL,DIMENSION(IMS:IME,JMS:JME) :: DARE,EMH
2678	!
2679	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: AFP,AFQ,DEST,DVOL &
2680	& ,E1,E2
2681	!
2682	!***********************************************************************
2683	!-----------------------------------------------------------------------
2684	RDY=1./DY
2685	SLOPAC=SLOPHTSQRT(2.)0.5*50.
2686	CRIT=SLOPACREAL(IDTAD)DTRDY1000.
2687	!
2688	ADDT=REAL(IDTAD)*DT
2689	ENH=ADDT/(08.*DY)
2690	!
2691	!-----------------------------------------------------------------------
2692	!$omp parallel do &
2693	!$omp& private(i,j)
2694	DO J=MYJS_P3,MYJE_P3
2695	DO I=MYIS_P2,MYIE_P2
2696	EMH (I,J)=ADDT/(08.*DX(I,J))
2697	DARE(I,J)=HBM3(I,J)DX(I,J)DY
2698	E1(I,KTE,J)=MAX(Q2(I,KTE,J)*0.5,EPSQ2)
2699	E2(I,KTE,J)=E1(I,KTE,J)
2700	ENDDO
2701	ENDDO
2702	!-----------------------------------------------------------------------
2703	!$omp parallel do &
2704	!$omp& private(i,j,k)
2705	DO J=MYJS_P3,MYJE_P3
2706	!
2707	DO K=KTS,KTE
2708	DO I=MYIS_P2,MYIE_P2
2709	DVOL(I,K,J)=DARE(I,J)(DETA1(K)PDTOP+DETA2(K)*PDSL(I,J))
2710	ENDDO
2711	ENDDO
2712	!
2713	DO K=KTE-1,KTS,-1
2714	DO I=MYIS_P2,MYIE_P2
2715	E1(I,K,J)=MAX((Q2(I,K+1,J)+Q2(I,K,J))*0.5,EPSQ2)
2716	E2(I,K,J)=E1(I,K,J)
2717	ENDDO
2718	ENDDO
2719	!
2720	ENDDO
2721	!-----------------------------------------------------------------------
2722	!$omp parallel do &
2723	!$omp& private(dza,dzb,fpq,i,j,jfp,jfq,k,pp,qp,spp,sqp,ssa,ssb,tta,ttb)
2724	DO J=MYJS2_P1,MYJE2_P1
2725	DO K=KTS,KTE
2726	DO I=MYIS1_P1,MYIE1_P1
2727	!
2728	TTA=(U(I,K,J-1)+U(I+IHW(J),K,J)+U(I+IHE(J),K,J)+U(I,K,J+1)) &
2729	& EMH(I,J)HBM2(I,J)
2730	TTB=(V(I,K,J-1)+V(I+IHW(J),K,J)+V(I+IHE(J),K,J)+V(I,K,J+1)) &
2731	& ENHHBM2(I,J)
2732	!
2733	SPP=-TTA-TTB
2734	SQP= TTA-TTB
2735	!
2736	IF(SPP<0.)THEN
2737	JFP=-1
2738	ELSE
2739	JFP=1
2740	ENDIF
2741	IF(SQP<0.)THEN
2742	JFQ=-1
2743	ELSE
2744	JFQ=1
2745	ENDIF
2746	!
2747	IFPA(I,K,J)=IHE(J)+I+( JFP-1)/2
2748	IFQA(I,K,J)=IHE(J)+I+(-JFQ-1)/2
2749	!
2750	JFPA(I,K,J)=J+JFP
2751	JFQA(I,K,J)=J+JFQ
2752	!
2753	IFPF(I,K,J)=IHE(J)+I+(-JFP-1)/2
2754	IFQF(I,K,J)=IHE(J)+I+( JFQ-1)/2
2755	!
2756	JFPF(I,K,J)=J-JFP
2757	JFQF(I,K,J)=J-JFQ
2758	!
2759	!------------------------------------------------------------------------
2760	IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
2761	DZA=(Z(IFPA(I,K,J),K,JFPA(I,K,J))-Z(I,K,J))*RDY
2762	DZB=(Z(IFQA(I,K,J),K,JFQA(I,K,J))-Z(I,K,J))*RDY
2763	!
2764	IF(ABS(DZA)>SLOPAC)THEN
2765	SSA=DZA*SPP
2766	IF(SSA>CRIT)THEN
2767	SPP=0. !spp*.1
2768	ENDIF
2769	ENDIF
2770	!
2771	IF(ABS(DZB)>SLOPAC)THEN
2772	SSB=DZB*SQP
2773	IF(SSB>CRIT)THEN
2774	SQP=0. !sqp*.1
2775	ENDIF
2776	ENDIF
2777	!
2778	ENDIF
2779	!-----------------------------------------------------------------------
2780	SPP=SPP*HTM(IFPA(I,K,J),K,JFPA(I,K,J))
2781	SQP=SQP*HTM(IFQA(I,K,J),K,JFQA(I,K,J))
2782	FPQ=SPPSQPHTM(I,K,J-2)*HTM(I-1,K,J) &
2783	& HTM(I+1,K,J)HTM(I,K,J+2)*0.25
2784	PP=ABS(SPP)
2785	QP=ABS(SQP)
2786	!
2787	AFP(I,K,J)=(((FF4PP+FF3)PP+FF2)PP+FF1)PP
2788	AFQ(I,K,J)=(((FF4QP+FF3)QP+FF2)QP+FF1)QP
2789	!
2790	E2(I,K,J)=(E1 (IFPA(I,K,J),K,JFPA(I,K,J))-E1 (I,K,J))*PP &
2791	& +(E1 (IFQA(I,K,J),K,JFQA(I,K,J))-E1 (I,K,J))*QP &
2792	& +(E1 (I,K,J-2)+E1 (I,K,J+2) &
2793	& -E1 (I-1,K,J)-E1 (I+1,K,J))*FPQ &
2794	& +E1(I,K,J)
2795	!
2796	ENDDO
2797	ENDDO
2798	ENDDO
2799	!
2800	!-----------------------------------------------------------------------
2801	!*** ANTI-FILTERING STEP
2802	!-----------------------------------------------------------------------
2803	!
2804	DO K=KTS,KTE
2805	XSUMS(1,K)=0.
2806	XSUMS(2,K)=0.
2807	ENDDO
2808	!
2809	!--------------ANTI-FILTERING LIMITERS----------------------------------
2810	!
2811	DO 150 J=MYJS2,MYJE2
2812	DO 150 K=KTS,KTE
2813	DO 150 I=MYIS1,MYIE1
2814	!
2815	DVOLP=DVOL(I,K,J)
2816	E2IJ =E2(I,K,J)
2817	!
2818	HAFP=HTM(IFPF(I,K,J),K,JFPF(I,K,J))*AFP(I,K,J)
2819	HAFQ=HTM(IFQF(I,K,J),K,JFQF(I,K,J))*AFQ(I,K,J)
2820	!
2821	D2PQE=(E2(IFPA(I,K,J),K,JFPA(I,K,J))-E2IJ &
2822	& -E2IJ+E2(IFPF(I,K,J),K,JFPF(I,K,J))) &
2823	& *HAFP &
2824	& +(E2(IFQA(I,K,J),K,JFQA(I,K,J))-E2IJ &
2825	& -E2IJ+E2(IFQF(I,K,J),K,JFQF(I,K,J))) &
2826	& *HAFQ
2827	!
2828	ESTIJ=E2IJ-D2PQE
2829	!
2830	E00=E1 (I ,K ,J)
2831	EP0=E1 (IFPA(I,K,J),K,JFPA(I,K,J))
2832	E0Q=E1 (IFQA(I,K,J),K,JFQA(I,K,J))
2833	!
2834	ESTIJ=MAX(ESTIJ,MIN(E00,EP0,E0Q))
2835	ESTIJ=MIN(ESTIJ,MAX(E00,EP0,E0Q))
2836	!
2837	DESTIJ=ESTIJ-E1(I,K,J)
2838	DEST(I,K,J)=DESTIJ
2839	!
2840	DESTIJ=DESTIJ*DVOLP
2841	!
2842	IF(DESTIJ>0.)THEN
2843	XSUMS(1,K)=XSUMS(1,K)+DESTIJ
2844	ELSE
2845	XSUMS(2,K)=XSUMS(2,K)+DESTIJ
2846	ENDIF
2847	!
2848	150 CONTINUE
2849	!-----------------------------------------------------------------------
2850	!
2851	!-----------------------------------------------------------------------
2852	!*** GLOBAL REDUCTION
2853	!-----------------------------------------------------------------------
2854	!
2855	#ifdef DM_PARALLEL
2856	CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
2857	CALL MPI_ALLREDUCE(XSUMS,GSUMS,2*(KTE-KTS+1),MPI_REAL,MPI_SUM &
2858	& ,MPI_COMM_COMP,IRECV)
2859	#else
2860	GSUMS=XSUMS
2861	#endif
2862	!
2863	!-----------------------------------------------------------------------
2864	!*** END OF GLOBAL REDUCTION
2865	!-----------------------------------------------------------------------
2866	!
2867	DO K=KTS,KTE
2868	!
2869	!-----------------------------------------------------------------------
2870	SUMPE=GSUMS(1,K)
2871	SUMNE=GSUMS(2,K)
2872	!
2873	!-----------------------------------------------------------------------
2874	!*** FIRST MOMENT CONSERVING FACTOR
2875	!-----------------------------------------------------------------------
2876	!
2877	IF(SUMPE>1.)THEN
2878	RFACEK=-SUMNE/SUMPE
2879	ELSE
2880	RFACEK=1.
2881	ENDIF
2882	!
2883	IF(RFACEK<CONSERVE_MIN.OR.RFACEK>CONSERVE_MAX)RFACEK=1.
2884	!
2885	RFACE(K)=RFACEK
2886	!
2887	ENDDO
2888	!
2889	!-----------------------------------------------------------------------
2890	!*** IMPOSE CONSERVATION ON ANTI-FILTERING
2891	!-----------------------------------------------------------------------
2892	!$omp parallel do &
2893	!$omp& private(destij,i,j,k,rfacek,rfeij)
2894	DO J=MYJS2,MYJE2
2895	DO K=KTS,KTE
2896	RFACEK=RFACE(K)
2897	IF(RFACEK<1.)THEN
2898	DO I=MYIS1,MYIE1
2899	DESTIJ=DEST(I,K,J)
2900	RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
2901	IF(DESTIJ>=0.)DESTIJ=DESTIJ*RFEIJ
2902	E1(I,K,J)=E1(I,K,J)+DESTIJ
2903	ENDDO
2904	ELSE
2905	DO I=MYIS1,MYIE1
2906	DESTIJ=DEST(I,K,J)
2907	RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
2908	IF(DESTIJ<0.)DESTIJ=DESTIJ/RFEIJ
2909	E1(I,K,J)=E1(I,K,J)+DESTIJ
2910	ENDDO
2911	ENDIF
2912	ENDDO
2913	ENDDO
2914	!-----------------------------------------------------------------------
2915	!$omp parallel do &
2916	!$omp& private(i,j)
2917	DO J=MYJS,MYJE
2918	DO I=MYIS,MYIE
2919	Q2(I,KTE,J)=MAX(E1(I,KTE,J)+E1(I,KTE,J)-EPSQ2,EPSQ2) &
2920	& *HTM(I,KTE,J)
2921	ENDDO
2922	ENDDO
2923	!
2924	!$omp parallel do &
2925	!$omp& private(i,j,k,koff)
2926	DO J=MYJS,MYJE
2927	DO K=KTE-1,KTS+1,-1
2928	DO I=MYIS,MYIE
2929	KOFF=KTE-LMH(I,J)
2930	IF(K>KOFF+1)THEN
2931	Q2(I,K,J)=MAX(E1(I,K,J)+E1(I,K,J)-Q2(I,K+1,J),EPSQ2) &
2932	& *HTM(I,K,J)
2933	ELSE
2934	Q2(I,K,J)=Q2(I,K+1,J)
2935	ENDIF
2936	ENDDO
2937	ENDDO
2938	ENDDO
2939	!-----------------------------------------------------------------------
2940	END SUBROUTINE HAD2_DRY
2941	!-----------------------------------------------------------------------
2942	!-----------------------------------------------------------------------
2943	!^L
2944	! New routines added by Georg Grell to handle advection more like ARW
2945	! core. Instead of VAD2/HAD2 that advect TKE, specific humidity, and
2946	! condensed water species all in one routine, we call VAD2/HAD2_SCAL
2947	! with multidimensioned arrays to advect each variable. For purposes
2948	! here, solve_nmm.F calls this routine once for TKE, then again for
2949	! all the species held in the moist array (qv, qc, qi, qr, qs, qg),
2950	! then call again for number concentrations held in scalar array (qni).
2951	! The dummy argument lstart is the starting index of the multidimensioned
2952	! array for starting the advection since the 1st index of moist and
2953	! scalar are actually empty placeholders (and the 2nd element is vapor,
2954	! then qc, etc.) When calling with single 3D array (like TKE), just
2955	! set NUM_SCAL=1 and lstart=1. The variable to advect is called SCAL
2956	! herein.
2957	!***********************************************************************
2958	SUBROUTINE VAD2_SCAL(NTSD,DT,IDTAD,DX,DY &
2959	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
2960	& ,HBM2,LMH &
2961	& ,SCAL,PETDT &
2962	& ,N_IUP_H,N_IUP_V &
2963	& ,N_IUP_ADH,N_IUP_ADV &
2964	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
2965	& ,IHE,IHW,IVE,IVW,INDX3_WRK &
2966	& ,NUM_SCAL,lstart &
2967	& ,IDS,IDE,JDS,JDE,KDS,KDE &
2968	& ,IMS,IME,JMS,JME,KMS,KME &
2969	& ,ITS,ITE,JTS,JTE,KTS,KTE)
2970	!***********************************************************************
2971	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
2972	! . . .
2973	! SUBPROGRAM: VAD2_SCAL VERTICAL ADVECTION OF SCALARS
2974	!
2975	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
2976	! GRELL,PECKHAM ORG: NOAA/FSL DATE: 05-02-03
2977	!
2978	! ABSTRACT:
2979	! VAD2_SCAL CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION
2980	! TO THE TENDENCIES OF SCALAR SUBSTANCES AND THEN UPDATES
2981	! THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
2982	!
2983	! PROGRAM HISTORY LOG:
2984	! 96-07-19 JANJIC - ORIGINATOR
2985	! 05-02-03 GRELL,PECKHAM - MODIFIED FOR SCALARS
2986	!
2987	! USAGE: CALL VAD2_SCAL FROM SUBROUTINE SOLVE_NMM
2988	! INPUT ARGUMENT LIST:
2989	!
2990	! OUTPUT ARGUMENT LIST
2991	!
2992	! OUTPUT FILES:
2993	! NONE
2994	! SUBPROGRAMS CALLED:
2995	!
2996	! UNIQUE: NONE
2997	!
2998	! LIBRARY: NONE
2999	!
3000	! ATTRIBUTES:
3001	! LANGUAGE: FORTRAN 90
3002	! MACHINE : IBM SP
3003	!$$$
3004	!***********************************************************************
3005	!----------------------------------------------------------------------
3006	!
3007	IMPLICIT NONE
3008	!
3009	!----------------------------------------------------------------------
3010	!
3011	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
3012	& ,IMS,IME,JMS,JME,KMS,KME &
3013	,ITS,ITE,JTS,JTE,KTS,KTE
3014
3015	INTEGER,INTENT(IN) :: NUM_SCAL, lstart
3016	!
3017	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
3018	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
3019	& ,N_IUP_ADH,N_IUP_ADV
3020	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
3021	& ,IUP_ADH,IUP_ADV
3022	! NMM_MAX_DIM is set in configure.wrf and must agree with
3023	! the value of dimspec q in the Registry/Registry
3024	INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
3025	!
3026	INTEGER,INTENT(IN) :: IDTAD,NTSD
3027	!
3028	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
3029	!
3030	REAL,INTENT(IN) :: DT,DY,PDTOP
3031	!
3032	REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
3033	!
3034	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
3035	!
3036	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
3037	!
3038	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,1:NUM_SCAL),INTENT(INOUT) :: SCAL
3039	!
3040	!----------------------------------------------------------------------
3041	!
3042	!*** LOCAL VARIABLES
3043	!
3044	REAL,PARAMETER :: FF1=0.525
3045	!
3046	LOGICAL :: BOT,TOP
3047	!
3048	INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP, L
3049	!
3050	INTEGER,DIMENSION(KTS:KTE) :: LA
3051	!
3052	REAL*8 :: ADDT,AFRP,D2PQE,D2PQQ,D2PQW,DEP,DETAP,DPDN,DPUP,DQP &
3053	& ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ &
3054	& ,Q00,Q4P,QP,QP0 &
3055	& ,RFACEK,RFACQK,RFACWK,RFC,RR &
3056	& ,SUMNE,SUMNQ,SUMNW,SUMPE,SUMPQ,SUMPW &
3057	& ,W00,W4P,WP,WP0
3058	REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4,PETDTK &
3059	& ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
3060	!
3061	!***********************************************************************
3062	!-----------------------------------------------------------------------
3063	!
3064	ADDT=REAL(IDTAD)*DT
3065	!
3066	!-----------------------------------------------------------------------
3067	!
3068	!$omp parallel do &
3069	!$omp& private(afr,afrp,bot,d2pqe,d2pqq,d2pqw,del,dep,detap,dpdn,dpup &
3070	!$omp& ,dql,dqp,dwl,dwp,e00,e3,e4,e4p,ep,ep0,haddt,i,j,k,koff &
3071	!$omp& ,la,lap,llap,petdtk,q00,q3,q4,q4p,qp,qp0,rfacek,rfacqk &
3072	!$omp& ,rfacwk,rfc,rr,sumne,sumnq,sumnw,sumpe,sumpq,sumpw,top &
3073	!$omp& ,w00,w3,w4,w4p,wp,wp0)
3074
3075	scalar_loop : DO L=lstart,NUM_SCAL
3076	main_integration : DO J=MYJS2,MYJE2
3077	!
3078	DO I=MYIS1_P1,MYIE1_P1
3079	!-----------------------------------------------------------------------
3080	KOFF=KTE-LMH(I,J)
3081	!
3082	DO K=KOFF+1,KTE
3083	! Q3(K)=MAX(SCAL(I,K,J,L),EPSILSCALAR)
3084	Q3(K)=SCAL(I,K,J,L)
3085	Q4(K)=Q3(K)
3086	ENDDO
3087	!
3088	PETDTK(KTE)=PETDT(I,KTE-1,J)*0.5
3089	!
3090	DO K=KTE-1,KOFF+2,-1
3091	PETDTK(K)=(PETDT(I,K,J)+PETDT(I,K-1,J))*0.5
3092	ENDDO
3093	!
3094	PETDTK(KOFF+1)=PETDT(I,KOFF+1,J)*0.5
3095	!-----------------------------------------------------------------------
3096	HADDT=-ADDT*HBM2(I,J)
3097	!
3098	DO K=KTE,KOFF+1,-1
3099	RR=PETDTK(K)*HADDT
3100	!
3101	IF(RR<0.)THEN
3102	LAP=1
3103	ELSE
3104	LAP=-1
3105	ENDIF
3106	!
3107	LA(K)=LAP
3108	LLAP=K+LAP
3109	!
3110	TOP=.FALSE.
3111	BOT=.FALSE.
3112	!
3113	IF(LLAP>KOFF.AND.LLAP<KTE+1.AND.LAP/=0)THEN
3114	RR=ABS(RR/((AETA1(LLAP)-AETA1(K))*PDTOP &
3115	& +(AETA2(LLAP)-AETA2(K))*PDSL(I,J)))
3116	!
3117	AFR(K)=(((FF4RR+FF3)RR+FF2)RR+FF1)RR
3118	DQP=(Q3(LLAP)-Q3(K))*RR
3119	DQL(K)=DQP
3120	ELSE
3121	TOP=LLAP==KTE+1
3122	BOT=LLAP==KOFF
3123	!
3124	RR=0.
3125	AFR(K)=0.
3126	DQL(K)=0.
3127	ENDIF
3128	ENDDO
3129	!-----------------------------------------------------------------------
3130	IF(TOP)THEN
3131	IF(LA(KTE-1)>0)THEN
3132	RFC=(DETA1(KTE-1)PDTOP+DETA2(KTE-1)PDSL(I,J)) &
3133	& /(DETA1(KTE )PDTOP+DETA2(KTE )PDSL(I,J))
3134	DQL(KTE)=-DQL(KTE+1)*RFC
3135	ENDIF
3136	ENDIF
3137	!
3138	IF(BOT)THEN
3139	IF(LA(KOFF+2)<0)THEN
3140	RFC=(DETA1(KOFF+2)PDTOP+DETA2(KOFF+2)PDSL(I,J)) &
3141	& /(DETA1(KOFF+1)PDTOP+DETA2(KOFF+1)PDSL(I,J))
3142	DQL(KOFF+1)=-DQL(KOFF+2)*RFC
3143	ENDIF
3144	ENDIF
3145	!
3146	DO K=KOFF+1,KTE
3147	Q4(K)=Q3(K)+DQL(K)
3148	ENDDO
3149	!-----------------------------------------------------------------------
3150	!*** ANTI-FILTERING STEP
3151	!-----------------------------------------------------------------------
3152	SUMPQ=0.
3153	SUMNQ=0.
3154	!
3155	!*** ANTI-FILTERING LIMITERS
3156	!
3157	DO 50 K=KTE-1,KOFF+2,-1
3158	!
3159	DETAP=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
3160	!
3161	Q4P=Q4(K)
3162	!
3163	LAP=LA(K)
3164	!
3165	IF(LAP.NE.0)THEN
3166	DPDN=(AETA1(K+LAP)-AETA1(K))*PDTOP &
3167	& +(AETA2(K+LAP)-AETA2(K))*PDSL(I,J)
3168	DPUP=(AETA1(K)-AETA1(K-LAP))*PDTOP &
3169	& +(AETA2(K)-AETA2(K-LAP))*PDSL(I,J)
3170	!
3171	AFRP=2.AFR(K)DPDN*DPDN/(DPDN+DPUP)
3172	D2PQQ=((Q4(K+LAP)-Q4P)/DPDN &
3173	& -(Q4P-Q4(K-LAP))/DPUP)*AFRP
3174	ELSE
3175	D2PQQ=0.
3176	ENDIF
3177	!
3178	QP=Q4P-D2PQQ
3179	!
3180	Q00=Q3(K)
3181	QP0=Q3(K+LAP)
3182	!
3183	IF(LAP/=0)THEN
3184	QP=MAX(QP,MIN(Q00,QP0))
3185	QP=MIN(QP,MAX(Q00,QP0))
3186	ENDIF
3187	!
3188	DQP=QP-Q00
3189	!
3190	DQL(K)=DQP
3191	!
3192	DQP=DQP*DETAP
3193	!
3194	IF(DQP>0.)THEN
3195	SUMPQ=SUMPQ+DQP
3196	ELSE
3197	SUMNQ=SUMNQ+DQP
3198	ENDIF
3199	!
3200	50 CONTINUE
3201	!-----------------------------------------------------------------------
3202	DQL(KOFF+1)=0.
3203	!
3204	DQL(KTE)=0.
3205	!-----------------------------------------------------------------------
3206	!*** FIRST MOMENT CONSERVING FACTOR
3207	!-----------------------------------------------------------------------
3208	IF(SUMPQ>1.E-9)THEN
3209	RFACQK=-SUMNQ/SUMPQ
3210	ELSE
3211	RFACQK=1.
3212	ENDIF
3213	!
3214	IF(RFACQK<CONSERVE_MIN.OR.RFACQK>CONSERVE_MAX)RFACQK=1.
3215	!-----------------------------------------------------------------------
3216	!*** IMPOSE CONSERVATION ON ANTI-FILTERING
3217	!-----------------------------------------------------------------------
3218	DO K=KTE,KOFF+1,-1
3219	DQP=DQL(K)
3220	IF(DQP>=0.)DQP=DQP*RFACQK
3221	SCAL(I,K,J,L)=Q3(K)+DQP
3222	ENDDO
3223	!
3224	! HBM2IJ=HBM2(I,J)
3225	!-----------------------------------------------------------------------
3226	!-----------------------------------------------------------------------
3227	ENDDO
3228
3229	!
3230	ENDDO main_integration
3231	ENDDO scalar_loop
3232	!-----------------------------------------------------------------------
3233	!-----------------------------------------------------------------------
3234	END SUBROUTINE VAD2_SCAL
3235	!-----------------------------------------------------------------------
3236	!
3237	!***********************************************************************
3238	SUBROUTINE HAD2_SCAL( &
3239	#if defined(DM_PARALLEL)
3240	& domdesc , &
3241	#endif
3242	& NTSD,DT,IDTAD,DX,DY &
3243	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
3244	& ,HTM,HBM2,HBM3,LMH &
3245	& ,SCAL,U,V,Z,HYDRO &
3246	& ,N_IUP_H,N_IUP_V &
3247	& ,N_IUP_ADH,N_IUP_ADV &
3248	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
3249	& ,IHE,IHW,IVE,IVW,INDX3_WRK &
3250	& ,NUM_SCAL,lstart &
3251	& ,IDS,IDE,JDS,JDE,KDS,KDE &
3252	& ,IMS,IME,JMS,JME,KMS,KME &
3253	& ,ITS,ITE,JTS,JTE,KTS,KTE)
3254	!***********************************************************************
3255	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
3256	! . . .
3257	! SUBPROGRAM: HAD2_SCAL HORIZONTAL ADVECTION OF SCALAR
3258	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
3259	! GRELL,PECKHAM ORG: NOAA/FSL DATE: 05-02-03
3260	!
3261	! ABSTRACT:
3262	! HAD2_SCAL CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
3263	! TO THE TENDENCIES OF SCALAR SUBSTANCES AND THEN
3264	! UPDATES THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
3265	!
3266	! PROGRAM HISTORY LOG:
3267	! 96-07-19 JANJIC - ORIGINATOR
3268	! 05-01-03 GRELL,PECKKHAM - MODIFIED FOR SCALAR
3269	!
3270	! USAGE: CALL HAD2_SCAL FROM SUBROUTINE SOLVE_NMM
3271	! INPUT ARGUMENT LIST:
3272	!
3273	! OUTPUT ARGUMENT LIST
3274	!
3275	! OUTPUT FILES:
3276	! NONE
3277	! SUBPROGRAMS CALLED:
3278	!
3279	! UNIQUE: NONE
3280	!
3281	! LIBRARY: NONE
3282	!
3283	! ATTRIBUTES:
3284	! LANGUAGE: FORTRAN 90
3285	! MACHINE : IBM SP
3286	!$$$
3287	!***********************************************************************
3288	!-----------------------------------------------------------------------
3289	!
3290	IMPLICIT NONE
3291	!
3292	!-----------------------------------------------------------------------
3293	!
3294	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
3295	& ,IMS,IME,JMS,JME,KMS,KME &
3296	& ,ITS,ITE,JTS,JTE,KTS,KTE
3297
3298	INTEGER,INTENT(IN) :: NUM_SCAL, lstart
3299	!
3300	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
3301	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
3302	& ,N_IUP_ADH,N_IUP_ADV
3303	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
3304	& ,IUP_ADH,IUP_ADV
3305	!-----------------------------------------------------------------------
3306	!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3307	! NMM_MAX_DIM is set in configure.wrf and must agree with the value of
3308	! dimspec q in Registry/Registry.
3309	!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3310	!-----------------------------------------------------------------------
3311	INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
3312	!
3313	INTEGER,INTENT(IN) :: IDTAD,NTSD
3314	!
3315	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
3316	!
3317	REAL,INTENT(IN) :: DT,DY,PDTOP
3318	!
3319	REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
3320	!
3321	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
3322	!
3323	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,U,V,Z
3324	!
3325	!!!!! q is local. CORRECT DIMENSION???
3326	!jjjj
3327	!!!!! REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: Q
3328	REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,JTS-5:JTE+5) :: Q
3329	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,NUM_SCAL),INTENT(INOUT) :: SCAL
3330	!
3331	LOGICAL,INTENT(IN) :: HYDRO
3332	!
3333	!-----------------------------------------------------------------------
3334	!
3335	!*** LOCAL VARIABLES
3336	!
3337	REAL,PARAMETER :: FF1=0.530
3338	!
3339	#ifdef DM_PARALLEL
3340	INTEGER :: DOMDESC
3341	#endif
3342	!
3343	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
3344	LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
3345	INTEGER :: N
3346	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,6) :: XSUMS_L
3347	REAL,DIMENSION(IDS:IDE,KDS:KDE,JDS:JDE,6) :: XSUMS_G
3348	#endif
3349	!
3350	LOGICAL :: BOT,TOP
3351	!
3352	INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP,MPI_COMM_COMP, L
3353	!
3354	INTEGER,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: IFPA,IFPF &
3355	& ,IFQA,IFQF &
3356	& ,JFPA,JFPF &
3357	& ,JFQA,JFQF
3358	!
3359	REAL :: ADDT,AFRP,CRIT,D2PQE,D2PQQ,D2PQW,DEP,DESTIJ,DQP,DQSTIJ &
3360	& ,DVOLP,DWP,DWSTIJ,DZA,DZB,E00,E0Q,E1X,E2IJ,E4P,ENH,EP,EP0 &
3361	& ,ESTIJ,FPQ,HAFP,HAFQ,HBM2IJ,HM,HTMIKJ,PP,PPQ00,Q00,Q0Q &
3362	& ,Q1IJ,Q4P,QP,QP0,QSTIJ,RDY,RFACEK,RFACQK,RFACWK,RFC &
3363	& ,RFEIJ,RFQIJ,RFWIJ,RR,SLOPAC,SPP,SQP,SSA,SSB,SUMNE,SUMNQ &
3364	& ,SUMNW,SUMPE,SUMPQ,SUMPW,TTA,TTB,W00,W0Q,W1IJ,W4P,WP,WP0 &
3365	& ,WSTIJ
3366	!
3367	DOUBLE PRECISION,DIMENSION(6,KTE-KTS+1) :: GSUMS,XSUMS
3368	!
3369	REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4 &
3370	& ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
3371	!
3372	REAL,DIMENSION(IMS:IME,JMS:JME) :: DARE,EMH
3373	!
3374	REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,JTS-5:JTE+5) :: AFP,AFQ,DEST &
3375	& ,DQST,DVOL,DWST &
3376	& ,E1,E2,Q1,W1
3377	integer :: nunit,ier
3378	save nunit
3379	!***********************************************************************
3380	!-----------------------------------------------------------------------
3381	!
3382	RDY=1./DY
3383	SLOPAC=SLOPHTSQRT(2.)0.5*50.
3384	CRIT=SLOPACREAL(IDTAD)DTRDY1000.
3385	!
3386	ADDT=REAL(IDTAD)*DT
3387	ENH=ADDT/(08.*DY)
3388	!
3389	!-----------------------------------------------------------------------
3390	!
3391	SCALAR_LOOP : DO L=lstart,NUM_SCAL
3392	!
3393	!-----------------------------------------------------------------------
3394	!$omp parallel do &
3395	!$omp& private(i,j)
3396	DO J=MYJS_P3,MYJE_P3
3397	DO I=MYIS_P2,MYIE_P2
3398	EMH (I,J)=ADDT/(08.*DX(I,J))
3399	DARE(I,J)=HBM3(I,J)DX(I,J)DY
3400	! E1(I,KTE,J)=MAX(Q2(I,KTE,J)*0.5,EPSQ2)
3401	! E2(I,KTE,J)=E1(I,KTE,J)
3402	ENDDO
3403	ENDDO
3404	!-----------------------------------------------------------------------
3405	!
3406	!$omp parallel do &
3407	!$omp& private(e1x,htmikj,i,j,k)
3408	DO J=MYJS_P3,MYJE_P3
3409	DO K=KTS,KTE
3410	DO I=MYIS_P2,MYIE_P2
3411	DVOL(I,K,J)=DARE(I,J)(DETA1(K)PDTOP+DETA2(K)*PDSL(I,J))
3412	HTMIKJ=HTM(I,K,J)
3413	! Q (I,K,J)=MAX(SCAL(I,K,J,L),EPSILSCALAR)*HTMIKJ
3414	Q (I,K,J)=SCAL(I,K,J,L)*HTMIKJ
3415	Q1 (I,K,J)=Q (I,K,J)
3416	ENDDO
3417	ENDDO
3418	!
3419	ENDDO
3420	!-----------------------------------------------------------------------
3421	!$omp parallel do &
3422	!$omp& private(dza,dzb,fpq,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp,tta,ttb)
3423	DO J=MYJS2_P1,MYJE2_P1
3424	DO K=KTS,KTE
3425	DO I=MYIS1_P1,MYIE1_P1
3426	!
3427	TTA=(U(I,K,J-1)+U(I+IHW(J),K,J)+U(I+IHE(J),K,J)+U(I,K,J+1)) &
3428	& EMH(I,J)HBM2(I,J)
3429	TTB=(V(I,K,J-1)+V(I+IHW(J),K,J)+V(I+IHE(J),K,J)+V(I,K,J+1)) &
3430	& ENHHBM2(I,J)
3431	!
3432	SPP=-TTA-TTB
3433	SQP= TTA-TTB
3434	!
3435	IF(SPP<0.)THEN
3436	JFP=-1
3437	ELSE
3438	JFP=1
3439	ENDIF
3440	IF(SQP<0.)THEN
3441	JFQ=-1
3442	ELSE
3443	JFQ=1
3444	ENDIF
3445	!
3446	IFPA(I,K,J)=IHE(J)+I+( JFP-1)/2
3447	IFQA(I,K,J)=IHE(J)+I+(-JFQ-1)/2
3448	!
3449	JFPA(I,K,J)=J+JFP
3450	JFQA(I,K,J)=J+JFQ
3451	!
3452	IFPF(I,K,J)=IHE(J)+I+(-JFP-1)/2
3453	IFQF(I,K,J)=IHE(J)+I+( JFQ-1)/2
3454	!
3455	JFPF(I,K,J)=J-JFP
3456	JFQF(I,K,J)=J-JFQ
3457	!
3458	!-----------------------------------------------------------------------
3459	IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
3460	DZA=(Z(IFPA(I,K,J),K,JFPA(I,K,J))-Z(I,K,J))*RDY
3461	DZB=(Z(IFQA(I,K,J),K,JFQA(I,K,J))-Z(I,K,J))*RDY
3462	!
3463	IF(ABS(DZA)>SLOPAC)THEN
3464	SSA=DZA*SPP
3465	IF(SSA>CRIT)THEN
3466	SPP=0. !spp*.1
3467	ENDIF
3468	ENDIF
3469	!
3470	IF(ABS(DZB)>SLOPAC)THEN
3471	SSB=DZB*SQP
3472	IF(SSB>CRIT)THEN
3473	SQP=0. !sqp*.1
3474	ENDIF
3475	ENDIF
3476	!
3477	ENDIF
3478	!-----------------------------------------------------------------------
3479	SPP=SPP*HTM(IFPA(I,K,J),K,JFPA(I,K,J))
3480	SQP=SQP*HTM(IFQA(I,K,J),K,JFQA(I,K,J))
3481	FPQ=SPPSQPHTM(I,K,J-2)*HTM(I-1,K,J) &
3482	& HTM(I+1,K,J)HTM(I,K,J+2)*0.25
3483	PP=ABS(SPP)
3484	QP=ABS(SQP)
3485	!
3486	AFP(I,K,J)=(((FF4PP+FF3)PP+FF2)PP+FF1)PP
3487	AFQ(I,K,J)=(((FF4QP+FF3)QP+FF2)QP+FF1)QP
3488	!
3489	Q1(I,K,J)=(Q (IFPA(I,K,J),K,JFPA(I,K,J))-Q (I,K,J))*PP &
3490	& +(Q (IFQA(I,K,J),K,JFQA(I,K,J))-Q (I,K,J))*QP &
3491	& +(Q (I,K,J-2)+Q (I,K,J+2) &
3492	& -Q (I-1,K,J)-Q (I+1,K,J))*FPQ &
3493	& +Q(I,K,J)
3494	!
3495	ENDDO
3496	ENDDO
3497	ENDDO
3498	!
3499	!-----------------------------------------------------------------------
3500	!*** ANTI-FILTERING STEP
3501	!-----------------------------------------------------------------------
3502	!
3503	DO K=KTS,KTE
3504	XSUMS(1,K)=0.
3505	XSUMS(2,K)=0.
3506	XSUMS(3,K)=0.
3507	XSUMS(4,K)=0.
3508	XSUMS(5,K)=0.
3509	XSUMS(6,K)=0.
3510	ENDDO
3511	!-----------------------------------------------------------------------
3512	!
3513	!*** ANTI-FILTERING LIMITERS
3514	!
3515	!-----------------------------------------------------------------------
3516	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
3517	DO N=1,6
3518	!
3519	!$omp parallel do &
3520	!$omp& private(i,j,k)
3521	DO J=JMS,JME
3522	DO K=KMS,KME
3523	DO I=IMS,IME
3524	XSUMS_L(I,K,J,N)=0.
3525	ENDDO
3526	ENDDO
3527	ENDDO
3528	!
3529	!$omp parallel do &
3530	!$omp& private(i,j,k)
3531	DO J=JDS,JDE
3532	DO K=KDS,KDE
3533	DO I=IDS,IDE
3534	XSUMS_G(I,K,J,N)=0.
3535	ENDDO
3536	ENDDO
3537	ENDDO
3538	!
3539	ENDDO
3540	!
3541	#endif
3542	!-----------------------------------------------------------------------
3543	DO 150 J=MYJS2,MYJE2
3544	DO 150 K=KTS,KTE
3545	DO 150 I=MYIS1,MYIE1
3546	!
3547	DVOLP=DVOL(I,K,J)
3548	Q1IJ =Q1(I,K,J)
3549	W1IJ =W1(I,K,J)
3550	E2IJ =E2(I,K,J)
3551	!
3552	HAFP=HTM(IFPF(I,K,J),K,JFPF(I,K,J))*AFP(I,K,J)
3553	HAFQ=HTM(IFQF(I,K,J),K,JFQF(I,K,J))*AFQ(I,K,J)
3554	!
3555	D2PQQ=(Q1(IFPA(I,K,J),K,JFPA(I,K,J))-Q1IJ &
3556	& -Q1IJ+Q1(IFPF(I,K,J),K,JFPF(I,K,J))) &
3557	& *HAFP &
3558	& +(Q1(IFQA(I,K,J),K,JFQA(I,K,J))-Q1IJ &
3559	& -Q1IJ+Q1(IFQF(I,K,J),K,JFQF(I,K,J))) &
3560	& *HAFQ
3561	!
3562	QSTIJ=Q1IJ-D2PQQ
3563	!
3564	Q00=Q (I ,K ,J)
3565	QP0=Q (IFPA(I,K,J),K,JFPA(I,K,J))
3566	Q0Q=Q (IFQA(I,K,J),K,JFQA(I,K,J))
3567	!
3568	QSTIJ=MAX(QSTIJ,MIN(Q00,QP0,Q0Q))
3569	QSTIJ=MIN(QSTIJ,MAX(Q00,QP0,Q0Q))
3570	!
3571	DQSTIJ=QSTIJ-Q(I,K,J)
3572	!
3573	DQST(I,K,J)=DQSTIJ
3574	!
3575	DQSTIJ=DQSTIJ*DVOLP
3576	!
3577	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
3578	DO N=1,6
3579	XSUMS_L(I,K,J,N)=0.
3580	ENDDO
3581	!
3582	IF(DQSTIJ>0.)THEN
3583	XSUMS_L(I,K,J,1)=DQSTIJ
3584	ELSE
3585	XSUMS_L(I,K,J,2)=DQSTIJ
3586	ENDIF
3587	!
3588	#else
3589	IF(DQSTIJ>0.)THEN
3590	XSUMS(1,K)=XSUMS(1,K)+DQSTIJ
3591	ELSE
3592	XSUMS(2,K)=XSUMS(2,K)+DQSTIJ
3593	ENDIF
3594	!
3595	#endif
3596	!
3597	150 CONTINUE
3598	!
3599	!-----------------------------------------------------------------------
3600	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
3601	DO N=1,6
3602	CALL WRF_PATCH_TO_GLOBAL_REAL( XSUMS_L(IMS,KMS,JMS,N) &
3603	&, XSUMS_G(1,1,1,N),DOMDESC &
3604	&, 'xyz','xzy' &
3605	&, IDS,IDE,KDS,KDE,JDS,JDE &
3606	&, IMS,IME,KMS,KME,JMS,JME &
3607	&, ITS,ITE,KTS,KTE,JTS,JTE )
3608	ENDDO
3609	!
3610	GSUMS=0.
3611	!
3612	IF(WRF_DM_ON_MONITOR())THEN
3613	DO N=1,6
3614	!$omp parallel do &
3615	!$omp& private(i,j,k)
3616	DO J=JDS,JDE
3617	DO K=KDS,KDE
3618	DO I=IDS,IDE
3619	GSUMS(N,K)=GSUMS(N,K)+XSUMS_G(I,K,J,N)
3620	ENDDO
3621	ENDDO
3622	ENDDO
3623	ENDDO
3624	ENDIF
3625
3626	CALL WRF_DM_BCAST_BYTES(GSUMS,2RWORDSIZE6*(KDE-KDS+1) )
3627
3628	#else
3629	!-----------------------------------------------------------------------
3630	!
3631	!-----------------------------------------------------------------------
3632	!*** GLOBAL REDUCTION
3633	!-----------------------------------------------------------------------
3634	!
3635	# ifdef DM_PARALLEL
3636	CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
3637	CALL MPI_ALLREDUCE(XSUMS,GSUMS,6*(KTE-KTS+1) &
3638	& ,MPI_DOUBLE_PRECISION,MPI_SUM &
3639	& ,MPI_COMM_COMP,IRECV)
3640	# else
3641	GSUMS=XSUMS
3642	# endif
3643	#endif
3644	!
3645	!-----------------------------------------------------------------------
3646	!*** END OF GLOBAL REDUCTION
3647	!-----------------------------------------------------------------------
3648	!
3649	! if(mype==0)then
3650	! if(ntsd==0)then
3651	!! call int_get_fresh_handle(nunit)
3652	!! close(nunit)
3653	! nunit=56
3654	! open(unit=nunit,file='gsums',form='unformatted',iostat=ier)
3655	! endif
3656	! endif
3657	DO K=KTS,KTE
3658	! if(mype==0)then
3659	! write(nunit)(gsums(i,k),i=1,6)
3660	! endif
3661	!
3662	!-----------------------------------------------------------------------
3663	SUMPQ=GSUMS(1,K)
3664	SUMNQ=GSUMS(2,K)
3665	!
3666	!-----------------------------------------------------------------------
3667	!*** FIRST MOMENT CONSERVING FACTOR
3668	!-----------------------------------------------------------------------
3669	!
3670	IF(SUMPQ>1.)THEN
3671	RFACQK=-SUMNQ/SUMPQ
3672	ELSE
3673	RFACQK=1.
3674	ENDIF
3675	!
3676	IF(RFACQK<CONSERVE_MIN.OR.RFACQK>CONSERVE_MAX)RFACQK=1.
3677	!
3678	RFACQ(K)=RFACQK
3679	!
3680	ENDDO
3681	! if(mype==0.and.ntsd==181)close(nunit)
3682	!
3683	!-----------------------------------------------------------------------
3684	!*** IMPOSE CONSERVATION ON ANTI-FILTERING
3685	!-----------------------------------------------------------------------
3686	!$omp parallel do &
3687	!$omp& private(dqstij,i,j,k,rfacqk,rfqij)
3688	DO J=MYJS2,MYJE2
3689	DO K=KTS,KTE
3690	RFACQK=RFACQ(K)
3691	IF(RFACQK<1.)THEN
3692	DO I=MYIS1,MYIE1
3693	DQSTIJ=DQST(I,K,J)
3694	RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
3695	IF(DQSTIJ>=0.)DQSTIJ=DQSTIJ*RFQIJ
3696	Q(I,K,J)=Q(I,K,J)+DQSTIJ
3697	ENDDO
3698	ELSE
3699	DO I=MYIS1,MYIE1
3700	DQSTIJ=DQST(I,K,J)
3701	RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
3702	IF(DQSTIJ<0.)DQSTIJ=DQSTIJ/RFQIJ
3703	Q(I,K,J)=Q(I,K,J)+DQSTIJ
3704	ENDDO
3705	ENDIF
3706	ENDDO
3707	ENDDO
3708	!-----------------------------------------------------------------------
3709	!$omp parallel do &
3710	!$omp& private(i,j,k)
3711	DO J=MYJS,MYJE
3712	DO K=KTS,KTE
3713	DO I=MYIS,MYIE
3714	! SCAL(I,K,J,L)=MAX(Q (I,K,J),EPSILSCALAR)*HTM(I,K,J)
3715	SCAL(I,K,J,L)=Q (I,K,J)*HTM(I,K,J)
3716	ENDDO
3717	ENDDO
3718	ENDDO
3719
3720	ENDDO SCALAR_LOOP
3721	!-----------------------------------------------------------------------
3722	END SUBROUTINE HAD2_SCAL
3723	!-----------------------------------------------------------------------
3724	!-----------------------------------------------------------------------
3725	END MODULE MODULE_ADVECTION
3726	!-----------------------------------------------------------------------
3727

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

Download in other formats:

Original Format