Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_ADVECTION.F @ 3567

Last change on this file since 3567 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 101.7 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	#if defined(DM_PARALLEL) && !defined(STUBMPI)
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	& ,HBM2,VBM2 &
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 &
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	! 05-12-14 BLACK - CONVERTED FROM IKJ TO IJK
88	!
89	! USAGE: CALL ADVE FROM SUBROUTINE SOLVE_NMM
90	! INPUT ARGUMENT LIST:
91	!
92	! OUTPUT ARGUMENT LIST:
93	!
94	! OUTPUT FILES:
95	! NONE
96	!
97	! SUBPROGRAMS CALLED:
98	!
99	! UNIQUE: NONE
100	!
101	! LIBRARY: NONE
102	!
103	! ATTRIBUTES:
104	! LANGUAGE: FORTRAN 90
105	! MACHINE : IBM SP
106	!$$$
107	!***********************************************************************
108	!-----------------------------------------------------------------------
109	!
110	IMPLICIT NONE
111	!
112	!-----------------------------------------------------------------------
113	!
114	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
115	& ,IMS,IME,JMS,JME,KMS,KME &
116	& ,ITS,ITE,JTS,JTE,KTS,KTE
117	!
118	INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW &
119	,N_IUP_H,N_IUP_V &
120	& ,N_IUP_ADH,N_IUP_ADV
121	!
122	INTEGER, DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
123	& ,IUP_ADH,IUP_ADV
124	!
125	INTEGER,INTENT(IN) :: NTSD
126	!
127	REAL,INTENT(IN) :: DT,DY,EN,ENT,F4D,PDTOP
128	!
129	REAL,DIMENSION(NMM_MAX_DIM),INTENT(IN) :: EM_LOC,EMT_LOC
130	!
131	REAL,DIMENSION(KMS:KME),INTENT(IN) :: DETA1,DETA2
132	!
133	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CURV,DX,F,FAD,HBM2 &
134	& ,PDSLO,VBM2
135	!
136	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: ADT,ADU,ADV
137	!
138	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PETDT
139	!
140	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: T,TOLD &
141	& ,U,UOLD &
142	& ,V,VOLD
143	!
144	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: FEW,FNE &
145	& ,FNS,FSE
146	!
147	!-----------------------------------------------------------------------
148	!*** LOCAL VARIABLES
149	!-----------------------------------------------------------------------
150	!
151	LOGICAL :: UPSTRM
152	!
153	INTEGER :: I,IEND,IFP,IFQ,II,IPQ,ISP,ISQ,ISTART &
154	& ,IUP_ADH_J,IVH,IVL &
155	& ,J,J1,JA,JAK,JEND,JGLOBAL,JJ,JKNT,JP2,JSTART &
156	& ,K,KNTI_ADH,KSTART,KSTOP &
157	& ,N,N_IUPH_J,N_IUPADH_J,N_IUPADV_J
158	!
159	INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB
160	!
161	INTEGER,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: ISPA,ISQA
162	!
163	REAL :: ADPDX,ADPDY,ARRAY3_X,CFL,CFT,CFU,CFV,CMT,CMU,CMV &
164	& ,DTE,DTQ,F0,F1,F2,F3,FEWP,FNEP,FNSP,FPP,FSEP,HM &
165	& ,PDOP,PDOPU,PDOPV,PP &
166	& ,PVVLO,PVVLOU,PVVLOV,PVVUP,PVVUPU,PVVUPV &
167	& ,QP,RDP,RDPU,RDPV &
168	& ,TEMPA,TEMPB,TTA,TTB,UDY &
169	& ,VDX,VM,VVLO,VVLOU,VVLOV,VVUP,VVUPU,VVUPV
170	!
171	REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: ARRAY0,ARRAY1 &
172	& ,ARRAY2,ARRAY3 &
173	& ,DPDE,RDPD,RDPDX,RDPDY &
174	& ,TEW,TNE,TNS,TSE,TST &
175	& ,UNE,UNED,UEW,UNS,USE &
176	& ,USED,UST &
177	& ,VEW,VNE,VNS,VSE &
178	& ,VST
179	!
180	REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5,KTS:KTE) :: VAD_TEND_T &
181	& ,VAD_TEND_U &
182	& ,VAD_TEND_V
183	!
184	REAL,DIMENSION(KTS:KTE) :: CRT,CRU,CRV,DETA1_PDTOP &
185	& ,RCMT,RCMU,RCMV,RSTT,RSTU,RSTV &
186	& ,T_K,TN,U_K,UN,V_K,VN
187	!
188	!-----------------------------------------------------------------------
189	!***********************************************************************
190	!
191	! DPDE ----- 3
192	! \| J Increasing
193	! \|
194	! \| ^
195	! FNS ----- 2 \|
196	! \| \|
197	! \| \|
198	! \| \|
199	! VNS ----- 1 \|
200	! \|
201	! \|
202	! \|
203	! ADV ----- 0 ------> Current J
204	! \|
205	! \|
206	! \|
207	! VNS ----- -1
208	! \|
209	! \|
210	! \|
211	! FNS ----- -2
212	! \|
213	! \|
214	! \|
215	! DPDE ----- -3
216	!
217	!***********************************************************************
218	!-----------------------------------------------------------------------
219	DO J=JTS-5,JTE+5
220	DO I=ITS-5,ITE+5
221	ARRAY0(I,J)=0.0
222	ARRAY1(I,J)=0.0
223	ARRAY2(I,J)=0.0
224	ARRAY3(I,J)=0.0
225	DPDE(I,J)=0.0
226	RDPD(I,J)=0.0
227	RDPDX(I,J)=0.0
228	RDPDY(I,J)=0.0
229	TEW(I,J)=0.0
230	TNE(I,J)=0.0
231	TNS(I,J)=0.0
232	TSE(I,J)=0.0
233	TST(I,J)=0.0
234	UNE(I,J)=0.0
235	UNED(I,J)=0.0
236	UEW(I,J)=0.0
237	UNS(I,J)=0.0
238	USE(I,J)=0.0
239	USED(I,J)=0.0
240	UST(I,J)=0.0
241	VEW(I,J)=0.0
242	VNE(I,J)=0.0
243	VNS(I,J)=0.0
244	VSE(I,J)=0.0
245	VST(I,J)=0.0
246	ENDDO
247	ENDDO
248	!-----------------------------------------------------------------------
249	!
250	DTQ=DT*0.25
251	DTE=DT(0.50.25)
252	!
253	!-----------------------------------------------------------------------
254	!***
255	!*** PRECOMPUTE DETA1 TIMES PDTOP.
256	!***
257	!-----------------------------------------------------------------------
258	!
259	DO K=KTS,KTE
260	DETA1_PDTOP(K)=DETA1(K)*PDTOP
261	ENDDO
262	!
263	!-----------------------------------------------------------------------
264	!***
265	!*** INITIALIZE SOME WORKING ARRAYS TO ZERO
266	!***
267	!
268	!-----------------------------------------------------------------------
269	!-----------------------------------------------------------------------
270	!
271	!*** COMPUTE VERTICAL ADVECTION TENDENCIES USING CRANK-NICHOLSON.
272	!
273	!-----------------------------------------------------------------------
274	!-----------------------------------------------------------------------
275	!
276	!-----------------------------------------------------------------------
277	!*** FIRST THE TEMPERATURE
278	!-----------------------------------------------------------------------
279	!$omp parallel do &
280	!$omp& private(cft,cfu,cfv,cmt,cmu,cmv,crt,cru,crv,i,k &
281	!$omp& ,pdop,pdopu,pdopv,pvvlo,pvvlou,pvvlov,pvvup,pvvupu,pvvupv &
282	!$omp& ,rcmt,rcmu,rcmv,rdp,rdpu,rdpv,rstt,rstu,rstv,t_k,tn &
283	!$omp& ,u_k,un,v_k,vn,vvlo,vvlou,vvlov,vvup,vvupu,vvupv)
284	!!$omp& private(adtp,adup,advp,ttlo,ttup,tulo,tuup,tvlo,tvup)
285	!-----------------------------------------------------------------------
286	!
287	main_vertical: DO J=MYJS2,MYJE2
288	!
289	!-----------------------------------------------------------------------
290	!
291	iloop_for_t: DO I=MYIS1,MYIE1
292	!
293	!-----------------------------------------------------------------------
294	!*** EXTRACT T FROM THE COLUMN
295	!-----------------------------------------------------------------------
296	!
297	DO K=KTS,KTE
298	T_K(K)=T(I,J,K)
299	ENDDO
300	!
301	!-----------------------------------------------------------------------
302	!
303	PDOP=PDSLO(I,J)
304	PVVLO=PETDT(I,J,KTE-1)*DTQ
305	VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
306	CMT=-VVLO*WGT2+1.
307	RCMT(KTE)=1./CMT
308	CRT(KTE)=VVLO*WGT2
309	RSTT(KTE)=-VVLOWGT1(T_K(KTE-1)-T_K(KTE))+T_K(KTE)
310	!
311	!-----------------------------------------------------------------------
312	!
313	DO K=KTE-1,KTS+1,-1
314	RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
315	PVVUP=PVVLO
316	PVVLO=PETDT(I,J,K-1)*DTQ
317	VVUP=PVVUP*RDP
318	VVLO=PVVLO*RDP
319	CFT=-VVUPWGT2RCMT(K+1)
320	CMT=-CRT(K+1)CFT+((VVUP-VVLO)WGT2+1.)
321	RCMT(K)=1./CMT
322	CRT(K)=VVLO*WGT2
323	RSTT(K)=-RSTT(K+1)*CFT+T_K(K) &
324	& -(T_K(K)-T_K(K+1))VVUPWGT1 &
325	& -(T_K(K-1)-T_K(K))VVLOWGT1
326	ENDDO
327	!
328	!-----------------------------------------------------------------------
329	!
330	PVVUP=PVVLO
331	VVUP=PVVUP/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOP)
332	CFT=-VVUPWGT2RCMT(KTS+1)
333	CMT=-CRT(KTS+1)CFT+VVUPWGT2+1.
334	CRT(KTS)=0.
335	RSTT(KTS)=-(T_K(KTS)-T_K(KTS+1))VVUPWGT1 &
336	& -RSTT(KTS+1)*CFT+T_K(KTS)
337	TN(KTS)=RSTT(KTS)/CMT
338	VAD_TEND_T(I,J,KTS)=TN(KTS)-T_K(KTS)
339	!
340	DO K=KTS+1,KTE
341	TN(K)=(-CRT(K)TN(K-1)+RSTT(K))RCMT(K)
342	VAD_TEND_T(I,J,K)=TN(K)-T_K(K)
343	ENDDO
344	!
345	!-----------------------------------------------------------------------
346	!*** The following section is only for checking the implicit solution
347	!*** using back-substitution. Remove this section otherwise.
348	!-----------------------------------------------------------------------
349	! if(ntsd<=10.or.ntsd>=6000)then
350	! IF(I==ITEST.AND.J==JTEST)THEN
351	!!
352	! PVVLO=PETDT(I,J,KTE-1)DT0.25
353	! VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
354	! TTLO=VVLO*(T(I,J,KTE-1)-T(I,J,KTE) &
355	! & +TN(KTE-1)-TN(KTE))
356	! ADTP=TTLO+TN(KTE)-T(I,J,KTE)
357	! WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',KTE &
358	! &, ' ADTP=',ADTP
359	! WRITE(0,*)' T=',T(I,J,KTE),' TN=',TN(KTE) &
360	! &, ' VAD_TEND_T=',VAD_TEND_T(I,J,KTE)
361	! WRITE(0,*)' '
362	!!
363	! DO K=KTE-1,KTS+1,-1
364	! RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
365	! PVVUP=PVVLO
366	! PVVLO=PETDT(I,J,K-1)DT0.25
367	! VVUP=PVVUP*RDP
368	! VVLO=PVVLO*RDP
369	! TTUP=VVUP*(T(I,J,K)-T(I,J,K+1)+TN(K)-TN(K+1))
370	! TTLO=VVLO*(T(I,J,K-1)-T(I,J,K)+TN(K-1)-TN(K))
371	! ADTP=TTLO+TTUP+TN(K)-T(I,J,K)
372	! WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',K &
373	! &, ' ADTP=',ADTP
374	! WRITE(0,*)' T=',T(I,J,K),' TN=',TN(K) &
375	! &, ' VAD_TEND_T=',VAD_TEND_T(I,J,K)
376	! WRITE(0,*)' '
377	! ENDDO
378	!!
379	! PVVUP=PVVLO
380	! VVUP=PVVUP/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOP)
381	! TTUP=VVUP*(T(I,J,KTS)-T(I,J,KTS+1)+TN(KTS)-TN(KTS+1))
382	! ADTP=TTUP+TN(KTS)-T(I,J,KTS)
383	! WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',KTS &
384	! &, ' ADTP=',ADTP
385	! WRITE(0,*)' T=',T(I,J,KTS),' TN=',TN(KTS) &
386	! &, ' VAD_TEND_T=',VAD_TEND_T(I,J,KTS)
387	! WRITE(0,*)' '
388	! ENDIF
389	! endif
390	!
391	!-----------------------------------------------------------------------
392	!*** End of check.
393	!-----------------------------------------------------------------------
394	!
395	ENDDO iloop_for_t
396	!
397	!-----------------------------------------------------------------------
398	!
399	!*** NOW VERTICAL ADVECTION OF WIND COMPONENTS
400	!
401	!-----------------------------------------------------------------------
402	!
403	iloop_for_uv: DO I=MYIS1,MYIE1
404	!
405	!-----------------------------------------------------------------------
406	!*** EXTRACT U AND V FROM THE COLUMN
407	!-----------------------------------------------------------------------
408	!
409	DO K=KTS,KTE
410	U_K(K)=U(I,J,K)
411	V_K(K)=V(I,J,K)
412	ENDDO
413	!
414	!-----------------------------------------------------------------------
415	!
416	PDOPU=(PDSLO(I+IVW(J),J)+PDSLO(I+IVE(J),J))*0.5
417	PDOPV=(PDSLO(I,J-1)+PDSLO(I,J+1))*0.5
418	PVVLOU=(PETDT(I+IVW(J),J,KTE-1)+PETDT(I+IVE(J),J,KTE-1))*DTE
419	PVVLOV=(PETDT(I,J-1,KTE-1)+PETDT(I,J+1,KTE-1))*DTE
420	VVLOU=PVVLOU/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPU)
421	VVLOV=PVVLOV/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPV)
422	CMU=-VVLOU*WGT2+1.
423	CMV=-VVLOV*WGT2+1.
424	RCMU(KTE)=1./CMU
425	RCMV(KTE)=1./CMV
426	CRU(KTE)=VVLOU*WGT2
427	CRV(KTE)=VVLOV*WGT2
428	RSTU(KTE)=-VVLOUWGT1(U_K(KTE-1)-U_K(KTE))+U_K(KTE)
429	RSTV(KTE)=-VVLOVWGT1(V_K(KTE-1)-V_K(KTE))+V_K(KTE)
430	!
431	!-----------------------------------------------------------------------
432	!
433	DO K=KTE-1,KTS+1,-1
434	RDPU=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPU)
435	RDPV=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPV)
436	PVVUPU=PVVLOU
437	PVVUPV=PVVLOV
438	PVVLOU=(PETDT(I+IVW(J),J,K-1)+PETDT(I+IVE(J),J,K-1))*DTE
439	PVVLOV=(PETDT(I,J-1,K-1)+PETDT(I,J+1,K-1))*DTE
440	VVUPU=PVVUPU*RDPU
441	VVUPV=PVVUPV*RDPV
442	VVLOU=PVVLOU*RDPU
443	VVLOV=PVVLOV*RDPV
444	CFU=-VVUPUWGT2RCMU(K+1)
445	CFV=-VVUPVWGT2RCMV(K+1)
446	CMU=-CRU(K+1)CFU+(VVUPU-VVLOU)WGT2+1.
447	CMV=-CRV(K+1)CFV+(VVUPV-VVLOV)WGT2+1.
448	RCMU(K)=1./CMU
449	RCMV(K)=1./CMV
450	CRU(K)=VVLOU*WGT2
451	CRV(K)=VVLOV*WGT2
452	RSTU(K)=-RSTU(K+1)*CFU+U_K(K) &
453	& -(U_K(K)-U_K(K+1))VVUPUWGT1 &
454	& -(U_K(K-1)-U_K(K))VVLOUWGT1
455	RSTV(K)=-RSTV(K+1)*CFV+V_K(K) &
456	& -(V_K(K)-V_K(K+1))VVUPVWGT1 &
457	& -(V_K(K-1)-V_K(K))VVLOVWGT1
458	ENDDO
459	!
460	!-----------------------------------------------------------------------
461	!
462	RDPU=1./(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPU)
463	RDPV=1./(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPV)
464	PVVUPU=PVVLOU
465	PVVUPV=PVVLOV
466	VVUPU=PVVUPU*RDPU
467	VVUPV=PVVUPV*RDPV
468	CFU=-VVUPUWGT2RCMU(KTS+1)
469	CFV=-VVUPVWGT2RCMV(KTS+1)
470	CMU=-CRU(KTS+1)CFU+VVUPUWGT2+1.
471	CMV=-CRV(KTS+1)CFV+VVUPVWGT2+1.
472	CRU(KTS)=0.
473	CRV(KTS)=0.
474	RSTU(KTS)=-(U_K(KTS)-U_K(KTS+1))VVUPUWGT1 &
475	& -RSTU(KTS+1)*CFU+U_K(KTS)
476	RSTV(KTS)=-(V_K(KTS)-V_K(KTS+1))VVUPVWGT1 &
477	& -RSTV(KTS+1)*CFV+V_K(KTS)
478	UN(KTS)=RSTU(KTS)/CMU
479	VN(KTS)=RSTV(KTS)/CMV
480	VAD_TEND_U(I,J,KTS)=UN(KTS)-U_K(KTS)
481	VAD_TEND_V(I,J,KTS)=VN(KTS)-V_K(KTS)
482	!
483	DO K=KTS+1,KTE
484	UN(K)=(-CRU(K)UN(K-1)+RSTU(K))RCMU(K)
485	VN(K)=(-CRV(K)VN(K-1)+RSTV(K))RCMV(K)
486	VAD_TEND_U(I,J,K)=UN(K)-U_K(K)
487	VAD_TEND_V(I,J,K)=VN(K)-V_K(K)
488	ENDDO
489	!
490	!-----------------------------------------------------------------------
491	!*** The following section is only for checking the implicit solution
492	!*** using back-substitution. Remove this section otherwise.
493	!-----------------------------------------------------------------------
494	!
495	! if(ntsd<=10.or.ntsd>=6000)then
496	! IF(I==ITEST.AND.J==JTEST)THEN
497	!!
498	! PDOPU=(PDSLO(I+IVW(J),J)+PDSLO(I+IVE(J),J))*0.5
499	! PDOPV=(PDSLO(I,J-1)+PDSLO(I,J+1))*0.5
500	! PVVLOU=(PETDT(I+IVW(J),J,KTE-1) &
501	! & +PETDT(I+IVE(J),J,KTE-1))*DTE
502	! PVVLOV=(PETDT(I,J-1,KTE-1) &
503	! & +PETDT(I,J+1,KTE-1))*DTE
504	! VVLOU=PVVLOU/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPU)
505	! VVLOV=PVVLOV/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPV)
506	! TULO=VVLOU*(U(I,J,KTE-1)-U(I,J,KTE)+UN(KTE-1)-UN(KTE))
507	! TVLO=VVLOV*(V(I,J,KTE-1)-V(I,J,KTE)+VN(KTE-1)-VN(KTE))
508	! ADUP=TULO+UN(KTE)-U(I,J,KTE)
509	! ADVP=TVLO+VN(KTE)-V(I,J,KTE)
510	! WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',KTE &
511	! &, ' ADUP=',ADUP,' ADVP=',ADVP
512	! WRITE(0,*)' U=',U(I,J,KTE),' UN=',UN(KTE) &
513	! &, ' VAD_TEND_U=',VAD_TEND_U(I,KTE) &
514	! &, ' V=',V(I,J,KTE),' VN=',VN(KTE) &
515	! &, ' VAD_TEND_V=',VAD_TEND_V(I,KTE)
516	! WRITE(0,*)' '
517	!!
518	! DO K=KTE-1,KTS+1,-1
519	! RDPU=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPU)
520	! RDPV=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPV)
521	! PVVUPU=PVVLOU
522	! PVVUPV=PVVLOV
523	! PVVLOU=(PETDT(I+IVW(J),J,K-1) &
524	! & +PETDT(I+IVE(J),J,K-1))*DTE
525	! PVVLOV=(PETDT(I,J-1,K-1)+PETDT(I,J+1,K-1))*DTE
526	! VVUPU=PVVUPU*RDPU
527	! VVUPV=PVVUPV*RDPV
528	! VVLOU=PVVLOU*RDPU
529	! VVLOV=PVVLOV*RDPV
530	! TUUP=VVUPU*(U(I,J,K)-U(I,J,K+1)+UN(K)-UN(K+1))
531	! TVUP=VVUPV*(V(I,J,K)-V(I,J,K+1)+VN(K)-VN(K+1))
532	! TULO=VVLOU*(U(I,J,K-1)-U(I,J,K)+UN(K-1)-UN(K))
533	! TVLO=VVLOV*(V(I,J,K-1)-V(I,J,K)+VN(K-1)-VN(K))
534	! ADUP=TUUP+TULO+UN(K)-U(I,J,K)
535	! ADVP=TVUP+TVLO+VN(K)-V(I,J,K)
536	! WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',K &
537	! &, ' ADUP=',ADUP,' ADVP=',ADVP
538	! WRITE(0,*)' U=',U(I,J,K),' UN=',UN(K) &
539	! &, ' VAD_TEND_U=',VAD_TEND_U(I,K) &
540	! &, ' V=',V(I,J,K),' VN=',VN(K) &
541	! &, ' VAD_TEND_V=',VAD_TEND_V(I,K)
542	! WRITE(0,*)' '
543	! ENDDO
544	!!
545	! PVVUPU=PVVLOU
546	! PVVUPV=PVVLOV
547	! VVUPU=PVVUPU/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPU)
548	! VVUPV=PVVUPV/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPV)
549	! TUUP=VVUPU*(U(I,J,KTS)-U(I,J,KTS+1)+UN(KTS)-UN(KTS+1))
550	! TVUP=VVUPV*(V(I,J,KTS)-V(I,J,KTS+1)+VN(KTS)-VN(KTS+1))
551	! ADUP=TUUP+UN(KTS)-U(I,J,KTS)
552	! ADVP=TVUP+VN(KTS)-V(I,J,KTS)
553	! WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',KTS &
554	! &, ' ADUP=',ADUP,' ADVP=',ADVP
555	! WRITE(0,*)' U=',U(I,J,KTS),' UN=',UN(KTS) &
556	! &, ' VAD_TEND_U=',VAD_TEND_U(I,KTS) &
557	! &, ' V=',V(I,J,KTS),' VN=',VN(KTS) &
558	! &, ' VAD_TEND_V=',VAD_TEND_V(I,KTS)
559	! WRITE(0,*)' '
560	! ENDIF
561	! endif
562	!
563	!-----------------------------------------------------------------------
564	!*** End of check.
565	!-----------------------------------------------------------------------
566	!
567	ENDDO iloop_for_uv
568	!
569	!-----------------------------------------------------------------------
570	!
571	ENDDO main_vertical
572	!
573	!-----------------------------------------------------------------------
574	!-----------------------------------------------------------------------
575	!
576	!*** COMPUTE HORIZONTAL ADVECTION TENDENCIES.
577	!
578	!-----------------------------------------------------------------------
579	!-----------------------------------------------------------------------
580	!$omp parallel do &
581	!$omp& private(adpdx,adpdy,adt,adu,adv,array0,array1,array2,array3 &
582	!$omp& ,array3_x,dpde,f0,f1,f2,f3,fewp,fnep,fnsp,fpp,fsep,hm &
583	!$omp& ,i,ifp,ifq,ii,ipq,isp,ispa,isq,isqa,iup_adh_j,j,k &
584	!$omp& ,knti_adh,n_iupadh_j,n_iupadv_j,n_iuph_j,pp,qp &
585	!$omp& ,rdpd,rdpdx,rdpdy,tew,tne,tns,tse,tst,tta,ttb &
586	!$omp& ,uew,udy,une,uned,uns,use,used,ust &
587	!$omp& ,vdx,vew,vm,vne,vns,vse,vst)
588	!-----------------------------------------------------------------------
589	!
590	main_horizontal: DO K=KTS,KTE
591	!
592	!-----------------------------------------------------------------------
593	!
594	DO J=MYJS_P4,MYJE_P4
595	DO I=MYIS_P4,MYIE_P4
596	DPDE(I,J)=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,J)
597	RDPD(I,J)=1./DPDE(I,J)
598	TST(I,J)=T(I,J,K)FFC+TOLD(I,J,K)FBC
599	UST(I,J)=U(I,J,K)FFC+UOLD(I,J,K)FBC
600	VST(I,J)=V(I,J,K)FFC+VOLD(I,J,K)FBC
601	ENDDO
602	ENDDO
603	!
604	!-----------------------------------------------------------------------
605	!*** MASS FLUXES AND MASS POINT ADVECTION COMPONENTS
606	!*** THE NS AND EW FLUXES IN THE FOLLOWING LOOP ARE ON V POINTS
607	!*** FOR T.
608	!-----------------------------------------------------------------------
609	!
610	DO J=MYJS1_P3,MYJE1_P3
611	DO I=MYIS_P3,MYIE_P3
612	!
613	ADPDX=DPDE(I+IVW(J),J)+DPDE(I+IVE(J),J)
614	ADPDY=DPDE(I,J-1)+DPDE(I,J+1)
615	RDPDX(I,J)=1./ADPDX
616	RDPDY(I,J)=1./ADPDY
617	!
618	UDY=U(I,J,K)*DY
619	VDX=V(I,J,K)*DX(I,J)
620	!
621	FEWP=UDY*ADPDX
622	FNSP=VDX*ADPDY
623	!
624	FEW(I,J,K)=FEWP
625	FNS(I,J,K)=FNSP
626	!
627	TEW(I,J)=FEWP*(TST(I+IVE(J),J)-TST(I+IVW(J),J))
628	TNS(I,J)=FNSP*(TST(I,J+1)-TST(I,J-1))
629	!
630	UNED(I,J)=UDY+VDX
631	USED(I,J)=UDY-VDX
632	!
633	ENDDO
634	ENDDO
635	!
636	!-----------------------------------------------------------------------
637	!*** DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND
638	!*** THE NE AND SE FLUXES ARE ASSOCIATED WITH H POINTS
639	!*** (ACTUALLY JUST TO THE NE AND SE OF EACH H POINT).
640	!-----------------------------------------------------------------------
641	!
642	DO J=MYJS1_P2,MYJE2_P2
643	DO I=MYIS_P2,MYIE_P2
644	FNEP=(UNED(I+IHE(J),J)+UNED(I ,J+1)) &
645	& *(DPDE(I ,J)+DPDE(I+IHE(J),J+1))
646	FNE(I,J,K)=FNEP
647	TNE(I,J)=FNEP*(TST(I+IHE(J),J+1)-TST(I,J))
648	ENDDO
649	ENDDO
650	!
651	DO J=MYJS2_P2,MYJE1_P2
652	DO I=MYIS_P2,MYIE_P2
653	FSEP=(USED(I+IHE(J),J)+USED(I ,J-1)) &
654	& *(DPDE(I ,J)+DPDE(I+IHE(J),J-1))
655	FSE(I,J,K)=FSEP
656	TSE(I,J)=FSEP*(TST(I+IHE(J),J-1)-TST(I,J))
657	!
658	ENDDO
659	ENDDO
660	!
661	!-----------------------------------------------------------------------
662	!*** HORIZONTAL T ADVECTION TENDENCY ADT IS ON H POINTS OF COURSE.
663	!-----------------------------------------------------------------------
664	!
665	DO J=MYJS5,MYJE5
666	DO I=MYIS2,MYIE2
667	ADT(I,J)=(TEW(I+IHW(J),J)+TEW(I+IHE(J),J) &
668	& +TNS(I,J-1)+TNS(I,J+1) &
669	& +TNE(I+IHW(J),J-1)+TNE(I,J) &
670	& +TSE(I,J)+TSE(I+IHW(J),J+1)) &
671	& RDPD(I,J)FAD(I,J)
672	ENDDO
673	ENDDO
674	!
675	!
676	!-----------------------------------------------------------------------
677	!*** CALCULATION OF MOMENTUM ADVECTION COMPONENTS.
678	!-----------------------------------------------------------------------
679	!
680	DO J=MYJS4_P1,MYJE4_P1
681	DO I=MYIS_P1,MYIE_P1
682	!
683	!-----------------------------------------------------------------------
684	!*** THE NS AND EW FLUXES ARE ON H POINTS FOR U AND V.
685	!-----------------------------------------------------------------------
686	!
687	UEW(I,J)=(FEW(I+IHW(J),J,K)+FEW(I+IHE(J),J,K)) &
688	& *(UST(I+IHE(J),J)-UST(I+IHW(J),J))
689	UNS(I,J)=(FNS(I+IHW(J),J,K)+FNS(I+IHE(J),J,K)) &
690	& *(UST(I,J+1)-UST(I,J-1))
691	VEW(I,J)=(FEW(I,J-1,K)+FEW(I,J+1,K)) &
692	& *(VST(I+IHE(J),J)-VST(I+IHW(J),J))
693	VNS(I,J)=(FNS(I,J-1,K)+FNS(I,J+1,K)) &
694	& *(VST(I,J+1)-VST(I,J-1))
695	!
696	!-----------------------------------------------------------------------
697	!*** THE FOLLOWING NE AND SE FLUXES ARE TIED TO V POINTS AND ARE
698	!*** LOCATED JUST TO THE NE AND SE OF THE GIVEN I,J.
699	!-----------------------------------------------------------------------
700	!
701	UNE(I,J)=(FNE(I+IVW(J),J,K)+FNE(I+IVE(J),J,K)) &
702	& *(UST(I+IVE(J),J+1)-UST(I,J))
703	USE(I,J)=(FSE(I+IVW(J),J,K)+FSE(I+IVE(J),J,K)) &
704	& *(UST(I+IVE(J),J-1)-UST(I,J))
705	VNE(I,J)=(FNE(I,J-1,K)+FNE(I,J+1,K)) &
706	& *(VST(I+IVE(J),J+1)-VST(I,J))
707	VSE(I,J)=(FSE(I,J-1,K)+FSE(I,J+1,K)) &
708	& *(VST(I+IVE(J),J-1)-VST(I,J))
709	!
710	!-----------------------------------------------------------------------
711	!
712	ENDDO
713	ENDDO
714	!
715	!-----------------------------------------------------------------------
716	!*** COMPUTE THE ADVECTION TENDENCIES FOR U AND V.
717	!*** THE AD ARRAYS ARE ON THE VELOCITY POINTS.
718	!-----------------------------------------------------------------------
719	!
720	DO J=MYJS5,MYJE5
721	DO I=MYIS2,MYIE2
722	ADU(I,J)=(UEW(I+IVW(J),J)+UEW(I+IVE(J),J) &
723	& +UNS(I,J-1)+UNS(I,J+1) &
724	& +UNE(I+IVW(J),J-1)+UNE(I,J) &
725	& +USE(I,J)+USE(I+IVW(J),J+1)) &
726	& RDPDX(I,J)FAD(I+IVW(J),J)
727	!
728	ADV(I,J)=(VEW(I+IVW(J),J)+VEW(I+IVE(J),J) &
729	& +VNS(I,J-1)+VNS(I,J+1) &
730	& +VNE(I+IVW(J),J-1)+VNE(I,J) &
731	& +VSE(I,J)+VSE(I+IVW(J),J+1)) &
732	& RDPDY(I,J)FAD(I+IVW(J),J)
733	ENDDO
734	ENDDO
735	!
736	!-----------------------------------------------------------------------
737	!
738	!*** END OF JANJIC HORIZONTAL ADVECTION
739	!
740	!-----------------------------------------------------------------------
741	!
742	!*** UPSTREAM ADVECTION OF T
743	!
744	!-----------------------------------------------------------------------
745	!
746	upstream: IF(UPSTRM)THEN
747	!
748	!-----------------------------------------------------------------------
749	!***
750	!*** COMPUTE UPSTREAM COMPUTATIONS ON THIS TASK'S ROWS.
751	!***
752	!-----------------------------------------------------------------------
753	!
754	jloop_upstream: DO J=MYJS2,MYJE2
755	!
756	N_IUPH_J=N_IUP_H(J) ! See explanation in START_DOMAIN_NMM
757	DO II=0,N_IUPH_J-1
758	!
759	I=IUP_H(IMS+II,J)
760	TTA=EMT_LOC(J)*(UST(I,J-1)+UST(I+IHW(J),J) &
761	& +UST(I+IHE(J),J)+UST(I,J+1))
762	TTB=ENT *(VST(I,J-1)+VST(I+IHW(J),J) &
763	& +VST(I+IHE(J),J)+VST(I,J+1))
764	PP=-TTA-TTB
765	QP= TTA-TTB
766	!
767	IF(PP<0.)THEN
768	ISPA(I,J)=-1
769	ELSE
770	ISPA(I,J)= 1
771	ENDIF
772	!
773	IF(QP<0.)THEN
774	ISQA(I,J)=-1
775	ELSE
776	ISQA(I,J)= 1
777	ENDIF
778	!
779	PP=ABS(PP)
780	QP=ABS(QP)
781	ARRAY3_X=PP*QP
782	ARRAY0(I,J)=ARRAY3_X-PP-QP
783	ARRAY1(I,J)=PP-ARRAY3_X
784	ARRAY2(I,J)=QP-ARRAY3_X
785	ARRAY3(I,J)=ARRAY3_X
786	ENDDO
787	!
788	!-----------------------------------------------------------------------
789	!
790	N_IUPADH_J=N_IUP_ADH(J)
791	KNTI_ADH=1
792	IUP_ADH_J=IUP_ADH(IMS,J)
793	!
794	iloop_T: DO II=0,N_IUPH_J-1
795	!
796	I=IUP_H(IMS+II,J)
797	!
798	ISP=ISPA(I,J)
799	ISQ=ISQA(I,J)
800	IFP=(ISP-1)/2
801	IFQ=(-ISQ-1)/2
802	IPQ=(ISP-ISQ)/2
803	!
804	!-----------------------------------------------------------------------
805	!
806	IF(I==IUP_ADH_J)THEN ! Upstream advection T tendencies
807	!
808	ISP=ISPA(I,J)
809	ISQ=ISQA(I,J)
810	IFP=(ISP-1)/2
811	IFQ=(-ISQ-1)/2
812	IPQ=(ISP-ISQ)/2
813	!
814	F0=ARRAY0(I,J)
815	F1=ARRAY1(I,J)
816	F2=ARRAY2(I,J)
817	F3=ARRAY3(I,J)
818	!
819	ADT(I,J)=F0*T(I,J,K) &
820	& +F1*T(I+IHE(J)+IFP,J+ISP,K) &
821	& +F2*T(I+IHE(J)+IFQ,J+ISQ,K) &
822	+F3*T(I+IPQ,J+ISP+ISQ,K)
823	!
824	!-----------------------------------------------------------------------
825	!
826	IF(KNTI_ADH<N_IUPADH_J)THEN
827	IUP_ADH_J=IUP_ADH(IMS+KNTI_ADH,J)
828	KNTI_ADH=KNTI_ADH+1
829	ENDIF
830	!
831	ENDIF ! End of upstream advection T tendency IF block
832	!
833	ENDDO iloop_T
834	!
835	!-----------------------------------------------------------------------
836	!
837	!*** UPSTREAM ADVECTION OF VELOCITY COMPONENTS
838	!
839	!-----------------------------------------------------------------------
840	!
841	N_IUPADV_J=N_IUP_ADV(J)
842	!
843	DO II=0,N_IUPADV_J-1
844	I=IUP_ADV(IMS+II,J)
845	!
846	TTA=EM_LOC(J)*UST(I,J)
847	TTB=EN *VST(I,J)
848	PP=-TTA-TTB
849	QP=TTA-TTB
850	!
851	IF(PP<0.)THEN
852	ISP=-1
853	ELSE
854	ISP= 1
855	ENDIF
856	!
857	IF(QP<0.)THEN
858	ISQ=-1
859	ELSE
860	ISQ= 1
861	ENDIF
862	!
863	IFP=(ISP-1)/2
864	IFQ=(-ISQ-1)/2
865	IPQ=(ISP-ISQ)/2
866	PP=ABS(PP)
867	QP=ABS(QP)
868	F3=PP*QP
869	F0=F3-PP-QP
870	F1=PP-F3
871	F2=QP-F3
872	!
873	ADU(I,J)=F0*U(I,J,K) &
874	& +F1*U(I+IVE(J)+IFP,J+ISP,K) &
875	& +F2*U(I+IVE(J)+IFQ,J+ISQ,K) &
876	& +F3*U(I+IPQ,J+ISP+ISQ,K)
877	!
878	ADV(I,J)=F0*V(I,J,K) &
879	& +F1*V(I+IVE(J)+IFP,J+ISP,K) &
880	& +F2*V(I+IVE(J)+IFQ,J+ISQ,K) &
881	& +F3*V(I+IPQ,J+ISP+ISQ,K)
882	!
883	ENDDO
884	!
885	ENDDO jloop_upstream
886	!
887	!-----------------------------------------------------------------------
888	!
889	ENDIF upstream
890	!
891	!-----------------------------------------------------------------------
892	!
893	!*** END OF HORIZONTAL ADVECTION
894	!
895	!-----------------------------------------------------------------------
896	!
897	!*** NOW SUM THE VERTICAL AND HORIZONTAL TENDENCIES,
898	!*** CURVATURE AND CORIOLIS TERMS.
899	!
900	!-----------------------------------------------------------------------
901	!
902	DO J=MYJS2,MYJE2
903	DO I=MYIS1,MYIE1
904	HM=HBM2(I,J)
905	VM=VBM2(I,J)
906	ADT(I,J)=(VAD_TEND_T(I,J,K)+2.ADT(I,J))HM
907	!
908	FPP=CURV(I,J)2.UST(I,J)+F(I,J)*2.
909	ADU(I,J)=(VAD_TEND_U(I,J,K)+2.ADU(I,J)+VST(I,J)FPP)*VM
910	ADV(I,J)=(VAD_TEND_V(I,J,K)+2.ADV(I,J)-UST(I,J)FPP)*VM
911	ENDDO
912	ENDDO
913	!
914	!-----------------------------------------------------------------------
915	!*** SAVE THE OLD VALUES FOR TIMESTEPPING
916	!-----------------------------------------------------------------------
917	!
918	DO J=MYJS_P4,MYJE_P4
919	DO I=MYIS_P4,MYIE_P4
920	TOLD(I,J,K)=T(I,J,K)
921	UOLD(I,J,K)=U(I,J,K)
922	VOLD(I,J,K)=V(I,J,K)
923	ENDDO
924	ENDDO
925	!
926	!-----------------------------------------------------------------------
927	!*** FINALLY UPDATE THE PROGNOSTIC VARIABLES
928	!-----------------------------------------------------------------------
929	!
930	DO J=MYJS2,MYJE2
931	DO I=MYIS1,MYIE1
932	T(I,J,K)=ADT(I,J)+T(I,J,K)
933	U(I,J,K)=ADU(I,J)+U(I,J,K)
934	V(I,J,K)=ADV(I,J)+V(I,J,K)
935	ENDDO
936	ENDDO
937	!
938	!-----------------------------------------------------------------------
939	!
940	ENDDO main_horizontal
941	!
942	!-----------------------------------------------------------------------
943	!
944	END SUBROUTINE ADVE
945	!
946	!-----------------------------------------------------------------------
947	!
948	!***********************************************************************
949	SUBROUTINE VAD2(NTSD,DT,IDTAD,DX,DY &
950	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP,HBM2 &
951	& ,Q,Q2,CWM,PETDT &
952	& ,N_IUP_H,N_IUP_V &
953	& ,N_IUP_ADH,N_IUP_ADV &
954	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
955	& ,IHE,IHW,IVE,IVW &
956	& ,IDS,IDE,JDS,JDE,KDS,KDE &
957	& ,IMS,IME,JMS,JME,KMS,KME &
958	& ,ITS,ITE,JTS,JTE,KTS,KTE)
959	!***********************************************************************
960	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
961	! . . .
962	! SUBPROGRAM: VAD2 VERTICAL ADVECTION OF H2O SUBSTANCE AND TKE
963	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
964	!
965	! ABSTRACT:
966	! VAD2 CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION
967	! TO THE TENDENCIES OF WATER SUBSTANCE AND TKE AND THEN UPDATES
968	! THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
969	!
970	! PROGRAM HISTORY LOG:
971	! 96-07-19 JANJIC - ORIGINATOR
972	! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
973	! 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
974	! 02-02-06 BLACK - CONVERTED TO WRF FORMAT
975	! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
976	! 04-11-23 BLACK - THREADED
977	!
978	! USAGE: CALL VAD2 FROM SUBROUTINE SOLVE_NMM
979	! INPUT ARGUMENT LIST:
980	!
981	! OUTPUT ARGUMENT LIST
982	!
983	! OUTPUT FILES:
984	! NONE
985	! SUBPROGRAMS CALLED:
986	!
987	! UNIQUE: NONE
988	!
989	! LIBRARY: NONE
990	!
991	! ATTRIBUTES:
992	! LANGUAGE: FORTRAN 90
993	! MACHINE : IBM SP
994	!$$$
995	!***********************************************************************
996	!----------------------------------------------------------------------
997	!
998	IMPLICIT NONE
999	!
1000	!----------------------------------------------------------------------
1001	!
1002	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
1003	& ,IMS,IME,JMS,JME,KMS,KME &
1004	,ITS,ITE,JTS,JTE,KTS,KTE
1005	!
1006	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
1007	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
1008	& ,N_IUP_ADH,N_IUP_ADV
1009	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
1010	& ,IUP_ADH,IUP_ADV
1011	!
1012	INTEGER,INTENT(IN) :: IDTAD,NTSD
1013	!
1014	REAL,INTENT(IN) :: DT,DY,PDTOP
1015	!
1016	REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
1017	!
1018	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
1019	!
1020	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PETDT
1021	!
1022	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM,Q,Q2
1023	!
1024	!----------------------------------------------------------------------
1025	!*** LOCAL VARIABLES
1026	!----------------------------------------------------------------------
1027	!
1028	REAL,PARAMETER :: FF1=0.500
1029	!
1030	LOGICAL,SAVE :: TRADITIONAL=.TRUE.
1031	!
1032	INTEGER :: I,IRECV,J,JFP,JFQ,K,LAP,LLAP
1033	!
1034	INTEGER,DIMENSION(KTS:KTE) :: LA
1035	!
1036	REAL*8 :: ADDT,AFRP,D2PQE,D2PQQ,D2PQW,DEP,DETAP,DPDN,DPUP,DQP &
1037	& ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ &
1038	& ,Q00,Q4P,QP,QP0 &
1039	& ,RFACEK,RFACQK,RFACWK,RFC,RR &
1040	& ,SUMNE,SUMNQ,SUMNW,SUMPE,SUMPQ,SUMPW &
1041	& ,W00,W4P,WP,WP0
1042
1043	REAL :: SFACEK,SFACQK,SFACWK
1044	!
1045	REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4,PETDTK &
1046	& ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
1047	!
1048	!***********************************************************************
1049	!-----------------------------------------------------------------------
1050	!
1051	ADDT=REAL(IDTAD)*DT
1052	!
1053	!-----------------------------------------------------------------------
1054	!$omp parallel do &
1055	!$omp& private(afr,afrp,d2pqe,d2pqq,d2pqw,del,dep,detap,dpdn,dpup &
1056	!$omp& ,dql,dqp,dwl,dwp,e00,e3,e4,e4p,ep,ep0,haddt,i,j,k &
1057	!$omp& ,la,lap,llap,petdtk,q00,q3,q4,q4p,qp,qp0,rfacek,rfacqk &
1058	!$omp& ,rfacwk,rfc,rr,sumne,sumnq,sumnw,sumpe,sumpq,sumpw &
1059	!$omp& ,w00,w3,w4,w4p,wp,wp0,sfacek,sfacqk,sfacwk)
1060	!-----------------------------------------------------------------------
1061	!
1062	main_integration : DO J=MYJS2,MYJE2
1063	!
1064	!-----------------------------------------------------------------------
1065	!
1066	main_iloop: DO I=MYIS1_P1,MYIE1_P1
1067	!
1068	!-----------------------------------------------------------------------
1069	!
1070	E3(KTE)=Q2(I,J,KTE)*0.5
1071	!
1072	DO K=KTE-1,KTS,-1
1073	E3(K)=MAX((Q2(I,J,K+1)+Q2(I,J,K))*0.5,EPSQ2)
1074	ENDDO
1075	!
1076	DO K=KTS,KTE
1077	Q3(K)=MAX(Q(I,J,K),EPSQ)
1078	W3(K)=MAX(CWM(I,J,K),CLIMIT)
1079	E4(K)=E3(K)
1080	Q4(K)=Q3(K)
1081	W4(K)=W3(K)
1082	ENDDO
1083	!
1084	IF(TRADITIONAL)THEN
1085	PETDTK(KTE)=PETDT(I,J,KTE-1)*0.5
1086	!
1087	DO K=KTE-1,KTS+1,-1
1088	PETDTK(K)=(PETDT(I,J,K)+PETDT(I,J,K-1))*0.5
1089	ENDDO
1090	!
1091	PETDTK(KTS)=PETDT(I,J,KTS)*0.5
1092	!
1093	ELSE
1094	!
1095	!-----------------------------------------------------------------------
1096	!*** PERFORM HORIZONTAL AVERAGING OF VERTICAL VELOCITY
1097	!-----------------------------------------------------------------------
1098	!
1099	PETDTK(KTE)=(PETDT(I+IHW(J-1),J-1,KTE-1) &
1100	& +PETDT(I+IHE(J-1),J-1,KTE-1) &
1101	& +PETDT(I+IHW(J+1),J+1,KTE-1) &
1102	& +PETDT(I+IHE(J+1),J+1,KTE-1) &
1103	& +PETDT(I,J,KTE-1)4. )0.0625
1104	!
1105	DO K=KTE-1,KTS+1,-1
1106	PETDTK(K)=(PETDT(I+IHW(J-1),J-1,K-1) &
1107	+PETDT(I+IHE(J-1),J-1,K-1) &
1108	& +PETDT(I+IHW(J+1),J+1,K-1) &
1109	& +PETDT(I+IHE(J+1),J+1,K-1) &
1110	& +PETDT(I+IHW(J-1),J-1,K ) &
1111	& +PETDT(I+IHE(J-1),J-1,K ) &
1112	& +PETDT(I+IHW(J+1),J+1,K ) &
1113	& +PETDT(I+IHE(J+1),J+1,K ) &
1114	& +(PETDT(I,J,K-1)+PETDT(I,J,K))*4. &
1115	& )*0.0625
1116	ENDDO
1117	!
1118	PETDTK(KTS)=(PETDT(I+IHW(J-1),J-1,KTS) &
1119	& +PETDT(I+IHE(J-1),J-1,KTS) &
1120	& +PETDT(I+IHW(J+1),J+1,KTS) &
1121	& +PETDT(I+IHE(J+1),J+1,KTS) &
1122	& +PETDT(I,J,KTS)4. )0.0625
1123
1124	ENDIF
1125	!
1126	!-----------------------------------------------------------------------
1127	!
1128	HADDT=-ADDT*HBM2(I,J)
1129	!
1130	DO K=KTE,KTS,-1
1131	RR=PETDTK(K)*HADDT
1132	!
1133	IF(RR<0.)THEN
1134	LAP=1
1135	ELSE
1136	LAP=-1
1137	ENDIF
1138	!
1139	LA(K)=LAP
1140	LLAP=K+LAP
1141	!
1142	IF(LLAP>KTS-1.AND.LLAP<KTE+1)THEN !zjmod
1143	RR=ABS(RR/((AETA1(LLAP)-AETA1(K))*PDTOP &
1144	& +(AETA2(LLAP)-AETA2(K))*PDSL(I,J)))
1145	IF(RR>0.9)RR=0.9
1146	!
1147	AFR(K)=(((FF4RR+FF3)RR+FF2)RR+FF1)RR
1148	DQP=(Q3(LLAP)-Q3(K))*RR
1149	DWP=(W3(LLAP)-W3(K))*RR
1150	DEP=(E3(LLAP)-E3(K))*RR
1151	DQL(K)=DQP
1152	DWL(K)=DWP
1153	DEL(K)=DEP
1154	ELSE
1155	RR=0.
1156	AFR(K)=0.
1157	DQL(K)=0.
1158	DWL(K)=0.
1159	DEL(K)=0.
1160	ENDIF
1161	ENDDO
1162	!
1163	!-----------------------------------------------------------------------
1164	!
1165	IF(LA(KTE-1)>0)THEN
1166	RFC=(DETA1(KTE-1)PDTOP+DETA2(KTE-1)PDSL(I,J)) &
1167	& /(DETA1(KTE )PDTOP+DETA2(KTE )PDSL(I,J))
1168	DQL(KTE)=-DQL(KTE-1)*RFC
1169	DWL(KTE)=-DWL(KTE-1)*RFC
1170	DEL(KTE)=-DEL(KTE-1)*RFC
1171	ENDIF
1172	!
1173	IF(LA(KTS+1)<0)THEN
1174	RFC=(DETA1(KTS+1)PDTOP+DETA2(KTS+1)PDSL(I,J)) &
1175	& /(DETA1(KTS )PDTOP+DETA2(KTS )PDSL(I,J))
1176	DQL(KTS)=-DQL(KTS+1)*RFC
1177	DWL(KTS)=-DWL(KTS+1)*RFC
1178	DEL(KTS)=-DEL(KTS+1)*RFC
1179	ENDIF
1180	!
1181	DO K=KTS,KTE
1182	Q4(K)=Q3(K)+DQL(K)
1183	W4(K)=W3(K)+DWL(K)
1184	E4(K)=E3(K)+DEL(K)
1185	ENDDO
1186	!
1187	!-----------------------------------------------------------------------
1188	!*** ANTI-FILTERING STEP
1189	!-----------------------------------------------------------------------
1190	!
1191	SUMPQ=0.
1192	SUMNQ=0.
1193	SUMPW=0.
1194	SUMNW=0.
1195	SUMPE=0.
1196	SUMNE=0.
1197	!
1198	antifiltering_limiters: DO K=KTE-1,KTS+1,-1
1199	!
1200	DETAP=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
1201	!
1202	Q4P=Q4(K)
1203	W4P=W4(K)
1204	E4P=E4(K)
1205	!
1206	LAP=LA(K)
1207	!
1208	DPDN=(AETA1(K+LAP)-AETA1(K))*PDTOP &
1209	& +(AETA2(K+LAP)-AETA2(K))*PDSL(I,J)
1210	DPUP=(AETA1(K)-AETA1(K-LAP))*PDTOP &
1211	& +(AETA2(K)-AETA2(K-LAP))*PDSL(I,J)
1212	!
1213	AFRP=2.AFR(K)DPDN*DPDN/(DPDN+DPUP)
1214	D2PQQ=((Q4(K+LAP)-Q4P)/DPDN &
1215	& -(Q4P-Q4(K-LAP))/DPUP)*AFRP
1216	D2PQW=((W4(K+LAP)-W4P)/DPDN &
1217	& -(W4P-W4(K-LAP))/DPUP)*AFRP
1218	D2PQE=((E4(K+LAP)-E4P)/DPDN &
1219	& -(E4P-E4(K-LAP))/DPUP)*AFRP
1220	!
1221	QP=Q4P-D2PQQ
1222	WP=W4P-D2PQW
1223	EP=E4P-D2PQE
1224	!
1225	Q00=Q3(K)
1226	QP0=Q3(K+LAP)
1227	!
1228	W00=W3(K)
1229	WP0=W3(K+LAP)
1230	!
1231	E00=E3(K)
1232	EP0=E3(K+LAP)
1233	!
1234	QP=MAX(QP,MIN(Q00,QP0))
1235	QP=MIN(QP,MAX(Q00,QP0))
1236	WP=MAX(WP,MIN(W00,WP0))
1237	WP=MIN(WP,MAX(W00,WP0))
1238	EP=MAX(EP,MIN(E00,EP0))
1239	EP=MIN(EP,MAX(E00,EP0))
1240	!
1241	DQP=QP-Q00
1242	DWP=WP-W00
1243	DEP=EP-E00
1244	!
1245	DQL(K)=DQP
1246	DWL(K)=DWP
1247	DEL(K)=DEP
1248	!
1249	ENDDO antifiltering_limiters
1250	!
1251	!-----------------------------------------------------------------------
1252	!
1253	IF(LA(KTE-1)>0)THEN
1254	RFC=(DETA1(KTE-1)PDTOP+DETA2(KTE-1)PDSL(I,J)) &
1255	& /(DETA1(KTE )PDTOP+DETA2(KTE )PDSL(I,J))
1256	DQL(KTE)=-DQL(KTE-1)*RFC+DQL(KTE)
1257	DWL(KTE)=-DWL(KTE-1)*RFC+DWL(KTE)
1258	DEL(KTE)=-DEL(KTE-1)*RFC+DEL(KTE)
1259	ENDIF
1260	!
1261	IF(LA(KTS+1)<0)THEN
1262	RFC=(DETA1(KTS+1)PDTOP+DETA2(KTS+1)PDSL(I,J)) &
1263	& /(DETA1(KTS )PDTOP+DETA2(KTS )PDSL(I,J))
1264	DQL(KTS)=-DQL(KTS+1)*RFC+DQL(KTS)
1265	DWL(KTS)=-DWL(KTS+1)*RFC+DWL(KTS)
1266	DEL(KTS)=-DEL(KTS+1)*RFC+DEL(KTS)
1267	ENDIF
1268	!
1269	DO K=KTS,KTE
1270	DETAP=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
1271	DQP=DQL(K)*DETAP
1272	DWP=DWL(K)*DETAP
1273	DEP=DEL(K)*DETAP
1274	!
1275	IF(DQP>0.)THEN
1276	SUMPQ=SUMPQ+DQP
1277	ELSE
1278	SUMNQ=SUMNQ+DQP
1279	ENDIF
1280	IF(DWP>0.)THEN
1281	SUMPW=SUMPW+DWP
1282	ELSE
1283	SUMNW=SUMNW+DWP
1284	ENDIF
1285	IF(DEP>0.)THEN
1286	SUMPE=SUMPE+DEP
1287	ELSE
1288	SUMNE=SUMNE+DEP
1289	ENDIF
1290	ENDDO
1291	!
1292	!-----------------------------------------------------------------------
1293	!*** FIRST MOMENT CONSERVING FACTOR
1294	!-----------------------------------------------------------------------
1295	!
1296	IF(SUMPQ>1.E-9)THEN
1297	SFACQK=-SUMNQ/SUMPQ
1298	ELSE
1299	SFACQK=1.
1300	ENDIF
1301	!
1302	IF(SUMPW>1.E-9)THEN
1303	SFACWK=-SUMNW/SUMPW
1304	ELSE
1305	SFACWK=1.
1306	ENDIF
1307	!
1308	IF(SUMPE>1.E-9)THEN
1309	SFACEK=-SUMNE/SUMPE
1310	ELSE
1311	SFACEK=1.
1312	ENDIF
1313	!
1314	IF(SFACQK<CONSERVE_MIN.OR.SFACQK>CONSERVE_MAX)SFACQK=1.
1315	IF(SFACWK<CONSERVE_MIN.OR.SFACWK>CONSERVE_MAX)SFACWK=1.
1316	IF(SFACEK<CONSERVE_MIN.OR.SFACEK>CONSERVE_MAX)SFACEK=1.
1317	!
1318	RFACQK=1./SFACQK
1319	RFACWK=1./SFACWK
1320	RFACEK=1./SFACEK
1321	!
1322	!-----------------------------------------------------------------------
1323	!*** IMPOSE CONSERVATION ON ANTI-FILTERING
1324	!-----------------------------------------------------------------------
1325	!
1326	DO K=KTE,KTS,-1
1327	!
1328	DQP=DQL(K)
1329	IF(SFACQK>=1.)THEN
1330	IF(DQP<0.)DQP=DQP*RFACQK
1331	ELSE
1332	IF(DQP>0.)DQP=DQP*SFACQK
1333	ENDIF
1334	Q(I,J,K)=Q3(K)+DQP
1335	!
1336	DWP=DWL(K)
1337	IF(SFACWK>=1.)THEN
1338	IF(DWP<0.)DWP=DWP*RFACWK
1339	ELSE
1340	IF(DWP>0.)DWP=DWP*SFACWK
1341	ENDIF
1342	CWM(I,J,K)=W3(K)+DWP
1343	!
1344	DEP=DEL(K)
1345	IF(SFACEK>=1.)THEN
1346	IF(DEP<0.)DEP=DEP*RFACEK
1347	ELSE
1348	IF(DEP>0.)DWP=DWP*SFACEK
1349	ENDIF
1350	E3(K)=E3(K)+DEP
1351	!
1352	ENDDO
1353	!
1354	!-----------------------------------------------------------------------
1355	!
1356	HBM2IJ=HBM2(I,J)
1357	Q2(I,J,KTE)=MAX(E3(KTE)+E3(KTE)-EPSQ2,EPSQ2)*HBM2IJ &
1358	& +Q2(I,J,KTE)*(1.-HBM2IJ)
1359	DO K=KTE-1,KTS+1,-1
1360	Q2(I,J,K)=MAX(E3(K)+E3(K)-Q2(I,J,K+1),EPSQ2)*HBM2IJ &
1361	& +Q2(I,J,K)*(1.-HBM2IJ)
1362	ENDDO
1363	!
1364	!-----------------------------------------------------------------------
1365	!
1366	ENDDO main_iloop
1367	!
1368	!-----------------------------------------------------------------------
1369	!
1370	ENDDO main_integration
1371	!
1372	!-----------------------------------------------------------------------
1373	!
1374	END SUBROUTINE VAD2
1375	!
1376	!-----------------------------------------------------------------------
1377	!***********************************************************************
1378	!-----------------------------------------------------------------------
1379	SUBROUTINE HAD2( &
1380	#if defined(DM_PARALLEL)
1381	& domdesc , &
1382	#endif
1383	& NTSD,DT,IDTAD,DX,DY &
1384	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
1385	& ,HBM2,HBM3 &
1386	& ,Q,Q2,CWM,U,V,Z,HYDRO &
1387	& ,N_IUP_H,N_IUP_V &
1388	& ,N_IUP_ADH,N_IUP_ADV &
1389	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
1390	& ,IHE,IHW,IVE,IVW &
1391	& ,IDS,IDE,JDS,JDE,KDS,KDE &
1392	& ,IMS,IME,JMS,JME,KMS,KME &
1393	& ,ITS,ITE,JTS,JTE,KTS,KTE)
1394	!***********************************************************************
1395	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
1396	! . . .
1397	! SUBPROGRAM: HAD2 HORIZONTAL ADVECTION OF H2O AND TKE
1398	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
1399	!
1400	! ABSTRACT:
1401	! HAD2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
1402	! TO THE TENDENCIES OF WATER SUBSTANCE AND TKE AND THEN
1403	! UPDATES THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
1404	!
1405	! PROGRAM HISTORY LOG:
1406	! 96-07-19 JANJIC - ORIGINATOR
1407	! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
1408	! 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
1409	! 02-02-06 BLACK - CONVERTED TO WRF FORMAT
1410	! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
1411	! 03-05-23 JANJIC - ADDED SLOPE FACTOR
1412	! 04-11-23 BLACK - THREADED
1413	! 05-12-14 BLACK - CONVERTED FROM IKJ TO IJK
1414	!
1415	! USAGE: CALL HAD2 FROM SUBROUTINE SOLVE_NMM
1416	! INPUT ARGUMENT LIST:
1417	!
1418	! OUTPUT ARGUMENT LIST
1419	!
1420	! OUTPUT FILES:
1421	! NONE
1422	! SUBPROGRAMS CALLED:
1423	!
1424	! UNIQUE: NONE
1425	!
1426	! LIBRARY: NONE
1427	!
1428	! ATTRIBUTES:
1429	! LANGUAGE: FORTRAN 90
1430	! MACHINE : IBM SP
1431	!$$$
1432	!***********************************************************************
1433	!-----------------------------------------------------------------------
1434	!
1435	IMPLICIT NONE
1436	!
1437	!-----------------------------------------------------------------------
1438	!
1439	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
1440	& ,IMS,IME,JMS,JME,KMS,KME &
1441	& ,ITS,ITE,JTS,JTE,KTS,KTE
1442	!
1443	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
1444	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
1445	& ,N_IUP_ADH,N_IUP_ADV
1446	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
1447	& ,IUP_ADH,IUP_ADV
1448	!
1449	!-----------------------------------------------------------------------
1450	!
1451	INTEGER,INTENT(IN) :: IDTAD,NTSD
1452	!
1453	REAL,INTENT(IN) :: DT,DY,PDTOP
1454	!
1455	REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
1456	!
1457	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
1458	!
1459	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: U,V,Z
1460	!
1461	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM,Q,Q2
1462	!
1463	LOGICAL,INTENT(IN) :: HYDRO
1464	!
1465	!-----------------------------------------------------------------------
1466	!*** LOCAL VARIABLES
1467	!-----------------------------------------------------------------------
1468	!
1469	REAL,PARAMETER :: FF1=0.530
1470	!
1471	#ifdef DM_PARALLEL
1472	INTEGER :: DOMDESC
1473	#endif
1474	!
1475	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
1476	LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
1477	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,6) :: XSUMS_L
1478	REAL,DIMENSION(IDS:IDE,JDS:JDE,KDS:KDE,6) :: XSUMS_G
1479	#endif
1480	!
1481	LOGICAL :: BOT,TOP
1482	!
1483	INTEGER :: I,IRECV,J,JFP,JFQ,K,LAP,LLAP,MPI_COMM_COMP
1484	INTEGER :: N
1485	!
1486	INTEGER,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5,KTS:KTE) :: IFPA,IFPF &
1487	& ,IFQA,IFQF &
1488	& ,JFPA,JFPF &
1489	& ,JFQA,JFQF
1490	!
1491	REAL :: ADDT,AFRP,CRIT,D2PQE,D2PQQ,D2PQW,DEP,DESTIJ,DQP,DQSTIJ &
1492	& ,DVOLP,DWP,DWSTIJ,DZA,DZB,E00,E0Q,E1X,E2IJ,E4P,ENH,EP,EP0 &
1493	& ,ESTIJ,FPQ,HAFP,HAFQ,HBM2IJ,HM,PP,PPQ00,Q00,Q0Q &
1494	& ,Q1IJ,Q4P,QP,QP0,QSTIJ,RDY,RFACE,RFACQ,RFACW,RFC &
1495	& ,RFEIJ,RFQIJ,RFWIJ,RR,SLOPAC,SPP,SQP,SSA,SSB,SUMNE,SUMNQ &
1496	& ,SUMNW,SUMPE,SUMPQ,SUMPW,TTA,TTB,W00,W0Q,W1IJ,W4P,WP,WP0 &
1497	& ,WSTIJ
1498	!
1499	DOUBLE PRECISION,DIMENSION(6,KTS:KTE) :: GSUMS,XSUMS
1500	!
1501	REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4 &
1502	& ,Q3,Q4,W3,W4
1503	!
1504	REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: DARE,EMH
1505	!
1506	REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5,KTS:KTE) :: AFP,AFQ,DEST &
1507	& ,DQST,DVOL,DWST &
1508	& ,E1,E2,Q1,W1
1509	!-----------------------------------------------------------------------
1510	integer :: nunit,ier
1511	save nunit
1512	!-----------------------------------------------------------------------
1513	!***********************************************************************
1514	!-----------------------------------------------------------------------
1515	!
1516	RDY=1./DY
1517	SLOPAC=SLOPHTSQRT(2.)0.5*50.
1518	CRIT=SLOPACREAL(IDTAD)DTRDY1000.
1519	!
1520	ADDT=REAL(IDTAD)*DT
1521	ENH=ADDT/(08.*DY)
1522	!
1523	!-----------------------------------------------------------------------
1524	!$omp parallel do &
1525	!$omp& private(i,j)
1526	DO J=MYJS_P3,MYJE_P3
1527	DO I=MYIS_P2,MYIE_P2
1528	EMH (I,J)=ADDT/(08.*DX(I,J))
1529	DARE(I,J)=HBM3(I,J)DX(I,J)DY
1530	E1(I,J,KTE)=MAX(Q2(I,J,KTE)*0.5,EPSQ2)
1531	E2(I,J,KTE)=E1(I,J,KTE)
1532	ENDDO
1533	ENDDO
1534	!-----------------------------------------------------------------------
1535	!$omp parallel do &
1536	!$omp& private(dza,dzb,e1x,fpq,hm,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp &
1537	!$omp& ,tta,ttb)
1538	!-----------------------------------------------------------------------
1539	!
1540	vertical_1: DO K=KTS,KTE
1541	!
1542	!-----------------------------------------------------------------------
1543	!
1544	DO J=MYJS_P3,MYJE_P3
1545	DO I=MYIS_P2,MYIE_P2
1546	DVOL(I,J,K)=DARE(I,J)(DETA1(K)PDTOP+DETA2(K)*PDSL(I,J))
1547	Q (I,J,K)=MAX(Q (I,J,K),EPSQ)
1548	CWM(I,J,K)=MAX(CWM(I,J,K),CLIMIT)
1549	Q1 (I,J,K)=Q (I,J,K)
1550	W1 (I,J,K)=CWM(I,J,K)
1551	ENDDO
1552	ENDDO
1553	!
1554	IF(K<KTE)THEN
1555	DO J=MYJS_P3,MYJE_P3
1556	DO I=MYIS_P2,MYIE_P2
1557	E1X=(Q2(I,J,K+1)+Q2(I,J,K))*0.5
1558	E1(I,J,K)=MAX(E1X,EPSQ2)
1559	E2(I,J,K)=E1(I,J,K)
1560	ENDDO
1561	ENDDO
1562	ENDIF
1563	!
1564	!-----------------------------------------------------------------------
1565	!
1566	DO J=MYJS2_P1,MYJE2_P1
1567	DO I=MYIS1_P1,MYIE1_P1
1568	!
1569	HM=HBM2(I,J)
1570	TTA=(U(I,J-1,K)+U(I+IHW(J),J,K)+U(I+IHE(J),J,K)+U(I,J+1,K)) &
1571	& EMH(I,J)HM
1572	TTB=(V(I,J-1,K)+V(I+IHW(J),J,K)+V(I+IHE(J),J,K)+V(I,J+1,K)) &
1573	& ENHHBM2(I,J)
1574	!
1575	SPP=-TTA-TTB
1576	SQP= TTA-TTB
1577	!
1578	IF(SPP<0.)THEN
1579	JFP=-1
1580	ELSE
1581	JFP=1
1582	ENDIF
1583	IF(SQP<0.)THEN
1584	JFQ=-1
1585	ELSE
1586	JFQ=1
1587	ENDIF
1588	!
1589	IFPA(I,J,K)=IHE(J)+I+( JFP-1)/2
1590	IFQA(I,J,K)=IHE(J)+I+(-JFQ-1)/2
1591	!
1592	JFPA(I,J,K)=J+JFP
1593	JFQA(I,J,K)=J+JFQ
1594	!
1595	IFPF(I,J,K)=IHE(J)+I+(-JFP-1)/2
1596	IFQF(I,J,K)=IHE(J)+I+( JFQ-1)/2
1597	!
1598	JFPF(I,J,K)=J-JFP
1599	JFQF(I,J,K)=J-JFQ
1600	if(i==111.and.j==438.and.k==1)then
1601	endif
1602	!
1603	!-----------------------------------------------------------------------
1604	IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
1605	DZA=(Z(IFPA(I,J,K),JFPA(I,J,K),K)-Z(I,J,K))*RDY
1606	DZB=(Z(IFQA(I,J,K),JFQA(I,J,K),K)-Z(I,J,K))*RDY
1607	!
1608	IF(ABS(DZA)>SLOPAC)THEN
1609	SSA=DZA*SPP
1610	IF(SSA>CRIT)THEN
1611	SPP=0. !spp*.1
1612	ENDIF
1613	ENDIF
1614	!
1615	IF(ABS(DZB)>SLOPAC)THEN
1616	SSB=DZB*SQP
1617	IF(SSB>CRIT)THEN
1618	SQP=0. !sqp*.1
1619	ENDIF
1620	ENDIF
1621	!
1622	ENDIF
1623	!
1624	!-----------------------------------------------------------------------
1625	!
1626	FPQ=SPPSQP0.25
1627	PP=ABS(SPP)
1628	QP=ABS(SQP)
1629	!
1630	AFP(I,J,K)=(((FF4PP+FF3)PP+FF2)PP+FF1)PP
1631	AFQ(I,J,K)=(((FF4QP+FF3)QP+FF2)QP+FF1)QP
1632	!
1633	Q1(I,J,K)=(Q (IFPA(I,J,K),JFPA(I,J,K),K)-Q (I,J,K))*PP &
1634	& +(Q (IFQA(I,J,K),JFQA(I,J,K),K)-Q (I,J,K))*QP &
1635	& +(Q (I,J-2,K)+Q (I,J+2,K) &
1636	& -Q (I-1,J,K)-Q (I+1,J,K))*FPQ &
1637	& +Q(I,J,K)
1638	!
1639	W1(I,J,K)=(CWM(IFPA(I,J,K),JFPA(I,J,K),K)-CWM(I,J,K))*PP &
1640	& +(CWM(IFQA(I,J,K),JFQA(I,J,K),K)-CWM(I,J,K))*QP &
1641	& +(CWM(I,J-2,K)+CWM(I,J+2,K) &
1642	& -CWM(I-1,J,K)-CWM(I+1,J,K))*FPQ &
1643	& +CWM(I,J,K)
1644	!
1645	E2(I,J,K)=(E1 (IFPA(I,J,K),JFPA(I,J,K),K)-E1 (I,J,K))*PP &
1646	& +(E1 (IFQA(I,J,K),JFQA(I,J,K),K)-E1 (I,J,K))*QP &
1647	& +(E1 (I,J-2,K)+E1 (I,J+2,K) &
1648	& -E1 (I-1,J,K)-E1 (I+1,J,K))*FPQ &
1649	& +E1(I,J,K)
1650	!
1651	ENDDO
1652	ENDDO
1653	!
1654	!-----------------------------------------------------------------------
1655	!
1656	ENDDO vertical_1
1657	!
1658	!-----------------------------------------------------------------------
1659	!*** ANTI-FILTERING STEP
1660	!-----------------------------------------------------------------------
1661	!
1662	DO K=KTS,KTE
1663	XSUMS(1,K)=0.
1664	XSUMS(2,K)=0.
1665	XSUMS(3,K)=0.
1666	XSUMS(4,K)=0.
1667	XSUMS(5,K)=0.
1668	XSUMS(6,K)=0.
1669	ENDDO
1670	!-----------------------------------------------------------------------
1671	!
1672	!*** ANTI-FILTERING LIMITERS
1673	!
1674	!-----------------------------------------------------------------------
1675	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
1676	DO N=1,6
1677	!
1678	!$omp parallel do &
1679	!$omp& private(i,j,k)
1680	DO K=KMS,KME
1681	DO J=JMS,JME
1682	DO I=IMS,IME
1683	XSUMS_L(I,J,K,N)=0.
1684	ENDDO
1685	ENDDO
1686	ENDDO
1687	!
1688	!$omp parallel do &
1689	!$omp& private(i,j,k)
1690	DO K=KDS,KDE
1691	DO J=JDS,JDE
1692	DO I=IDS,IDE
1693	XSUMS_G(I,J,K,N)=0.
1694	ENDDO
1695	ENDDO
1696	ENDDO
1697	!
1698	ENDDO
1699	!
1700	#endif
1701	!-----------------------------------------------------------------------
1702	!$omp parallel do &
1703	!$omp& private(d2pqe,d2pqq,d2pqw,destij,dqstij,dvolp,dwstij &
1704	!$omp& ,e00,e0q,e2ij,ep0,estij,hafp,hafq,i,j,k &
1705	!$omp& ,q00,q0q,q1ij,qp0,qstij,w00,w0q,w1ij,wp0,wstij)
1706	!-----------------------------------------------------------------------
1707	!
1708	vertical_2: DO K=KTS,KTE
1709	!
1710	!-----------------------------------------------------------------------
1711	!
1712	DO J=MYJS2,MYJE2
1713	DO I=MYIS1,MYIE1
1714	!
1715	DVOLP=DVOL(I,J,K)
1716	Q1IJ =Q1(I,J,K)
1717	W1IJ =W1(I,J,K)
1718	E2IJ =E2(I,J,K)
1719	!
1720	HAFP=AFP(I,J,K)
1721	HAFQ=AFQ(I,J,K)
1722	!
1723	D2PQQ=(Q1(IFPA(I,J,K),JFPA(I,J,K),K)-Q1IJ &
1724	& -Q1IJ+Q1(IFPF(I,J,K),JFPF(I,J,K),K)) &
1725	& *HAFP &
1726	& +(Q1(IFQA(I,J,K),JFQA(I,J,K),K)-Q1IJ &
1727	& -Q1IJ+Q1(IFQF(I,J,K),JFQF(I,J,K),K)) &
1728	& *HAFQ
1729	!
1730	D2PQW=(W1(IFPA(I,J,K),JFPA(I,J,K),K)-W1IJ &
1731	& -W1IJ+W1(IFPF(I,J,K),JFPF(I,J,K),K)) &
1732	& *HAFP &
1733	& +(W1(IFQA(I,J,K),JFQA(I,J,K),K)-W1IJ &
1734	& -W1IJ+W1(IFQF(I,J,K),JFQF(I,J,K),K)) &
1735	& *HAFQ
1736	!
1737	D2PQE=(E2(IFPA(I,J,K),JFPA(I,J,K),K)-E2IJ &
1738	& -E2IJ+E2(IFPF(I,J,K),JFPF(I,J,K),K)) &
1739	& *HAFP &
1740	& +(E2(IFQA(I,J,K),JFQA(I,J,K),K)-E2IJ &
1741	& -E2IJ+E2(IFQF(I,J,K),JFQF(I,J,K),K)) &
1742	& *HAFQ
1743	!
1744	QSTIJ=Q1IJ-D2PQQ
1745	WSTIJ=W1IJ-D2PQW
1746	ESTIJ=E2IJ-D2PQE
1747	!
1748	Q00=Q (I ,J ,K)
1749	QP0=Q (IFPA(I,J,K),JFPA(I,J,K),K)
1750	Q0Q=Q (IFQA(I,J,K),JFQA(I,J,K),K)
1751	!
1752	W00=CWM(I ,J ,K)
1753	WP0=CWM(IFPA(I,J,K),JFPA(I,J,K),K)
1754	W0Q=CWM(IFQA(I,J,K),JFQA(I,J,K),K)
1755	!
1756	E00=E1 (I ,J ,K)
1757	EP0=E1 (IFPA(I,J,K),JFPA(I,J,K),K)
1758	E0Q=E1 (IFQA(I,J,K),JFQA(I,J,K),K)
1759	!
1760	QSTIJ=MAX(QSTIJ,MIN(Q00,QP0,Q0Q))
1761	QSTIJ=MIN(QSTIJ,MAX(Q00,QP0,Q0Q))
1762	WSTIJ=MAX(WSTIJ,MIN(W00,WP0,W0Q))
1763	WSTIJ=MIN(WSTIJ,MAX(W00,WP0,W0Q))
1764	ESTIJ=MAX(ESTIJ,MIN(E00,EP0,E0Q))
1765	ESTIJ=MIN(ESTIJ,MAX(E00,EP0,E0Q))
1766	!
1767	DQSTIJ=QSTIJ-Q(I,J,K)
1768	DWSTIJ=WSTIJ-CWM(I,J,K)
1769	DESTIJ=ESTIJ-E1(I,J,K)
1770	!
1771	DQST(I,J,K)=DQSTIJ
1772	DWST(I,J,K)=DWSTIJ
1773	DEST(I,J,K)=DESTIJ
1774	!
1775	DQSTIJ=DQSTIJ*DVOLP
1776	DWSTIJ=DWSTIJ*DVOLP
1777	DESTIJ=DESTIJ*DVOLP
1778	!
1779	!-----------------------------------------------------------------------
1780	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
1781	!-----------------------------------------------------------------------
1782	DO N=1,6
1783	XSUMS_L(I,J,K,N)=0.
1784	ENDDO
1785	!
1786	IF(DQSTIJ>0.)THEN
1787	XSUMS_L(I,J,K,1)=DQSTIJ
1788	ELSE
1789	XSUMS_L(I,J,K,2)=DQSTIJ
1790	ENDIF
1791	!
1792	IF(DWSTIJ>0.)THEN
1793	XSUMS_L(I,J,K,3)=DWSTIJ
1794	ELSE
1795	XSUMS_L(I,J,K,4)=DWSTIJ
1796	ENDIF
1797	!
1798	IF(DESTIJ>0.)THEN
1799	XSUMS_L(I,J,K,5)=DESTIJ
1800	ELSE
1801	XSUMS_L(I,J,K,6)=DESTIJ
1802	ENDIF
1803	!-----------------------------------------------------------------------
1804	#else
1805	!-----------------------------------------------------------------------
1806	IF(DQSTIJ>0.)THEN
1807	XSUMS(1,K)=XSUMS(1,K)+DQSTIJ
1808	ELSE
1809	XSUMS(2,K)=XSUMS(2,K)+DQSTIJ
1810	ENDIF
1811	!
1812	IF(DWSTIJ>0.)THEN
1813	XSUMS(3,K)=XSUMS(3,K)+DWSTIJ
1814	ELSE
1815	XSUMS(4,K)=XSUMS(4,K)+DWSTIJ
1816	ENDIF
1817	!
1818	IF(DESTIJ>0.)THEN
1819	XSUMS(5,K)=XSUMS(5,K)+DESTIJ
1820	ELSE
1821	XSUMS(6,K)=XSUMS(6,K)+DESTIJ
1822	ENDIF
1823	!-----------------------------------------------------------------------
1824	#endif
1825	!-----------------------------------------------------------------------
1826	!
1827	ENDDO
1828	ENDDO
1829	!
1830	!-----------------------------------------------------------------------
1831	!
1832	ENDDO vertical_2
1833	!
1834	!-----------------------------------------------------------------------
1835	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
1836	!-----------------------------------------------------------------------
1837	DO N=1,6
1838	CALL WRF_PATCH_TO_GLOBAL_REAL(XSUMS_L(IMS,JMS,KMS,N) &
1839	&, XSUMS_G(1,1,1,N),DOMDESC &
1840	&, 'xyz','xyz' &
1841	&, IDS,IDE,JDS,JDE,KDS,KDE &
1842	&, IMS,IME,JMS,JME,KMS,KME &
1843	&, ITS,ITE,JTS,JTE,KTS,KTE)
1844	ENDDO
1845	!
1846	DO K=KTS,KTE
1847	DO N=1,6
1848	GSUMS(N,K)=0.
1849	ENDDO
1850	ENDDO
1851	!
1852	IF(WRF_DM_ON_MONITOR())THEN
1853	DO N=1,6
1854	!$omp parallel do &
1855	!$omp& private(i,j,k)
1856	DO K=KTS,KTE
1857	DO J=JDS,JDE
1858	DO I=IDS,IDE
1859	GSUMS(N,K)=GSUMS(N,K)+XSUMS_G(I,J,K,N)
1860	ENDDO
1861	ENDDO
1862	ENDDO
1863	ENDDO
1864	ENDIF
1865
1866	CALL WRF_DM_BCAST_BYTES(GSUMS,2RWORDSIZE6*(KTE-KTS+1) )
1867
1868	!-----------------------------------------------------------------------
1869	#else
1870	!-----------------------------------------------------------------------
1871	!
1872	!-----------------------------------------------------------------------
1873	!*** GLOBAL REDUCTION
1874	!-----------------------------------------------------------------------
1875	!
1876	# if defined(DM_PARALLEL) && !defined(STUBMPI)
1877	CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
1878	CALL MPI_ALLREDUCE(XSUMS,GSUMS,6*(KTE-KTS+1) &
1879	& ,MPI_DOUBLE_PRECISION,MPI_SUM &
1880	& ,MPI_COMM_COMP,IRECV)
1881	# else
1882	DO K=KTS,KTE
1883	DO N=1,6
1884	GSUMS(N,K)=XSUMS(N,K)
1885	ENDDO
1886	ENDDO
1887	# endif
1888	!
1889	!-----------------------------------------------------------------------
1890	#endif
1891	!-----------------------------------------------------------------------
1892	!
1893	!-----------------------------------------------------------------------
1894	!*** END OF GLOBAL REDUCTION
1895	!-----------------------------------------------------------------------
1896	!
1897	! if(mype==0)then
1898	!!! if(ntsd==0)then
1899	!!! call int_get_fresh_handle(nunit)
1900	!!! close(nunit)
1901	! nunit=56
1902	!!! open(unit=nunit,file='gsums',form='unformatted',iostat=ier)
1903	!!! endif
1904	! endif
1905	!-----------------------------------------------------------------------
1906	!$omp parallel do &
1907	!$omp& private(destij,dqstij,dwstij,i,j,k,rface,rfacq,rfacw &
1908	!$omp& ,rfeij,rfqij,rfwij,sumne,sumnq,sumnw,sumpe,sumpq,sumpw)
1909	!-----------------------------------------------------------------------
1910	!
1911	vertical_3: DO K=KTS,KTE
1912	!
1913	!-----------------------------------------------------------------------
1914	! if(mype==0)then
1915	! write(nunit)(gsums(i,k),i=1,6)
1916	! endif
1917	!!! read(nunit)(gsums(i,k),i=1,6)
1918	!-----------------------------------------------------------------------
1919	!
1920	SUMPQ=GSUMS(1,K)
1921	SUMNQ=GSUMS(2,K)
1922	SUMPW=GSUMS(3,K)
1923	SUMNW=GSUMS(4,K)
1924	SUMPE=GSUMS(5,K)
1925	SUMNE=GSUMS(6,K)
1926	!
1927	!-----------------------------------------------------------------------
1928	!*** FIRST MOMENT CONSERVING FACTOR
1929	!-----------------------------------------------------------------------
1930	!
1931	IF(SUMPQ>1.)THEN
1932	RFACQ=-SUMNQ/SUMPQ
1933	ELSE
1934	RFACQ=1.
1935	ENDIF
1936	!
1937	IF(SUMPW>1.)THEN
1938	RFACW=-SUMNW/SUMPW
1939	ELSE
1940	RFACW=1.
1941	ENDIF
1942	!
1943	IF(SUMPE>1.)THEN
1944	RFACE=-SUMNE/SUMPE
1945	ELSE
1946	RFACE=1.
1947	ENDIF
1948	!
1949	IF(RFACQ<CONSERVE_MIN.OR.RFACQ>CONSERVE_MAX)RFACQ=1.
1950	IF(RFACW<CONSERVE_MIN.OR.RFACW>CONSERVE_MAX)RFACW=1.
1951	IF(RFACE<CONSERVE_MIN.OR.RFACE>CONSERVE_MAX)RFACE=1.
1952	!
1953	!-----------------------------------------------------------------------
1954	! if(mype==0.and.ntsd==181)close(nunit)
1955	!-----------------------------------------------------------------------
1956	!
1957	!-----------------------------------------------------------------------
1958	!*** IMPOSE CONSERVATION ON ANTI-FILTERING
1959	!-----------------------------------------------------------------------
1960	!
1961	DO J=MYJS2,MYJE2
1962	IF(RFACQ<1.)THEN
1963	DO I=MYIS1,MYIE1
1964	DQSTIJ=DQST(I,J,K)
1965	RFQIJ=HBM2(I,J)*(RFACQ-1.)+1.
1966	IF(DQSTIJ>=0.)DQSTIJ=DQSTIJ*RFQIJ
1967	Q(I,J,K)=Q(I,J,K)+DQSTIJ
1968	ENDDO
1969	ELSE
1970	DO I=MYIS1,MYIE1
1971	DQSTIJ=DQST(I,J,K)
1972	RFQIJ=HBM2(I,J)*(RFACQ-1.)+1.
1973	IF(DQSTIJ<0.)DQSTIJ=DQSTIJ/RFQIJ
1974	Q(I,J,K)=Q(I,J,K)+DQSTIJ
1975	ENDDO
1976	ENDIF
1977	ENDDO
1978	!
1979	!-----------------------------------------------------------------------
1980	!
1981	DO J=MYJS2,MYJE2
1982	IF(RFACW<1.)THEN
1983	DO I=MYIS1,MYIE1
1984	DWSTIJ=DWST(I,J,K)
1985	RFWIJ=HBM2(I,J)*(RFACW-1.)+1.
1986	IF(DWSTIJ>=0.)DWSTIJ=DWSTIJ*RFWIJ
1987	CWM(I,J,K)=CWM(I,J,K)+DWSTIJ
1988	ENDDO
1989	ELSE
1990	DO I=MYIS1,MYIE1
1991	DWSTIJ=DWST(I,J,K)
1992	RFWIJ=HBM2(I,J)*(RFACW-1.)+1.
1993	IF(DWSTIJ<0.)DWSTIJ=DWSTIJ/RFWIJ
1994	CWM(I,J,K)=CWM(I,J,K)+DWSTIJ
1995	ENDDO
1996	ENDIF
1997	ENDDO
1998	!
1999	!-----------------------------------------------------------------------
2000	!
2001	DO J=MYJS2,MYJE2
2002	IF(RFACE<1.)THEN
2003	DO I=MYIS1,MYIE1
2004	DESTIJ=DEST(I,J,K)
2005	RFEIJ=HBM2(I,J)*(RFACE-1.)+1.
2006	IF(DESTIJ>=0.)DESTIJ=DESTIJ*RFEIJ
2007	E1(I,J,K)=E1(I,J,K)+DESTIJ
2008	ENDDO
2009	ELSE
2010	DO I=MYIS1,MYIE1
2011	DESTIJ=DEST(I,J,K)
2012	RFEIJ=HBM2(I,J)*(RFACE-1.)+1.
2013	IF(DESTIJ<0.)DESTIJ=DESTIJ/RFEIJ
2014	E1(I,J,K)=E1(I,J,K)+DESTIJ
2015	ENDDO
2016	ENDIF
2017	ENDDO
2018	!
2019	!-----------------------------------------------------------------------
2020	!
2021	DO J=MYJS,MYJE
2022	DO I=MYIS,MYIE
2023	Q (I,J,K)=MAX(Q (I,J,K),EPSQ)
2024	CWM(I,J,K)=MAX(CWM(I,J,K),CLIMIT)
2025	ENDDO
2026	ENDDO
2027	!
2028	!-----------------------------------------------------------------------
2029	!
2030	ENDDO vertical_3
2031	!
2032	!-----------------------------------------------------------------------
2033	!
2034	!$omp parallel do &
2035	!$omp& private(i,j)
2036	DO J=MYJS,MYJE
2037	DO I=MYIS,MYIE
2038	Q2(I,J,KTE)=MAX(E1(I,J,KTE)+E1(I,J,KTE)-EPSQ2,EPSQ2)
2039	ENDDO
2040	ENDDO
2041	!
2042	!-----------------------------------------------------------------------
2043	!
2044	DO K=KTE-1,KTS+1,-1
2045	!$omp parallel do &
2046	!$omp& private(i,j)
2047	DO J=MYJS,MYJE
2048	DO I=MYIS,MYIE
2049	IF(K>KTS)THEN
2050	Q2(I,J,K)=MAX(E1(I,J,K)+E1(I,J,K)-Q2(I,J,K+1),EPSQ2)
2051	ELSE
2052	Q2(I,J,K)=Q2(I,J,K+1)
2053	ENDIF
2054	ENDDO
2055	ENDDO
2056	ENDDO
2057	!-----------------------------------------------------------------------
2058	!
2059	END SUBROUTINE HAD2
2060	!
2061	!-----------------------------------------------------------------------
2062	!***********************************************************************
2063	!-----------------------------------------------------------------------
2064	! New routines added by Georg Grell to handle advection more like ARW
2065	! core. Instead of VAD2/HAD2 that advect TKE, specific humidity, and
2066	! condensed water species all in one routine, we call VAD2/HAD2_SCAL
2067	! with multidimensioned arrays to advect each variable. For purposes
2068	! here, solve_nmm.F calls this routine once for TKE, then again for
2069	! all the species held in the moist array (qv, qc, qi, qr, qs, qg),
2070	! then call again for number concentrations held in scalar array (qni).
2071	! The dummy argument lstart is the starting index of the multidimensioned
2072	! array for starting the advection since the 1st index of moist and
2073	! scalar are actually empty placeholders (and the 2nd element is vapor,
2074	! then qc, etc.) When calling with single 3D array (like TKE), just
2075	! set NUM_SCAL=1 and lstart=1. The variable to advect is called SCAL
2076	! herein.
2077	!***********************************************************************
2078	SUBROUTINE VAD2_SCAL(NTSD,DT,IDTAD,DX,DY &
2079	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
2080	& ,HBM2 &
2081	& ,SCAL,PETDT &
2082	& ,N_IUP_H,N_IUP_V &
2083	& ,N_IUP_ADH,N_IUP_ADV &
2084	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
2085	& ,IHE,IHW,IVE,IVW &
2086	& ,NUM_SCAL,LSTART &
2087	& ,IDS,IDE,JDS,JDE,KDS,KDE &
2088	& ,IMS,IME,JMS,JME,KMS,KME &
2089	& ,ITS,ITE,JTS,JTE,KTS,KTE)
2090	!***********************************************************************
2091	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
2092	! . . .
2093	! SUBPROGRAM: VAD2_SCAL VERTICAL ADVECTION OF SCALARS
2094	!
2095	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
2096	! GRELL,PECKHAM ORG: NOAA/FSL DATE: 05-02-03
2097	!
2098	! ABSTRACT:
2099	! VAD2_SCAL CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION
2100	! TO THE TENDENCIES OF SCALAR SUBSTANCES AND THEN UPDATES
2101	! THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
2102	!
2103	! PROGRAM HISTORY LOG:
2104	! 96-07-19 JANJIC - ORIGINATOR
2105	! 05-02-03 GRELL,PECKHAM - MODIFIED FOR SCALARS
2106	!
2107	! USAGE: CALL VAD2_SCAL FROM SUBROUTINE SOLVE_NMM
2108	! INPUT ARGUMENT LIST:
2109	!
2110	! OUTPUT ARGUMENT LIST
2111	!
2112	! OUTPUT FILES:
2113	! NONE
2114	! SUBPROGRAMS CALLED:
2115	!
2116	! UNIQUE: NONE
2117	!
2118	! LIBRARY: NONE
2119	!
2120	! ATTRIBUTES:
2121	! LANGUAGE: FORTRAN 90
2122	! MACHINE : IBM
2123	!$$$
2124	!***********************************************************************
2125	!----------------------------------------------------------------------
2126	!
2127	IMPLICIT NONE
2128	!
2129	!----------------------------------------------------------------------
2130	!
2131	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
2132	& ,IMS,IME,JMS,JME,KMS,KME &
2133	,ITS,ITE,JTS,JTE,KTS,KTE
2134	!
2135	INTEGER,INTENT(IN) :: LSTART,NUM_SCAL
2136	!
2137	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
2138	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
2139	& ,N_IUP_ADH,N_IUP_ADV
2140	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
2141	& ,IUP_ADH,IUP_ADV
2142	!
2143	INTEGER,INTENT(IN) :: IDTAD,NTSD
2144	!
2145	REAL,INTENT(IN) :: DT,DY,PDTOP
2146	!
2147	REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
2148	!
2149	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
2150	!
2151	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PETDT
2152	!
2153	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,1:NUM_SCAL) &
2154	,INTENT(INOUT) :: SCAL
2155	!
2156	!----------------------------------------------------------------------
2157	!*** LOCAL VARIABLES
2158	!----------------------------------------------------------------------
2159	!
2160	REAL,PARAMETER :: FF1=0.500
2161	!
2162	LOGICAL,SAVE :: TRADITIONAL=.TRUE.
2163	!
2164	INTEGER :: I,IRECV,J,JFP,JFQ,K,L,LAP,LLAP
2165	!
2166	INTEGER,DIMENSION(KTS:KTE) :: LA
2167	!
2168	REAL*8 :: ADDT,AFRP,D2PQQ,DETAP,DPDN,DPUP,DQP &
2169	& ,HADDT,HBM2IJ &
2170	& ,Q00,Q4P,QP,QP0 &
2171	& ,RFACQK,RFC,RR &
2172	& ,SUMNQ,SUMPQ
2173	!
2174	REAL :: SFACQK
2175	!
2176	REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4,PETDTK &
2177	& ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
2178	!
2179	!-----------------------------------------------------------------------
2180	!***********************************************************************
2181	!-----------------------------------------------------------------------
2182	!
2183	ADDT=REAL(IDTAD)*DT
2184	!
2185	!-----------------------------------------------------------------------
2186	!$omp parallel do &
2187	!$omp& private(afr,afrp,d2pqq,detap,dpdn,dpup &
2188	!$omp& ,dql,dqp,haddt,i,j,k &
2189	!$omp& ,la,lap,llap,petdtk,q00,q3,q4,q4p,qp,qp0,rfacqk &
2190	!$omp& ,rfc,rr,sfacqk,sumnq,sumpq)
2191	!-----------------------------------------------------------------------
2192	!
2193	scalar_loop: DO L=LSTART,NUM_SCAL
2194	!
2195	main_integration: DO J=MYJS2,MYJE2
2196	!
2197	!-----------------------------------------------------------------------
2198	!
2199	main_iloop: DO I=MYIS1_P1,MYIE1_P1
2200	!
2201	!-----------------------------------------------------------------------
2202	!
2203	DO K=KTS,KTE
2204	Q3(K)=SCAL(I,J,K,L)
2205	Q4(K)=Q3(K)
2206	ENDDO
2207	!
2208	IF(TRADITIONAL)THEN
2209	PETDTK(KTE)=PETDT(I,J,KTE-1)*0.5
2210	!
2211	DO K=KTE-1,KTS+1,-1
2212	PETDTK(K)=(PETDT(I,J,K)+PETDT(I,J,K-1))*0.5
2213	ENDDO
2214	!
2215	PETDTK(KTS)=PETDT(I,J,KTS)*0.5
2216	!
2217	ELSE
2218	!
2219	!-----------------------------------------------------------------------
2220	!*** PERFORM HORIZONTAL AVERAGING OF VERTICAL VELOCITY
2221	!-----------------------------------------------------------------------
2222	!
2223	PETDTK(KTE)=(PETDT(I+IHW(J-1),J-1,KTE-1) &
2224	& +PETDT(I+IHE(J-1),J-1,KTE-1) &
2225	& +PETDT(I+IHW(J+1),J+1,KTE-1) &
2226	& +PETDT(I+IHE(J+1),J+1,KTE-1) &
2227	& +PETDT(I,J,KTE-1)4. )0.0625
2228	!
2229	DO K=KTE-1,KTS+1,-1
2230	PETDTK(K)=(PETDT(I+IHW(J-1),J-1,K-1) &
2231	+PETDT(I+IHE(J-1),J-1,K-1) &
2232	& +PETDT(I+IHW(J+1),J+1,K-1) &
2233	& +PETDT(I+IHE(J+1),J+1,K-1) &
2234	& +PETDT(I+IHW(J-1),J-1,K ) &
2235	& +PETDT(I+IHE(J-1),J-1,K ) &
2236	& +PETDT(I+IHW(J+1),J+1,K ) &
2237	& +PETDT(I+IHE(J+1),J+1,K ) &
2238	& +(PETDT(I,J,K-1)+PETDT(I,J,K))*4. &
2239	& )*0.0625
2240	ENDDO
2241	!
2242	PETDTK(KTS)=(PETDT(I+IHW(J-1),J-1,KTS) &
2243	& +PETDT(I+IHE(J-1),J-1,KTS) &
2244	& +PETDT(I+IHW(J+1),J+1,KTS) &
2245	& +PETDT(I+IHE(J+1),J+1,KTS) &
2246	& +PETDT(I,J,KTS)4. )0.0625
2247
2248	ENDIF
2249	!
2250	!-----------------------------------------------------------------------
2251	!
2252	HADDT=-ADDT*HBM2(I,J)
2253	!
2254	DO K=KTE,KTS,-1
2255	RR=PETDTK(K)*HADDT
2256	!
2257	IF(RR<0.)THEN
2258	LAP=1
2259	ELSE
2260	LAP=-1
2261	ENDIF
2262	!
2263	LA(K)=LAP
2264	LLAP=K+LAP
2265	!
2266	IF(LLAP>KTS-1.AND.LLAP<KTE+1)THEN
2267	RR=ABS(RR/((AETA1(LLAP)-AETA1(K))*PDTOP &
2268	& +(AETA2(LLAP)-AETA2(K))*PDSL(I,J)))
2269	IF(RR>0.9)RR=0.9
2270	!
2271	AFR(K)=(((FF4RR+FF3)RR+FF2)RR+FF1)RR
2272	DQP=(Q3(LLAP)-Q3(K))*RR
2273	DQL(K)=DQP
2274	ELSE
2275	RR=0.
2276	AFR(K)=0.
2277	DQL(K)=0.
2278	ENDIF
2279	ENDDO
2280	!
2281	!-----------------------------------------------------------------------
2282	!
2283	IF(LA(KTE-1)>0)THEN
2284	RFC=(DETA1(KTE-1)PDTOP+DETA2(KTE-1)PDSL(I,J)) &
2285	& /(DETA1(KTE )PDTOP+DETA2(KTE )PDSL(I,J))
2286	DQL(KTE)=-DQL(KTE-1)*RFC
2287	ENDIF
2288	!
2289	IF(LA(KTS+1)<0)THEN
2290	RFC=(DETA1(KTS+1)PDTOP+DETA2(KTS+1)PDSL(I,J)) &
2291	& /(DETA1(KTS )PDTOP+DETA2(KTS )PDSL(I,J))
2292	DQL(KTS)=-DQL(KTS+1)*RFC
2293	ENDIF
2294	!
2295	DO K=KTS,KTE
2296	Q4(K)=Q3(K)+DQL(K)
2297	ENDDO
2298	!
2299	!-----------------------------------------------------------------------
2300	!*** ANTI-FILTERING STEP
2301	!-----------------------------------------------------------------------
2302	!
2303	SUMPQ=0.
2304	SUMNQ=0.
2305	!
2306	!*** ANTI-FILTERING LIMITERS
2307	!
2308	antifilter: DO K=KTE-1,KTS+1,-1
2309	!
2310	DETAP=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
2311	!
2312	Q4P=Q4(K)
2313	!
2314	LAP=LA(K)
2315	!
2316	DPDN=(AETA1(K+LAP)-AETA1(K))*PDTOP &
2317	& +(AETA2(K+LAP)-AETA2(K))*PDSL(I,J)
2318	DPUP=(AETA1(K)-AETA1(K-LAP))*PDTOP &
2319	& +(AETA2(K)-AETA2(K-LAP))*PDSL(I,J)
2320	!
2321	AFRP=2.AFR(K)DPDN*DPDN/(DPDN+DPUP)
2322	D2PQQ=((Q4(K+LAP)-Q4P)/DPDN &
2323	& -(Q4P-Q4(K-LAP))/DPUP)*AFRP
2324	!
2325	QP=Q4P-D2PQQ
2326	!
2327	Q00=Q3(K)
2328	QP0=Q3(K+LAP)
2329	!
2330	QP=MAX(QP,MIN(Q00,QP0))
2331	QP=MIN(QP,MAX(Q00,QP0))
2332	!
2333	DQP=QP-Q00
2334	!
2335	DQL(K)=DQP
2336	!
2337	ENDDO antifilter
2338	!
2339	!-----------------------------------------------------------------------
2340	!
2341	IF(LA(KTE-1)>0)THEN
2342	RFC=(DETA1(KTE-1)PDTOP+DETA2(KTE-1)PDSL(I,J)) &
2343	& /(DETA1(KTE )PDTOP+DETA2(KTE )PDSL(I,J))
2344	DQL(KTE)=-DQL(KTE-1)*RFC+DQL(KTE)
2345	ENDIF
2346	!
2347	IF(LA(KTS+1)<0)THEN
2348	RFC=(DETA1(KTS+1)PDTOP+DETA2(KTS+1)PDSL(I,J)) &
2349	& /(DETA1(KTS )PDTOP+DETA2(KTS )PDSL(I,J))
2350	DQL(KTS)=-DQL(KTS+1)*RFC+DQL(KTS)
2351	ENDIF
2352	!
2353	DO K=KTS,KTE
2354	DETAP=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
2355	DQP=DQL(K)*DETAP
2356	!
2357	IF(DQP>0.)THEN
2358	SUMPQ=SUMPQ+DQP
2359	ELSE
2360	SUMNQ=SUMNQ+DQP
2361	ENDIF
2362	ENDDO
2363	!
2364	!-----------------------------------------------------------------------
2365	!*** FIRST MOMENT CONSERVING FACTOR
2366	!-----------------------------------------------------------------------
2367	!
2368	IF(SUMPQ>1.E-9)THEN
2369	SFACQK=-SUMNQ/SUMPQ
2370	ELSE
2371	SFACQK=1.
2372	ENDIF
2373	!
2374	IF(SFACQK<CONSERVE_MIN.OR.SFACQK>CONSERVE_MAX)SFACQK=1.
2375	!
2376	RFACQK=1./SFACQK
2377	!
2378	!-----------------------------------------------------------------------
2379	!*** IMPOSE CONSERVATION ON ANTI-FILTERING
2380	!-----------------------------------------------------------------------
2381	!
2382	DO K=KTE,KTS,-1
2383	DQP=DQL(K)
2384	IF(SFACQK>=1.)THEN
2385	IF(DQP<0.)DQP=DQP*RFACQK
2386	ELSE
2387	IF(DQP>0.)DQP=DQP*SFACQK
2388	ENDIF
2389	SCAL(I,J,K,L)=Q3(K)+DQP
2390	ENDDO
2391	!
2392	!-----------------------------------------------------------------------
2393	!
2394	ENDDO main_iloop
2395	!
2396	!-----------------------------------------------------------------------
2397	!
2398	ENDDO main_integration
2399	!
2400	!-----------------------------------------------------------------------
2401	!
2402	ENDDO scalar_loop
2403	!
2404	!-----------------------------------------------------------------------
2405	!
2406	END SUBROUTINE VAD2_SCAL
2407	!
2408	!-----------------------------------------------------------------------
2409	!
2410	!***********************************************************************
2411	SUBROUTINE HAD2_SCAL( &
2412	#if defined(DM_PARALLEL)
2413	& DOMDESC , &
2414	#endif
2415	& NTSD,DT,IDTAD,DX,DY &
2416	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
2417	& ,HBM2,HBM3 &
2418	& ,SCAL,U,V,Z,HYDRO &
2419	& ,N_IUP_H,N_IUP_V &
2420	& ,N_IUP_ADH,N_IUP_ADV &
2421	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
2422	& ,IHE,IHW,IVE,IVW &
2423	& ,NUM_SCAL,LSTART &
2424	& ,IDS,IDE,JDS,JDE,KDS,KDE &
2425	& ,IMS,IME,JMS,JME,KMS,KME &
2426	& ,ITS,ITE,JTS,JTE,KTS,KTE)
2427	!***********************************************************************
2428	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
2429	! . . .
2430	! SUBPROGRAM: HAD2_SCAL HORIZONTAL ADVECTION OF SCALAR
2431	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
2432	! GRELL,PECKHAM ORG: NOAA/FSL DATE: 05-02-03
2433	!
2434	! ABSTRACT:
2435	! HAD2_SCAL CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
2436	! TO THE TENDENCIES OF SCALAR SUBSTANCES AND THEN
2437	! UPDATES THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
2438	!
2439	! PROGRAM HISTORY LOG:
2440	! 96-07-19 JANJIC - ORIGINATOR
2441	! 05-01-03 GRELL,PECKHAM - MODIFIED FOR SCALAR
2442	!
2443	! USAGE: CALL HAD2_SCAL FROM SUBROUTINE SOLVE_NMM
2444	! INPUT ARGUMENT LIST:
2445	!
2446	! OUTPUT ARGUMENT LIST
2447	!
2448	! OUTPUT FILES:
2449	! NONE
2450	! SUBPROGRAMS CALLED:
2451	!
2452	! UNIQUE: NONE
2453	!
2454	! LIBRARY: NONE
2455	!
2456	! ATTRIBUTES:
2457	! LANGUAGE: FORTRAN 90
2458	! MACHINE : IBM
2459	!$$$
2460	!***********************************************************************
2461	!-----------------------------------------------------------------------
2462	!
2463	IMPLICIT NONE
2464	!
2465	!-----------------------------------------------------------------------
2466	!
2467	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
2468	& ,IMS,IME,JMS,JME,KMS,KME &
2469	& ,ITS,ITE,JTS,JTE,KTS,KTE
2470	!
2471	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
2472	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
2473	& ,N_IUP_ADH,N_IUP_ADV
2474	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
2475	& ,IUP_ADH,IUP_ADV
2476	!
2477	!-----------------------------------------------------------------------
2478	!
2479	INTEGER,INTENT(IN) :: IDTAD,LSTART,NTSD,NUM_SCAL
2480	!
2481	REAL,INTENT(IN) :: DT,DY,PDTOP
2482	!
2483	REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
2484	!
2485	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
2486	!
2487	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: U,V,Z
2488	!
2489	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,1:NUM_SCAL) &
2490	,INTENT(INOUT) :: SCAL
2491	!
2492	LOGICAL,INTENT(IN) :: HYDRO
2493	!
2494	!-----------------------------------------------------------------------
2495	!*** LOCAL VARIABLES
2496	!-----------------------------------------------------------------------
2497	!
2498	REAL,PARAMETER :: FF1=0.530
2499	!
2500	#ifdef DM_PARALLEL
2501	INTEGER :: DOMDESC
2502	#endif
2503	!
2504	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
2505	LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
2506	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,2) :: XSUMS_L
2507	REAL,DIMENSION(IDS:IDE,JDS:JDE,KDS:KDE,2) :: XSUMS_G
2508	#endif
2509	!
2510	LOGICAL :: BOT,TOP
2511	!
2512	INTEGER :: I,IRECV,J,JFP,JFQ,K,L,LAP,LLAP,MPI_COMM_COMP
2513	INTEGER :: N
2514	!
2515	INTEGER,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5,KTS:KTE) :: IFPA,IFPF &
2516	& ,IFQA,IFQF &
2517	& ,JFPA,JFPF &
2518	& ,JFQA,JFQF
2519	!
2520	REAL :: ADDT,AFRP,CRIT,D2PQE,D2PQQ,D2PQW,DEP,DESTIJ,DQP,DQSTIJ &
2521	& ,DVOLP,DWP,DWSTIJ,DZA,DZB,E00,E0Q,E1X,E2IJ,E4P,ENH,EP,EP0 &
2522	& ,ESTIJ,FPQ,HAFP,HAFQ,HBM2IJ,HM,PP,PPQ00,Q00,Q0Q &
2523	& ,Q1IJ,Q4P,QP,QP0,QSTIJ,RDY,RFACE,RFACQ,RFACW,RFC &
2524	& ,RFEIJ,RFQIJ,RFWIJ,RR,SLOPAC,SPP,SQP,SSA,SSB,SUMNQ,SUMPQ &
2525	& ,TTA,TTB,W00,W0Q,W1IJ,W4P,WP,WP0,WSTIJ
2526	!
2527	DOUBLE PRECISION,DIMENSION(2,KTS:KTE) :: GSUMS,XSUMS
2528	!
2529	REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,Q3,Q4
2530	!
2531	REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: DARE,EMH
2532	!
2533	REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5,KTS:KTE) :: AFP,AFQ,DEST &
2534	& ,DQST,DVOL,DWST &
2535	& ,Q1
2536	!
2537	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME) :: Q
2538	!
2539	!-----------------------------------------------------------------------
2540	integer :: nunit,ier
2541	save nunit
2542	!-----------------------------------------------------------------------
2543	!***********************************************************************
2544	!-----------------------------------------------------------------------
2545	!
2546	RDY=1./DY
2547	SLOPAC=SLOPHTSQRT(2.)0.5*50.
2548	CRIT=SLOPACREAL(IDTAD)DTRDY1000.
2549	!
2550	ADDT=REAL(IDTAD)*DT
2551	ENH=ADDT/(08.*DY)
2552	!
2553	!-----------------------------------------------------------------------
2554	!$omp parallel do &
2555	!$omp& private(i,j)
2556	DO J=MYJS_P3,MYJE_P3
2557	DO I=MYIS_P2,MYIE_P2
2558	EMH (I,J)=ADDT/(08.*DX(I,J))
2559	DARE(I,J)=HBM3(I,J)DX(I,J)DY
2560	ENDDO
2561	ENDDO
2562	!-----------------------------------------------------------------------
2563	!
2564	scalar_loop: DO L=LSTART,NUM_SCAL
2565	!
2566	!-----------------------------------------------------------------------
2567	!$omp parallel do &
2568	!$omp& private(dza,dzb,e1x,fpq,hm,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp &
2569	!$omp& ,tta,ttb)
2570	!-----------------------------------------------------------------------
2571	!
2572	vertical_1: DO K=KTS,KTE
2573	!
2574	!-----------------------------------------------------------------------
2575	!
2576	DO J=MYJS_P3,MYJE_P3
2577	DO I=MYIS_P2,MYIE_P2
2578	DVOL(I,J,K)=DARE(I,J)(DETA1(K)PDTOP+DETA2(K)*PDSL(I,J))
2579	Q (I,J,K)=SCAL(I,J,K,L)
2580	Q1(I,J,K)=Q(I,J,K)
2581	ENDDO
2582	ENDDO
2583	!
2584	!-----------------------------------------------------------------------
2585	!
2586	DO J=MYJS2_P1,MYJE2_P1
2587	DO I=MYIS1_P1,MYIE1_P1
2588	!
2589	HM=HBM2(I,J)
2590	TTA=(U(I,J-1,K)+U(I+IHW(J),J,K)+U(I+IHE(J),J,K)+U(I,J+1,K)) &
2591	& EMH(I,J)HM
2592	TTB=(V(I,J-1,K)+V(I+IHW(J),J,K)+V(I+IHE(J),J,K)+V(I,J+1,K)) &
2593	& ENHHBM2(I,J)
2594	!
2595	SPP=-TTA-TTB
2596	SQP= TTA-TTB
2597	!
2598	IF(SPP<0.)THEN
2599	JFP=-1
2600	ELSE
2601	JFP=1
2602	ENDIF
2603	IF(SQP<0.)THEN
2604	JFQ=-1
2605	ELSE
2606	JFQ=1
2607	ENDIF
2608	!
2609	IFPA(I,J,K)=IHE(J)+I+( JFP-1)/2
2610	IFQA(I,J,K)=IHE(J)+I+(-JFQ-1)/2
2611	!
2612	JFPA(I,J,K)=J+JFP
2613	JFQA(I,J,K)=J+JFQ
2614	!
2615	IFPF(I,J,K)=IHE(J)+I+(-JFP-1)/2
2616	IFQF(I,J,K)=IHE(J)+I+( JFQ-1)/2
2617	!
2618	JFPF(I,J,K)=J-JFP
2619	JFQF(I,J,K)=J-JFQ
2620	!
2621	!-----------------------------------------------------------------------
2622	IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
2623	DZA=(Z(IFPA(I,J,K),JFPA(I,J,K),K)-Z(I,J,K))*RDY
2624	DZB=(Z(IFQA(I,J,K),JFQA(I,J,K),K)-Z(I,J,K))*RDY
2625	!
2626	IF(ABS(DZA)>SLOPAC)THEN
2627	SSA=DZA*SPP
2628	IF(SSA>CRIT)THEN
2629	SPP=0. !spp*.1
2630	ENDIF
2631	ENDIF
2632	!
2633	IF(ABS(DZB)>SLOPAC)THEN
2634	SSB=DZB*SQP
2635	IF(SSB>CRIT)THEN
2636	SQP=0. !sqp*.1
2637	ENDIF
2638	ENDIF
2639	!
2640	ENDIF
2641	!
2642	!-----------------------------------------------------------------------
2643	!
2644	FPQ=SPPSQP0.25
2645	PP=ABS(SPP)
2646	QP=ABS(SQP)
2647	!
2648	AFP(I,J,K)=(((FF4PP+FF3)PP+FF2)PP+FF1)PP
2649	AFQ(I,J,K)=(((FF4QP+FF3)QP+FF2)QP+FF1)QP
2650	!
2651	Q1(I,J,K)=(Q (IFPA(I,J,K),JFPA(I,J,K),K)-Q (I,J,K))*PP &
2652	& +(Q (IFQA(I,J,K),JFQA(I,J,K),K)-Q (I,J,K))*QP &
2653	& +(Q (I,J-2,K)+Q (I,J+2,K) &
2654	& -Q (I-1,J,K)-Q (I+1,J,K))*FPQ &
2655	& +Q(I,J,K)
2656	!
2657	ENDDO
2658	ENDDO
2659	!
2660	!-----------------------------------------------------------------------
2661	!
2662	ENDDO vertical_1
2663	!
2664	!-----------------------------------------------------------------------
2665	!*** ANTI-FILTERING STEP
2666	!-----------------------------------------------------------------------
2667	!
2668	DO K=KTS,KTE
2669	XSUMS(1,K)=0.
2670	XSUMS(2,K)=0.
2671	ENDDO
2672	!
2673	!-----------------------------------------------------------------------
2674	!
2675	!*** ANTI-FILTERING LIMITERS
2676	!
2677	!-----------------------------------------------------------------------
2678	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
2679	DO N=1,2
2680	!
2681	!$omp parallel do &
2682	!$omp& private(i,j,k)
2683	DO K=KMS,KME
2684	DO J=JMS,JME
2685	DO I=IMS,IME
2686	XSUMS_L(I,J,K,N)=0.
2687	ENDDO
2688	ENDDO
2689	ENDDO
2690	!
2691	!$omp parallel do &
2692	!$omp& private(i,j,k)
2693	DO K=KDS,KDE
2694	DO J=JDS,JDE
2695	DO I=IDS,IDE
2696	XSUMS_G(I,J,K,N)=0.
2697	ENDDO
2698	ENDDO
2699	ENDDO
2700	!
2701	ENDDO
2702	!
2703	#endif
2704	!-----------------------------------------------------------------------
2705	!$omp parallel do &
2706	!$omp& private(d2pqe,d2pqq,d2pqw,destij,dqstij,dvolp,dwstij &
2707	!$omp& ,e00,e0q,ep0,estij,hafp,hafq,i,j,k &
2708	!$omp& ,q00,q0q,q1ij,qp0,qstij,w00,w0q,wp0,wstij)
2709	!-----------------------------------------------------------------------
2710	!
2711	vertical_2: DO K=KTS,KTE
2712	!
2713	!-----------------------------------------------------------------------
2714	!
2715	DO J=MYJS2,MYJE2
2716	DO I=MYIS1,MYIE1
2717	!
2718	DVOLP=DVOL(I,J,K)
2719	Q1IJ =Q1(I,J,K)
2720	!
2721	HAFP=AFP(I,J,K)
2722	HAFQ=AFQ(I,J,K)
2723	!
2724	D2PQQ=(Q1(IFPA(I,J,K),JFPA(I,J,K),K)-Q1IJ &
2725	& -Q1IJ+Q1(IFPF(I,J,K),JFPF(I,J,K),K)) &
2726	& *HAFP &
2727	& +(Q1(IFQA(I,J,K),JFQA(I,J,K),K)-Q1IJ &
2728	& -Q1IJ+Q1(IFQF(I,J,K),JFQF(I,J,K),K)) &
2729	& *HAFQ
2730	!
2731	QSTIJ=Q1IJ-D2PQQ
2732	!
2733	Q00=Q (I ,J ,K)
2734	QP0=Q (IFPA(I,J,K),JFPA(I,J,K),K)
2735	Q0Q=Q (IFQA(I,J,K),JFQA(I,J,K),K)
2736	!
2737	QSTIJ=MAX(QSTIJ,MIN(Q00,QP0,Q0Q))
2738	QSTIJ=MIN(QSTIJ,MAX(Q00,QP0,Q0Q))
2739	!
2740	DQSTIJ=QSTIJ-Q(I,J,K)
2741	!
2742	DQST(I,J,K)=DQSTIJ
2743	!
2744	DQSTIJ=DQSTIJ*DVOLP
2745	!
2746	!-----------------------------------------------------------------------
2747	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
2748	!-----------------------------------------------------------------------
2749	DO N=1,2
2750	XSUMS_L(I,J,K,N)=0.
2751	ENDDO
2752	!
2753	IF(DQSTIJ>0.)THEN
2754	XSUMS_L(I,J,K,1)=DQSTIJ
2755	ELSE
2756	XSUMS_L(I,J,K,2)=DQSTIJ
2757	ENDIF
2758	!
2759	!-----------------------------------------------------------------------
2760	#else
2761	!-----------------------------------------------------------------------
2762	IF(DQSTIJ>0.)THEN
2763	XSUMS(1,K)=XSUMS(1,K)+DQSTIJ
2764	ELSE
2765	XSUMS(2,K)=XSUMS(2,K)+DQSTIJ
2766	ENDIF
2767	!
2768	!-----------------------------------------------------------------------
2769	#endif
2770	!-----------------------------------------------------------------------
2771	!
2772	ENDDO
2773	ENDDO
2774	!
2775	!-----------------------------------------------------------------------
2776	!
2777	ENDDO vertical_2
2778	!
2779	!-----------------------------------------------------------------------
2780	#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
2781	!-----------------------------------------------------------------------
2782	DO N=1,2
2783	CALL WRF_PATCH_TO_GLOBAL_REAL(XSUMS_L(IMS,JMS,KMS,N) &
2784	&, XSUMS_G(1,1,1,N),DOMDESC &
2785	&, 'xyz','xzy' &
2786	&, IDS,IDE,KDS,KDE,JDS,JDE &
2787	&, IMS,IME,KMS,KME,JMS,JME &
2788	&, ITS,ITE,KTS,KTE,JTS,JTE)
2789	ENDDO
2790	!
2791	DO K=KTS,KTE
2792	DO N=1,2
2793	GSUMS(N,K)=0.
2794	ENDDO
2795	ENDDO
2796	!
2797	IF(WRF_DM_ON_MONITOR())THEN
2798	DO N=1,2
2799	!$omp parallel do &
2800	!$omp& private(i,j,k)
2801	DO K=KDS,KDE
2802	DO J=JDS,JDE
2803	DO I=IDS,IDE
2804	GSUMS(N,K)=GSUMS(N,K)+XSUMS_G(I,J,K,N)
2805	ENDDO
2806	ENDDO
2807	ENDDO
2808	ENDDO
2809	ENDIF
2810
2811	CALL WRF_DM_BCAST_BYTES(GSUMS,2RWORDSIZE2*(KDE-KDS+1) )
2812
2813	!-----------------------------------------------------------------------
2814	#else
2815	!-----------------------------------------------------------------------
2816	!
2817	!-----------------------------------------------------------------------
2818	!*** GLOBAL REDUCTION
2819	!-----------------------------------------------------------------------
2820	!
2821	# if defined(DM_PARALLEL) && !defined(STUBMPI)
2822	CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
2823	CALL MPI_ALLREDUCE(XSUMS,GSUMS,2*(KTE-KTS+1) &
2824	& ,MPI_DOUBLE_PRECISION,MPI_SUM &
2825	& ,MPI_COMM_COMP,IRECV)
2826	# else
2827	DO K=KTS,KTE
2828	DO N=1,2
2829	GSUMS(N,K)=XSUMS(N,K)
2830	ENDDO
2831	ENDDO
2832	# endif
2833	!
2834	!-----------------------------------------------------------------------
2835	#endif
2836	!-----------------------------------------------------------------------
2837	!
2838	!-----------------------------------------------------------------------
2839	!*** END OF GLOBAL REDUCTION
2840	!-----------------------------------------------------------------------
2841	!
2842	! if(mype==0)then
2843	!!! if(ntsd==0)then
2844	!!! call int_get_fresh_handle(nunit)
2845	!!! close(nunit)
2846	! nunit=56
2847	!!! open(unit=nunit,file='gsums',form='unformatted',iostat=ier)
2848	!!! endif
2849	! endif
2850	!-----------------------------------------------------------------------
2851	!$omp parallel do &
2852	!$omp& private(destij,dqstij,dwstij,i,j,k,rface,rfacq,rfacw &
2853	!$omp& ,rfeij,rfqij,rfwij,sumnq,sumpq)
2854	!-----------------------------------------------------------------------
2855	!
2856	vertical_3: DO K=KTS,KTE
2857	!
2858	!-----------------------------------------------------------------------
2859	! if(mype==0)then
2860	! write(nunit)(gsums(i,k),i=1,6)
2861	! endif
2862	!!! read(nunit)(gsums(i,k),i=1,6)
2863	!-----------------------------------------------------------------------
2864	!
2865	SUMPQ=GSUMS(1,K)
2866	SUMNQ=GSUMS(2,K)
2867	!
2868	!-----------------------------------------------------------------------
2869	!*** FIRST MOMENT CONSERVING FACTOR
2870	!-----------------------------------------------------------------------
2871	!
2872	IF(SUMPQ>1.)THEN
2873	RFACQ=-SUMNQ/SUMPQ
2874	ELSE
2875	RFACQ=1.
2876	ENDIF
2877	!
2878	IF(RFACQ<CONSERVE_MIN.OR.RFACQ>CONSERVE_MAX)RFACQ=1.
2879	!
2880	!-----------------------------------------------------------------------
2881	! if(mype==0.and.ntsd==181)close(nunit)
2882	!-----------------------------------------------------------------------
2883	!
2884	!-----------------------------------------------------------------------
2885	!*** IMPOSE CONSERVATION ON ANTI-FILTERING
2886	!-----------------------------------------------------------------------
2887	!
2888	DO J=MYJS2,MYJE2
2889	IF(RFACQ<1.)THEN
2890	DO I=MYIS1,MYIE1
2891	DQSTIJ=DQST(I,J,K)
2892	RFQIJ=HBM2(I,J)*(RFACQ-1.)+1.
2893	IF(DQSTIJ>=0.)DQSTIJ=DQSTIJ*RFQIJ
2894	Q(I,J,K)=Q(I,J,K)+DQSTIJ
2895	ENDDO
2896	ELSE
2897	DO I=MYIS1,MYIE1
2898	DQSTIJ=DQST(I,J,K)
2899	RFQIJ=HBM2(I,J)*(RFACQ-1.)+1.
2900	IF(DQSTIJ<0.)DQSTIJ=DQSTIJ/RFQIJ
2901	Q(I,J,K)=Q(I,J,K)+DQSTIJ
2902	ENDDO
2903	ENDIF
2904	ENDDO
2905	!
2906	!-----------------------------------------------------------------------
2907	!
2908	DO J=MYJS,MYJE
2909	DO I=MYIS,MYIE
2910	SCAL(I,J,K,L)=Q(I,J,K)
2911	ENDDO
2912	ENDDO
2913	!
2914	!-----------------------------------------------------------------------
2915	!
2916	ENDDO vertical_3
2917	!
2918	!-----------------------------------------------------------------------
2919	!
2920	ENDDO scalar_loop
2921	!
2922	!-----------------------------------------------------------------------
2923	!
2924	END SUBROUTINE HAD2_SCAL
2925	!
2926	!-----------------------------------------------------------------------
2927	!-----------------------------------------------------------------------
2928	!
2929	END MODULE MODULE_ADVECTION
2930	!
2931	!-----------------------------------------------------------------------
2932

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

Download in other formats:

Original Format