Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

module_ADVECTION.F @ 3568

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

Rev	Line
[2759]	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