Context Navigation

module_IGWAVE_ADJUST.F @ 2748

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

Rev	Line
[2747]	1	!-----------------------------------------------------------------------
	2	!
	3	!NCEP_MESO:MODEL_LAYER: INERTIAL GRAVITY WAVE ADJUSTMENT
	4	!
	5	!-----------------------------------------------------------------------
	6	#include "nmm_loop_basemacros.h"
	7	#include "nmm_loop_macros.h"
	8	#define DATA_CALLS_INCLUDED
	9	!-----------------------------------------------------------------------
	10	!
	11	MODULE MODULE_IGWAVE_ADJUST
	12	!
	13	!-----------------------------------------------------------------------
	14	USE MODULE_MODEL_CONSTANTS
	15	! USE MODULE_EXCHANGE
	16	USE MODULE_MPP,ONLY: MYPE
	17	! USE MODULE_TIMERS ! this one creates a name conflict at compile time
	18	!-----------------------------------------------------------------------
	19	!***
	20	!*** SPECIFY THE NUMBER OF TIMES TO SMOOTH THE VERTICAL VELOCITY
	21	!*** AND THE NUMBER OF ROWS FROM THE NORTHERN AND SOUTHERN EDGES
	22	!*** OF THE GLOBAL DOMAIN BEYOND WHICH THE SMOOTHING DOES NOT GO
	23	!*** FOR SUBROUTINE PDTE
	24	!
	25	INTEGER :: KSMUD=0,LNSDT=7
	26	!
	27	!-----------------------------------------------------------------------
	28	!
	29	CONTAINS
	30	!
	31	!***********************************************************************
	32	SUBROUTINE PFDHT(NTSD,LAST_TIME,PT,DETA1,DETA2,PDTOP,RES,FIS &
	33	& ,HYDRO,SIGMA,FIRST,DX,DY &
	34	& ,HBM2,VBM2,VBM3 &
	35	& ,FDIV,FCP,WPDAR,DFL,CPGFU,CPGFV &
	36	& ,PD,PDSL,T,Q,U,V,CWM,OMGALF,PINT,DWDT &
	37	& ,RTOP,DIV,FEW,FNS,FNE,FSE &
	38	& ,IHE,IHW,IVE,IVW &
	39	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	40	& ,IMS,IME,JMS,JME,KMS,KME &
	41	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	42	!***********************************************************************
	43	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
	44	! . . .
	45	! SUBPROGRAM: PFDHT DIVERGENCE/HORIZONTAL OMEGA-ALPHA
	46	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 93-10-28
	47	!
	48	! ABSTRACT:
	49	! PFDHT CALCULATES THE PRESSURE GRADIENT FORCE, UPDATES THE
	50	! VELOCITY COMPONENTS DUE TO THE EFFECT OF THE PRESSURE GRADIENT
	51	! AND CORIOILS FORCES, COMPUTES THE DIVERGENCE INCLUDING THE
	52	! MODIFICATION PREVENTING GRAVITY WAVE GRID SEPARATION, AND
	53	! CALCULATES THE HORIZONTAL PART OF THE OMEGA-ALPHA TERM.
	54	! (THE PART PROPORTIONAL TO THE ADVECTION OF MASS ALONG
	55	! COORDINATE SURFACES).
	56	!
	57	! PROGRAM HISTORY LOG:
	58	! 87-06-?? JANJIC - ORIGINATOR
	59	! 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
	60	! 96-03-29 BLACK - ADDED EXTERNAL EDGE
	61	! 98-10-30 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
	62	! 02-02-01 BLACK - REWRITTEN FOR WRF CODING STANDARDS
	63	! 04-02-17 JANJIC - REMOVED UPDATE OF TEMPERATURE
	64	! 04-11-23 BLACK - THREADED
	65	! 05-12-09 BLACK - CONVERTED FROM IKJ TO IJK
	66	!
	67	! USAGE: CALL PFDHT FROM MAIN PROGRAM SOLVE_RUNSTREAM
	68	! INPUT ARGUMENT LIST:
	69	!
	70	! OUTPUT ARGUMENT LIST:
	71	!
	72	! OUTPUT FILES:
	73	! NONE
	74	!
	75	! SUBPROGRAMS CALLED:
	76	!
	77	! UNIQUE: NONE
	78	!
	79	! LIBRARY: NONE
	80	!
	81	! ATTRIBUTES:
	82	! LANGUAGE: FORTRAN 90
	83	! MACHINE : IBM SP
	84	!$$$
	85	!-----------------------------------------------------------------------
	86	!***********************************************************************
	87	!-----------------------------------------------------------------------
	88	IMPLICIT NONE
	89	!-----------------------------------------------------------------------
	90	!#ifdef DM_PARALLEL
	91	! INCLUDE "mpif.h"
	92	!#endif
	93	!-----------------------------------------------------------------------
	94	LOGICAL,INTENT(IN) :: FIRST,HYDRO
	95	INTEGER,INTENT(IN) :: SIGMA
	96	!
	97	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
	98	& ,IMS,IME,JMS,JME,KMS,KME &
	99	& ,ITS,ITE,JTS,JTE,KTS,KTE
	100	!
	101	INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
	102	!
	103	INTEGER,INTENT(IN) :: NTSD
	104	LOGICAL,INTENT(IN) :: LAST_TIME
	105	!
	106	REAL,INTENT(IN) :: CPGFV,DY,PDTOP,PT
	107	!
	108	REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: DETA1,DETA2
	109	!
	110	REAL,DIMENSION(KMS:KME),INTENT(IN) :: DFL
	111	!
	112	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CPGFU,DX,FCP,FDIV &
	113	& ,PD,FIS,RES,WPDAR &
	114	& ,HBM2,VBM2,VBM3
	115	!
	116	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: CWM,DWDT &
	117	& ,Q,T
	118	!
	119	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
	120	!
	121	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DIV &
	122	& ,OMGALF &
	123	& ,RTOP,U,V
	124	!
	125	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: FEW,FNS &
	126	& ,FNE,FSE
	127	!
	128	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: PDSL
	129	!
	130	!-----------------------------------------------------------------------
	131	!*** LOCAL VARIABLES
	132	!-----------------------------------------------------------------------
	133	!
	134	INTEGER :: I,J,K
	135	!
	136	REAL :: SLP_STD=101300.0
	137	!
	138	REAL :: APELP,DFI,DCNEK,DCSEK,DPFNEK,DPFSEK,DPNEK,DPSEK &
	139	& ,EDIV,FIUP,PRSFRC,PVNEK,PVSEK,RTOPP,VM
	140	!
	141	REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: ADPDNE,ADPDSE &
	142	& ,ADPDX,ADPDY,APEL &
	143	& ,CNE,CSE,DFDZ,DPDE &
	144	& ,DPFEW,DPFNS &
	145	& ,FILO,FIM,HM &
	146	& ,PCEW,PCNE,PCNS,PCSE &
	147	& ,PCXC,PEW,PNE,PNS &
	148	& ,PPNE,PPSE,PSE &
	149	& ,RDPD,RDPDX,RDPDY &
	150	& ,TEW,TNE,TNS,TSE &
	151	& ,UDY,VDX
	152	!
	153	!-----------------------------------------------------------------------
	154	!***********************************************************************
	155	!
	156	!
	157	! CSE CSE ------- 1
	158	! * *
	159	! * *
	160	! ******* * ******* *
	161	! * * * * * *
	162	! CNE * * CNE * *
	163	! TEW----------OMGALF----------TEW ------- 0
	164	! CSE * * CSE * *
	165	! * * * * * *
	166	! ******* * ******* *
	167	! * *
	168	! * *
	169	! CNE CNE ------- -1
	170	!
	171	!
	172	!
	173	!
	174	!***********************************************************************
	175	!
	176	! CSE ------- 2
	177	! *
	178	! *
	179	! *
	180	! *
	181	! CNE*****TNS ------- 1
	182	! CSE \| *
	183	! \| *
	184	! \| *
	185	! \| *
	186	! \| CNE
	187	! OMGALF ------- 0
	188	! \| CSE
	189	! \| *
	190	! \| *
	191	! \| *
	192	! CNE \| *
	193	! CSE*****TNS ------- -1
	194	! *
	195	! *
	196	! *
	197	! *
	198	! CNE ------- -2
	199	!
	200	!***********************************************************************
	201	!-----------------------------------------------------------------------
	202	!*** PREPARATORY CALCULATIONS
	203	!-----------------------------------------------------------------------
	204	! call hpm_start('PFDHT')
	205	!
	206	!$omp parallel do
	207	DO K=KMS,KME
	208	DO J=JMS,JME
	209	DO I=IMS,IME
	210	OMGALF(I,J,K)=0.
	211	DIV(I,J,K)=0.
	212	ENDDO
	213	ENDDO
	214	ENDDO
	215	!
	216	!$omp parallel do
	217	DO J=JMS,JME
	218	DO I=IMS,IME
	219	PDSL(I,J)=0.
	220	ENDDO
	221	ENDDO
	222	!
	223	!$omp parallel do
	224	DO J=JTS-5,JTE+5
	225	DO I=ITS-5,ITE+5
	226	ADPDNE(I,J)=0.
	227	ADPDSE(I,J)=0.
	228	ADPDX(I,J)=0.
	229	ADPDY(I,J)=0.
	230	APEL(I,J)=0.
	231	CNE (I,J)=0.
	232	CSE (I,J)=0.
	233	DFDZ(I,J)=0.
	234	DPDE(I,J)=0.
	235	DPFEW(I,J)=0.
	236	DPFNS(I,J)=0.
	237	FILO(I,J)=0.
	238	FIM (I,J)=0.
	239	HM (I,J)=0.
	240	PCEW(I,J)=0.
	241	PCNE(I,J)=0.
	242	PCNS(I,J)=0.
	243	PCSE(I,J)=0.
	244	PCXC(I,J)=0.
	245	PEW (I,J)=0.
	246	PNE (I,J)=0.
	247	PNS (I,J)=0.
	248	PPNE(I,J)=0.
	249	PPSE(I,J)=0.
	250	PSE (I,J)=0.
	251	RDPD(I,J)=0.
	252	RDPDX(I,J)=0.
	253	RDPDY(I,J)=0.
	254	TEW (I,J)=0.
	255	TNE (I,J)=0.
	256	TNS (I,J)=0.
	257	TSE (I,J)=0.
	258	UDY (I,J)=0.
	259	VDX (I,J)=0.
	260	ENDDO
	261	ENDDO
	262	!
	263	IF(SIGMA==1)THEN
	264	!$omp parallel do
	265	DO J=MYJS_P4,MYJE_P4
	266	DO I=MYIS_P4,MYIE_P4
	267	FILO(I,J)=FIS(I,J)
	268	PDSL(I,J)=PD(I,J)
	269	ENDDO
	270	ENDDO
	271	ELSE
	272	!$omp parallel do
	273	DO J=MYJS_P4,MYJE_P4
	274	DO I=MYIS_P4,MYIE_P4
	275	FILO(I,J)=0.0
	276	PDSL(I,J)=RES(I,J)*PD(I,J)
	277	ENDDO
	278	ENDDO
	279	ENDIF
	280	!
	281	PRSFRC=PDTOP/(SLP_STD-PT)
	282	!
	283	!-----------------------------------------------------------------------
	284	!
	285	!*** MAIN VERTICAL INTEGRATION LOOP
	286	!
	287	!-----------------------------------------------------------------------
	288	!$omp parallel do
	289	!$omp& private(adpdne,adpdse,adpdx,adpdy,
	290	!$omp& apel,cne,cse,dcnek,dcsek,dfdz,dpde,dpfew,dpfnek,
	291	!$omp& dpfns,dpfsek,dpnek,ediv,few,fne,fns,fse,hm,
	292	!$omp& pcew,pcne,pcns,pcse,pcxc,pew,pne,pns,ppne,ppse,
	293	!$omp& pse,pvnek,pvsek,rdpd,rdpdx,rdpdy,tew,tne,tns,tse,
	294	!$omp& udy,vdx,vm)
	295	!-----------------------------------------------------------------------
	296	!
	297	main_integration : DO K=KTS,KTE
	298	!
	299	!-----------------------------------------------------------------------
	300	!
	301	!-----------------------------------------------------------------------
	302	!*** INTEGRATE THE GEOPOTENTIAL
	303	!-----------------------------------------------------------------------
	304	!
	305	DO J=MYJS_P4,MYJE_P4
	306	DO I=MYIS_P4,MYIE_P4
	307	!
	308	HM(I,J)=HBM2(I,J)
	309	!
	310	APELP=(PINT(I,J,K+1)+PINT(I,J,K))*0.5
	311	RTOPP=(Q(I,J,K)P608-CWM(I,J,K)+1.)T(I,J,K)*R_D/APELP
	312	DFI=RTOPP(DETA1(K)PDTOP+DETA2(K)*PDSL(I,J))
	313	!
	314	APEL(I,J)=APELP
	315	RTOP(I,J,K)=RTOPP
	316	DFDZ(I,J)=RTOPP
	317	!
	318	FIUP=FILO(I,J)+DFI
	319	FIM(I,J)=FILO(I,J)+FIUP
	320	! if(i==154.and.j==096)then
	321	! write(0,10281)k,q(i,j,k),cwm(i,j,k),t(i,j,k),apelp,pdsl(i,j)
	322	10281 format(' k=',i2,' q=',z8,' cwm=',z8,' t=',z8,' apelp=',z8,' pdsl=',z8)
	323	! endif
	324	FILO(I,J)=FIUP
	325	!
	326	ENDDO
	327	ENDDO
	328	!
	329	!-----------------------------------------------------------------------
	330	!
	331	DO J=MYJS_P4,MYJE_P4
	332	DO I=MYIS_P4,MYIE_P4
	333	DPDE(I,J)=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
	334	ENDDO
	335	ENDDO
	336	!
	337	DO J=MYJS,MYJE
	338	DO I=MYIS,MYIE
	339	RDPD(I,J)=1./DPDE(I,J)
	340	ENDDO
	341	ENDDO
	342	!
	343	DO J=MYJS1_P3,MYJE1_P3
	344	DO I=MYIS_P3,MYIE_P3
	345	ADPDX(I,J)=DPDE(I+IVW(J),J)+DPDE(I+IVE(J),J)
	346	ADPDY(I,J)=DPDE(I,J+1)+DPDE(I,J-1)
	347	RDPDX(I,J)=1./ADPDX(I,J)
	348	RDPDY(I,J)=1./ADPDY(I,J)
	349	ENDDO
	350	ENDDO
	351	!
	352	!-----------------------------------------------------------------------
	353	!*** DIAGONAL CONTRIBUTIONS TO PRESSURE GRADIENT FORCE
	354	!-----------------------------------------------------------------------
	355	!
	356	DO J=MYJS_P3,MYJE1_P3
	357	DO I=MYIS_P3,MYIE_P3
	358	ADPDNE(I,J)=DPDE(I+IHE(J),J+1)+DPDE(I,J)
	359	PNE(I,J)=(FIM (I+IHE(J),J+1)-FIM (I,J)) &
	360	& *(DWDT(I+IHE(J),J+1,K)+DWDT(I,J,K))
	361	PPNE(I,J)=PNE(I,J)*ADPDNE(I,J)
	362	CNE(I,J)=(DFDZ(I+IHE(J),J+1)+DFDZ(I,J))*2. &
	363	& *(APEL(I+IHE(J),J+1)-APEL(I,J))
	364	PCNE(I,J)=CNE(I,J)*ADPDNE(I,J)
	365	ENDDO
	366	ENDDO
	367	!
	368	DO J=MYJS1_P3,MYJE_P3
	369	DO I=MYIS_P3,MYIE_P3
	370	ADPDSE(I,J)=DPDE(I+IHE(J),J-1)+DPDE(I,J)
	371	PSE(I,J)=(FIM (I+IHE(J),J-1)-FIM (I,J)) &
	372	& *(DWDT(I+IHE(J),J-1,K)+DWDT(I,J,K))
	373	! if(i==154.and.j==096.and.k==kte)then
	374	! write(0,58391)PSE(I,J),FIM(I+IHE(J),J-1),FIM(I,J),DWDT(I+IHE(J),J-1,K),DWDT(I,J,K),ihe(j)
	375	58391 format(' pse=',z8,' fim=',2(1x,z8),' dwdt=',2(1x,z8),' ihe=',i2)
	376	! endif
	377	PPSE(I,J)=PSE(I,J)*ADPDSE(I,J)
	378	CSE(I,J)=(DFDZ(I+IHE(J),J-1)+DFDZ(I,J))*2. &
	379	& *(APEL(I+IHE(J),J-1)-APEL(I,J))
	380	PCSE(I,J)=CSE(I,J)*ADPDSE(I,J)
	381	ENDDO
	382	ENDDO
	383	!
	384	!-----------------------------------------------------------------------
	385	!*** CONTINUITY EQUATION MODIFICATION
	386	!-----------------------------------------------------------------------
	387	!
	388	DO J=MYJS1_P1,MYJE1_P1
	389	DO I=MYIS_P1,MYIE_P1
	390	! if(i==155.and.j==096.and.k==kte)then
	391	! write(0,72451)PNE(I+IVW(J),J),PNE(I,J-1),PSE(I+IVW(J),J),PSE(I,J+1),ivw(j)
	392	! write(0,72452)CNE(I+IVW(J),J),CNE(I,J-1),CSE(I+IVW(J),J),CSE(I,J+1)
	393	72451 format(' pne=',2(1x,z8),' pse=',2(1x,z8),' ivw=',i2)
	394	72452 format(' cne=',2(1x,z8),' cse=',2(1x,z8))
	395	! endif
	396	PCXC(I,J)=VBM3(I,J)* &
	397	& (PNE(I+IVW(J),J)+CNE(I+IVW(J),J) &
	398	& +PSE(I+IVW(J),J)+CSE(I+IVW(J),J) &
	399	& -PNE(I,J-1)-CNE(I,J-1) &
	400	& -PSE(I,J+1)-CSE(I,J+1))
	401	ENDDO
	402	ENDDO
	403	!
	404	!-----------------------------------------------------------------------
	405	!
	406	DO J=MYJS2,MYJE2
	407	DO I=MYIS1,MYIE1
	408	! if(i==155.and.j==095.and.k==kte)then
	409	! write(0,76501)deta1(k),deta2(k),prsfrc,wpdar(i,j),ihe(j),ihw(j)
	410	! write(0,76502)PCXC(I+IHE(J),J),PCXC(I,J+1),PCXC(I+IHW(J),J),PCXC(I,J-1)
	411	76501 format(' deta1=',z8,' deta2=',z8,' prsfrc=',z8,' wpdar=',z8,' ihe=',i2,' ihw=',i2)
	412	76502 format(' pcxc=',4(1x,z8))
	413	! endif
	414	DIV(I,J,K)=(DETA1(K)*PRSFRC &
	415	& +DETA2(K)(1.-PRSFRC))WPDAR(I,J) &
	416	& *(PCXC(I+IHE(J),J)-PCXC(I,J+1) &
	417	& +PCXC(I+IHW(J),J)-PCXC(I,J-1))
	418	ENDDO
	419	ENDDO
	420	!
	421	!-----------------------------------------------------------------------
	422	!*** LATITUDINAL AND LONGITUDINAL PRESSURE FORCE COMPONENTS
	423	!-----------------------------------------------------------------------
	424	!
	425	DO J=MYJS1_P2,MYJE1_P2
	426	DO I=MYIS_P2,MYIE_P3
	427	DPNEK=PNE(I+IVW(J),J)+PNE(I,J-1)
	428	DPSEK=PSE(I+IVW(J),J)+PSE(I,J+1)
	429	PEW(I,J)=DPNEK+DPSEK
	430	PNS(I,J)=DPNEK-DPSEK
	431	DCNEK=CNE(I+IVW(J),J)+CNE(I,J-1)
	432	DCSEK=CSE(I+IVW(J),J)+CSE(I,J+1)
	433	PCEW(I,J)=(DCNEK+DCSEK)*ADPDX(I,J)
	434	PCNS(I,J)=(DCNEK-DCSEK)*ADPDY(I,J)
	435	ENDDO
	436	ENDDO
	437	!
	438	!-----------------------------------------------------------------------
	439	!
	440	IF(.NOT.FIRST)THEN ! Skip at timestep 0
	441	!
	442	!-----------------------------------------------------------------------
	443	!*** UPDATE U AND V FOR PRESSURE GRADIENT FORCE
	444	!-----------------------------------------------------------------------
	445	!
	446	DO J=MYJS2_P2,MYJE2_P2
	447	DO I=MYIS_P2,MYIE1_P2
	448	DPFNEK=((PPNE(I+IVW(J),J)+PPNE(I,J-1)) &
	449	& +(PCNE(I+IVW(J),J)+PCNE(I,J-1)))
	450	DPFNEK=DPFNEK+DPFNEK
	451	DPFSEK=((PPSE(I+IVW(J),J)+PPSE(I,J+1)) &
	452	& +(PCSE(I+IVW(J),J)+PCSE(I,J+1)))
	453	DPFSEK=DPFSEK+DPFSEK
	454	DPFEW(I,J)=DPFNEK+DPFSEK
	455	DPFNS(I,J)=DPFNEK-DPFSEK
	456	ENDDO
	457	ENDDO
	458	!
	459	!-----------------------------------------------------------------------
	460	!
	461	DO J=MYJS2_P3,MYJE2_P3
	462	DO I=MYIS_P2,MYIE1_P2
	463	VM=VBM2(I,J)
	464	U(I,J,K)=(((DPFEW(I,J)+PCEW(I,J))*RDPDX(I,J) &
	465	& +PEW(I,J))CPGFU(I,J))VM+U(I,J,K)
	466	V(I,J,K)=(((DPFNS(I,J)+PCNS(I,J))*RDPDY(I,J) &
	467	& +PNS(I,J))CPGFV)VM+V(I,J,K)
	468	ENDDO
	469	ENDDO
	470	!
	471	!-----------------------------------------------------------------------
	472	!
	473	ENDIF !End of IF block executed for FIRST equal to .FALSE.
	474	!
	475	!-----------------------------------------------------------------------
	476	!-----------------------------------------------------------------------
	477	!
	478	IF(.NOT.LAST_TIME)THEN !Do not execute block at last timestep
	479	!
	480	!-----------------------------------------------------------------------
	481	!*** LATITUDINAL AND LONGITUDINAL FLUXES AND OMEGA-ALPHA COMPONENTS
	482	!-----------------------------------------------------------------------
	483	!
	484	DO J=MYJS1_P2,MYJE1_P2
	485	DO I=MYIS_P2,MYIE_P3
	486	UDY(I,J)=DY*U(I,J,K)
	487	FEW(I,J,K)=UDY(I,J)*ADPDX(I,J)
	488	TEW(I,J)=UDY(I,J)*PCEW(I,J)
	489	VDX(I,J)=DX(I,J)*V(I,J,K)
	490	! if(i==178.and.j==003.and.k==53)then
	491	! write(0,77601)udy(i,j),dy,u(i,j,k)
	492	77601 format(' udy=',z8,' dy=',z8,' u=',z8)
	493	! endif
	494	FNS(I,J,K)=VDX(I,J)*ADPDY(I,J)
	495	TNS(I,J)=VDX(I,J)*PCNS(I,J)
	496	ENDDO
	497	ENDDO
	498	!
	499	!-----------------------------------------------------------------------
	500	!*** DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND
	501	!-----------------------------------------------------------------------
	502	!
	503	DO J=MYJS1_P1,MYJE2_P1
	504	DO I=MYIS_P1,MYIE1_P1
	505	PVNEK=(UDY(I+IHE(J),J)+VDX(I+IHE(J),J)) &
	506	& +(UDY(I,J+1)+VDX(I,J+1))
	507	FNE(I,J,K)=PVNEK*ADPDNE(I,J)
	508	! if(i==178.and.j==003.and.k==53)then
	509	! write(0,33781)fne(i,j,k),dpde(i+ihe(j),j+1),dpde(i,j),ihe(j)
	510	! write(0,33782)udy(i+ihe(j),j),udy(i,j+1),vdx(i+ihe(j),j),vdx(i,j+1)
	511	33781 format(' fne=',z8,' dpdne=',2(1x,z8),' ihe=',i2)
	512	33782 format(' udy=',2(1x,z8),' vdx=',2(1x,z8))
	513	! endif
	514	TNE(I,J)=PVNEKPCNE(I,J)2.
	515	ENDDO
	516	ENDDO
	517	!
	518	DO J=MYJS2_P1,MYJE1_P1
	519	DO I=MYIS_P1,MYIE1_P1
	520	PVSEK=(UDY(I+IHE(J),J)-VDX(I+IHE(J),J)) &
	521	& +(UDY(I,J-1)-VDX(I,J-1))
	522	FSE(I,J,K)=PVSEK*ADPDSE(I,J)
	523	TSE(I,J)=PVSEKPCSE(I,J)2.
	524	ENDDO
	525	ENDDO
	526	!
	527	!-----------------------------------------------------------------------
	528	!*** HORIZONTAL PART OF OMEGA-ALPHA & DIVERGENCE
	529	!-----------------------------------------------------------------------
	530	!
	531	DO J=MYJS2,MYJE2
	532	DO I=MYIS1,MYIE1
	533	OMGALF(I,J,K)=(TEW(I+IHE(J),J)+TEW(I+IHW(J),J) &
	534	& +TNS(I,J+1) +TNS(I,J-1) &
	535	& +TNE(I,J) +TNE(I+IHW(J),J-1) &
	536	& +TSE(I,J) +TSE(I+IHW(J),J+1)) &
	537	& RDPD(I,J)FCP(I,J)*HM(I,J)
	538	!
	539	! if(i==178.and.j==003.and.k==53)then
	540	! write(0,36311)div(i,j,k),fdiv(i,j),ihe(j),ihw(j)
	541	! write(0,36312)FEW(I+IHE(J),J,K),FEW(I+IHW(J),J,K),FNS(I,J+1,K),FNS(I,J-1,K)
	542	! write(0,36313)FNE(I,J,K),FNE(I+IHW(J),J-1,K),FSE(I,J,K),FSE(I+IHW(J),J+1,K)
	543	36311 format(' PFDHT div=',z8,' fdiv=',z8,' ihe=',i2,' ihw=',i2)
	544	36312 format(' few=',2(1x,z8),' fns=',2(1x,z8))
	545	36313 format(' fne=',2(1x,z8),' fse=',2(1x,z8))
	546	! endif
	547	EDIV=(FEW(I+IHE(J),J,K) +FNS(I,J+1,K) &
	548	+FNE(I,J,K) +FSE(I,J,K) &
	549	-(FEW(I+IHW(J),J,K) +FNS(I,J-1,K) &
	550	+FNE(I+IHW(J),J-1,K)+FSE(I+IHW(J),J+1,K)))*FDIV(I,J)
	551	!
	552	DIV(I,J,K)=(EDIV+DIV(I,J,K))*HM(I,J)
	553	ENDDO
	554	ENDDO
	555	!
	556	!-----------------------------------------------------------------------
	557	!
	558	ENDIF !End block to skip execution at last timestep
	559	!
	560	!-----------------------------------------------------------------------
	561	!
	562	ENDDO main_integration
	563	!
	564	!-----------------------------------------------------------------------
	565	! call hpm_stop('PFDHT')
	566	!-----------------------------------------------------------------------
	567	!
	568	END SUBROUTINE PFDHT
	569	!
	570	!-----------------------------------------------------------------------
	571	!***********************************************************************
	572	!-----------------------------------------------------------------------
	573	SUBROUTINE PDTE( &
	574	#ifdef DM_PARALLEL
	575	& GRID,MYPE,MPI_COMM_COMP, &
	576	#endif
	577	& NTSD,DT,PT,ETA2,RES,HYDRO,HBM2 &
	578	& ,PD,PDSL,PDSLO &
	579	& ,PETDT,DIV,PSDT &
	580	& ,IHE,IHW,IVE,IVW &
	581	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	582	& ,IMS,IME,JMS,JME,KMS,KME &
	583	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	584	!***********************************************************************
	585	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
	586	! . . .
	587	! SUBPROGRAM: PDTE SURFACE PRESSURE TENDENCY CALC
	588	! PRGRMMR: JANJIC ORG: W/NP2 DATE: 96-07-??
	589	!
	590	! ABSTRACT:
	591	! PDTE VERTICALLY INTEGRATES THE MASS FLUX DIVERGENCE TO
	592	! OBTAIN THE SURFACE PRESSURE TENDENCY AND VERTICAL VELOCITY ON
	593	! THE LAYER INTERFACES. THEN IT UPDATES THE HYDROSTATIC SURFACE
	594	! PRESSURE AND THE NONHYDROSTATIC PRESSURE.
	595	!
	596	! PROGRAM HISTORY LOG:
	597	! 87-06-?? JANJIC - ORIGINATOR
	598	! 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
	599	! 96-05-?? JANJIC - ADDED NONHYDROSTATIC EFFECTS & MERGED THE
	600	! PREVIOUS SUBROUTINES PDTE & PDNEW
	601	! 00-01-03 BLACK - DISTRIBUTED MEMORY AND THREADS
	602	! 01-02-23 BLACK - CONVERTED TO WRF FORMAT
	603	! 01-04-11 BLACK - REWRITTEN FOR WRF CODING STANDARDS
	604	! 04-02-17 JANJIC - MOVED UPDATE OF T DUE TO OMEGA-ALPHA TERM
	605	! AND UPDATE OF PINT TO NEW ROUTINE VTOA
	606	! 04-11-23 BLACK - THREADED
	607	! 05-12-09 BLACK - CONVERTED FROM IKJ TO IJK
	608	!
	609	! USAGE: CALL PDTE FROM SUBROUTINE SOLVE_RUNSTREAM
	610	! INPUT ARGUMENT LIST:
	611	!
	612	! OUTPUT ARGUMENT LIST:
	613	!
	614	! OUTPUT FILES:
	615	! NONE
	616	!
	617	! SUBPROGRAMS CALLED:
	618	!
	619	! UNIQUE: NONE
	620	!
	621	! LIBRARY: NONE
	622	!
	623	! ATTRIBUTES:
	624	! LANGUAGE: FORTRAN 90
	625	! MACHINE : IBM SP
	626	!$$$
	627	!***********************************************************************
	628	#ifdef DM_PARALLEL
	629	USE module_domain
	630	USE module_dm
	631	#endif
	632	!-----------------------------------------------------------------------
	633	IMPLICIT NONE
	634	!-----------------------------------------------------------------------
	635	#ifdef DM_PARALLEL
	636	! INCLUDE "mpif.h"
	637	TYPE (DOMAIN) :: GRID
	638	INTEGER,INTENT(IN) :: MYPE,MPI_COMM_COMP
	639	#endif
	640	!-----------------------------------------------------------------------
	641	LOGICAL,INTENT(IN) :: HYDRO
	642	!
	643	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
	644	,IMS,IME,JMS,JME,KMS,KME &
	645	,ITS,ITE,JTS,JTE,KTS,KTE
	646	!
	647	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
	648	!
	649	INTEGER,INTENT(IN) :: NTSD
	650	!
	651	REAL,INTENT(IN) :: DT,PT
	652	!
	653	REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA2
	654	!
	655	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: RES,HBM2
	656	!
	657	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DIV
	658	!
	659	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: PD,PDSL
	660	!
	661	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: PETDT
	662	!
	663	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: PDSLO,PSDT
	664	!
	665	!-----------------------------------------------------------------------
	666	!*** LOCAL VARIABLES
	667	!-----------------------------------------------------------------------
	668	!
	669	INTEGER :: I,IHH,IHL,IX,J,JHH,JHL,JX,K,KS,NSMUD
	670	INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB
	671	#ifdef DM_PARALLEL
	672	INTEGER :: IPS,IPE,JPS,JPE,KPS,KPE
	673	#endif
	674	!#ifdef DEREF_KLUDGE
	675	!! SEE http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
	676	! INTEGER :: SM31,EM31,SM32,EM32,SM33,EM33
	677	! INTEGER :: SM31X,EM31X,SM32X,EM32X,SM33X,EM33X
	678	! INTEGER :: SM31Y,EM31Y,SM32Y,EM32Y,SM33Y,EM33Y
	679	!#endif
	680	!
	681	REAL :: PETDTL
	682	!
	683	REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: HBMS,PNE,PRET,PSE
	684	!
	685	!-----------------------------------------------------------------------
	686	!***********************************************************************
	687	!-----------------------------------------------------------------------
	688	!#include "deref_kludge.h"
	689	!
	690	DO J=JMS,JME
	691	DO I=IMS,IME
	692	PDSLO(I,J)=0.
	693	ENDDO
	694	ENDDO
	695	!
	696	MY_IS_GLB=ITS
	697	MY_IE_GLB=ITE
	698	MY_JS_GLB=JTS
	699	MY_JE_GLB=JTE
	700	!
	701	!-----------------------------------------------------------------------
	702	!*** VERTICALLY INTEGRATE THE HORIZONTAL DIVERGENCE
	703	!-----------------------------------------------------------------------
	704	!
	705	!$omp parallel do &
	706	!$omp& private(i,j,k)
	707	DO K=KTE-1,KTS,-1
	708	DO J=MYJS_P2,MYJE_P2
	709	DO I=MYIS_P2,MYIE_P2
	710	DIV(I,J,K)=DIV(I,J,K+1)+DIV(I,J,K)
	711	ENDDO
	712	ENDDO
	713	ENDDO
	714	!
	715	!-----------------------------------------------------------------------
	716	!*** COMPUTATION OF PRESSURE TENDENCY
	717	!-----------------------------------------------------------------------
	718	!
	719	!$omp parallel do &
	720	!$omp& private(i,j)
	721	DO J=MYJS_P2,MYJE_P2
	722	DO I=MYIS_P2,MYIE_P2
	723	PSDT(I,J)=-DIV(I,J,KTS)
	724	PDSLO(I,J)=PDSL(I,J)
	725	ENDDO
	726	ENDDO
	727	!-----------------------------------------------------------------------
	728	DO J=JMS,JME
	729	DO I=IMS,IME
	730	PDSL(I,J)=0.
	731	ENDDO
	732	ENDDO
	733	!
	734	!$omp parallel do &
	735	!$omp& private(i,j)
	736	DO J=MYJS_P2,MYJE_P2
	737	DO I=MYIS_P2,MYIE_P2
	738	PD(I,J)=PSDT(I,J)*DT+PD(I,J)
	739	PRET(I,J)=PSDT(I,J)*RES(I,J)
	740	PDSL(I,J)=PD(I,J)*RES(I,J)
	741	ENDDO
	742	ENDDO
	743	!
	744	!-----------------------------------------------------------------------
	745	!*** COMPUTATION OF PETDT
	746	!-----------------------------------------------------------------------
	747	!
	748	!$omp parallel do &
	749	!$omp& private(i,j,k)
	750	DO K=KTE-1,KTS,-1
	751	DO J=MYJS_P2,MYJE_P2
	752	DO I=MYIS_P2,MYIE_P2
	753	PETDT(I,J,K)=-(PRET(I,J)*ETA2(K+1)+DIV(I,J,K+1)) &
	754	& *HBM2(I,J)
	755	ENDDO
	756	ENDDO
	757	ENDDO
	758	!
	759	!-----------------------------------------------------------------------
	760	!*** SMOOTHING VERTICAL VELOCITY ALONG BOUNDARIES
	761	!-----------------------------------------------------------------------
	762	!
	763	nonhydrostatic_smoothing: IF(.NOT.HYDRO.AND.KSMUD.GT.0)THEN
	764	!
	765	NSMUD=KSMUD
	766	!
	767	DO J=MYJS,MYJE
	768	DO I=MYIS,MYIE
	769	HBMS(I,J)=HBM2(I,J)
	770	ENDDO
	771	ENDDO
	772	!
	773	JHL=LNSDT
	774	JHH=JDE-JHL+1
	775	!
	776	!$omp parallel do &
	777	!$omp& private(i,ihh,ihl,ix,j,jx)
	778	DO J=JHL,JHH
	779	IF(J.GE.MY_JS_GLB.AND.J.LE.MY_JE_GLB)THEN
	780	IHL=JHL/2+1
	781	IHH=IDE-IHL+MOD(J,2)
	782	!
	783	DO I=IHL,IHH
	784	IF(I.GE.MY_IS_GLB.AND.I.LE.MY_IE_GLB)THEN
	785	IX=I ! -MY_IS_GLB+1
	786	JX=J ! -MY_JS_GLB+1
	787	HBMS(IX,JX)=0.
	788	ENDIF
	789	ENDDO
	790	!
	791	ENDIF
	792	ENDDO
	793	!
	794	!-----------------------------------------------------------------------
	795	!***
	796	!*** SMOOTH THE VERTICAL VELOCITY
	797	!***
	798	!-----------------------------------------------------------------------
	799	!
	800	DO KS=1,NSMUD
	801	!
	802	!-----------------------------------------------------------------------
	803	!
	804	!*** PNE AT H(I,J) LIES BETWEEN (I,J) AND THE H POINT TO THE NE.
	805	!*** PSE AT H(I,J) LIES BETWEEN (I,J) AND THE H POINT TO THE SE.
	806	!
	807	!$omp parallel do &
	808	!$omp& private(i,j,k,petdtl,pne,pse)
	809	!
	810	DO K=KTS+1,KTE
	811	!
	812	DO J=MYJS_P1,MYJE1_P1
	813	DO I=MYIS_P1,MYIE1_P1
	814	PNE(I,J)=PETDT(I+IHE(J),J+1,K)-PETDT(I,J,K)
	815	ENDDO
	816	ENDDO
	817	!
	818	DO J=MYJS1_P1,MYJE_P1
	819	DO I=MYIS_P1,MYIE1_P1
	820	PSE(I,J)=PETDT(I+IHE(J),J-1,K)-PETDT(I,J,K)
	821	ENDDO
	822	ENDDO
	823	!
	824	DO J=MYJS2,MYJE2
	825	DO I=MYIS1,MYIE1
	826	PETDTL=(PNE(I,J)-PNE(I+IHW(J),J-1) &
	827	& +PSE(I,J)-PSE(I+IHW(J),J+1))*HBM2(I,J)
	828	PETDT(I,J,K)=PETDTLHBMS(I,J)0.125+PETDT(I,J,K)
	829	ENDDO
	830	ENDDO
	831	!
	832	ENDDO
	833	!
	834	#ifdef DM_PARALLEL
	835	! IPS=ITS;IPE=ITE;JPS=JTS;JPE=JTE;KPS=KTS;KPE=KTE
	836	# include <HALO_NMM_E.inc>
	837	#endif
	838	!-----------------------------------------------------------------------
	839	!
	840	ENDDO ! End of smoothing loop
	841	!
	842	!-----------------------------------------------------------------------
	843	!
	844	ENDIF nonhydrostatic_smoothing
	845	!
	846	!-----------------------------------------------------------------------
	847	!
	848	END SUBROUTINE PDTE
	849	!
	850	!-----------------------------------------------------------------------
	851	!***********************************************************************
	852	!-----------------------------------------------------------------------
	853	SUBROUTINE VTOA( &
	854	#ifdef DM_PARALLEL
	855	& GRID, &
	856	#endif
	857	& NTSD,DT,PT,ETA2 &
	858	& ,HBM2,EF4T &
	859	& ,T,DWDT,RTOP,OMGALF &
	860	& ,PINT,DIV,PSDT,RES &
	861	& ,IHE,IHW,IVE,IVW &
	862	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	863	& ,IMS,IME,JMS,JME,KMS,KME &
	864	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	865	!***********************************************************************
	866	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
	867	! . . .
	868	! SUBPROGRAM: VTOA OMEGA-ALPHA
	869	! PRGRMMR: JANJIC ORG: W/NP2 DATE: 04-02-17
	870	!
	871	! ABSTRACT:
	872	! VTOA UPDATES THE NONHYDROSTATIC PRESSURE AND ADDS THE
	873	! CONTRIBUTION OF THE OMEGA-ALPHA TERM OF THE THERMODYNAMIC
	874	! EQUATION. ALSO, THE OMEGA-ALPHA TERM IS COMPUTED FOR DIAGNOSTICS.
	875	!
	876	! PROGRAM HISTORY LOG:
	877	! 04-02-17 JANJIC - SEPARATED FROM ORIGINAL PDTEDT ROUTINE
	878	! 04-11-23 BLACK - THREADED
	879	!
	880
	881	! INPUT ARGUMENT LIST:
	882	!
	883	! OUTPUT ARGUMENT LIST:
	884	!
	885	! OUTPUT FILES:
	886	! NONE
	887	!
	888	! SUBPROGRAMS CALLED:
	889	!
	890	! UNIQUE: NONE
	891	!
	892	! LIBRARY: NONE
	893	!
	894	! ATTRIBUTES:
	895	! LANGUAGE: FORTRAN 90
	896	! MACHINE : IBM SP
	897	!$$$
	898	!***********************************************************************
	899	#ifdef DM_PARALLEL
	900	USE MODULE_DOMAIN
	901	USE MODULE_DM
	902	#endif
	903	!-----------------------------------------------------------------------
	904	IMPLICIT NONE
	905	!-----------------------------------------------------------------------
	906	#ifdef DM_PARALLEL
	907	! INCLUDE "mpif.h"
	908	TYPE (DOMAIN) :: GRID
	909	#endif
	910	!-----------------------------------------------------------------------
	911	!
	912	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
	913	,IMS,IME,JMS,JME,KMS,KME &
	914	,ITS,ITE,JTS,JTE,KTS,KTE
	915	!
	916	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
	917	!
	918	INTEGER,INTENT(IN) :: NTSD
	919	!
	920	REAL,INTENT(IN) :: DT,EF4T,PT
	921	!
	922	REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA2
	923	!
	924	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: HBM2,PSDT,RES
	925	!
	926	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: DIV,DWDT &
	927	& ,RTOP
	928	!
	929	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: OMGALF,T
	930	!
	931	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: PINT
	932	!
	933	!-----------------------------------------------------------------------
	934	!*** LOCAL VARIABLES
	935	!-----------------------------------------------------------------------
	936	!
	937	INTEGER :: I,J,K
	938	!
	939	REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: PRET,TPM
	940	!
	941	REAL :: DWDTP,RHS,TPMP
	942	!
	943	!-----------------------------------------------------------------------
	944	!***********************************************************************
	945	!-----------------------------------------------------------------------
	946	!*** PREPARATIONS
	947	!-----------------------------------------------------------------------
	948	!
	949	!$omp parallel do &
	950	!$omp& private(i,j)
	951	DO J=MYJS_P2,MYJE_P2
	952	DO I=MYIS_P2,MYIE_P2
	953	PINT(I,J,KTE+1)=PT
	954	TPM(I,J)=PT+PINT(I,J,KTE)
	955	PRET(I,J)=PSDT(I,J)*RES(I,J)
	956	ENDDO
	957	ENDDO
	958	!
	959	!-----------------------------------------------------------------------
	960	!*** KINETIC ENERGY GENERATION TERMS IN T EQUATION
	961	!-----------------------------------------------------------------------
	962	!
	963	!$omp parallel do &
	964	!$omp& private(dwdtp,i,j,rhs,tpmp)
	965	DO J=MYJS,MYJE
	966	DO I=MYIS,MYIE
	967	DWDTP=DWDT(I,J,KTE)
	968	TPMP=PINT(I,J,KTE)+PINT(I,J,KTE-1)
	969	!
	970	RHS=-DIV(I,J,KTE)RTOP(I,J,KTE)DWDTP*EF4T
	971	OMGALF(I,J,KTE)=OMGALF(I,J,KTE)+RHS
	972	T(I,J,KTE)=OMGALF(I,J,KTE)*HBM2(I,J)+T(I,J,KTE)
	973	PINT(I,J,KTE)=PRET(I,J)(ETA2(KTE+1)+ETA2(KTE))DWDTP*DT &
	974	& +TPM(I,J)-PINT(I,J,KTE+1)
	975	!
	976	TPM(I,J)=TPMP
	977	ENDDO
	978	ENDDO
	979	!-----------------------------------------------------------------------
	980	!$omp parallel do &
	981	!$omp& private(dwdtp,i,j,k,rhs,tpmp)
	982	DO K=KTE-1,KTS+1,-1
	983	DO J=MYJS,MYJE
	984	DO I=MYIS,MYIE
	985	DWDTP=DWDT(I,J,K)
	986	TPMP=PINT(I,J,K)+PINT(I,J,K-1)
	987	!
	988	RHS=-(DIV(I,J,K+1)+DIV(I,J,K))RTOP(I,J,K)DWDTP*EF4T
	989	OMGALF(I,J,K)=OMGALF(I,J,K)+RHS
	990	T(I,J,K)=OMGALF(I,J,K)*HBM2(I,J)+T(I,J,K)
	991	PINT(I,J,K)=PRET(I,J)(ETA2(K+1)+ETA2(K))DWDTP*DT &
	992	& +TPM(I,J)-PINT(I,J,K+1)
	993	!
	994	TPM(I,J)=TPMP
	995	ENDDO
	996	ENDDO
	997	ENDDO
	998	!-----------------------------------------------------------------------
	999	!$omp parallel do &
	1000	!$omp& private(dwdtp,i,j,rhs)
	1001	DO J=MYJS,MYJE
	1002	DO I=MYIS,MYIE
	1003	!
	1004	DWDTP=DWDT(I,J,KTS)
	1005	!
	1006	! if(i==77.and.j==53)then
	1007	! write(0,28361)t(i,j,kts),omgalf(i,j,kts),rtop(i,j,kts),dwdtp
	1008	! write(0,28362)div(i,j,kts),div(i,j,kts+1),ef4t
	1009	28361 format(' t=',z8,' omgalf=',z8,' rtop=',z8,' dwdtp=',z8)
	1010	28362 format(' div=',2(1x,z8),' ef4t=',z8)
	1011	! endif
	1012	RHS=-(DIV(I,J,KTS+1)+DIV(I,J,KTS))RTOP(I,J,KTS)DWDTP*EF4T
	1013	OMGALF(I,J,KTS)=OMGALF(I,J,KTS)+RHS
	1014	T(I,J,KTS)=OMGALF(I,J,KTS)*HBM2(I,J)+T(I,J,KTS)
	1015	PINT(I,J,KTS)=PRET(I,J)(ETA2(KTS+1)+ETA2(KTS))DWDTP*DT &
	1016	& +TPM(I,J)-PINT(I,J,KTS+1)
	1017	ENDDO
	1018	ENDDO
	1019	!-----------------------------------------------------------------------
	1020	!
	1021	END SUBROUTINE VTOA
	1022	!
	1023	!-----------------------------------------------------------------------
	1024	!***********************************************************************
	1025	SUBROUTINE DDAMP(NTSD,DT,DETA1,DETA2,PDSL,PDTOP,DIV,HBM2 &
	1026	& ,T,U,V,DDMPU,DDMPV &
	1027	& ,IHE,IHW,IVE,IVW &
	1028	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	1029	& ,IMS,IME,JMS,JME,KMS,KME &
	1030	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1031	!***********************************************************************
	1032	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
	1033	! . . .
	1034	! SUBPROGRAM: DDAMP DIVERGENCE DAMPING
	1035	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 94-03-08
	1036	!
	1037	! ABSTRACT:
	1038	! DDAMP MODIFIES THE WIND COMPONENTS SO AS TO REDUCE THE
	1039	! HORIZONTAL DIVERGENCE.
	1040	!
	1041	! PROGRAM HISTORY LOG:
	1042	! 87-08-?? JANJIC - ORIGINATOR
	1043	! 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
	1044	! 95-03-28 BLACK - ADDED EXTERNAL EDGE
	1045	! 98-10-30 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
	1046	! 01-03-12 BLACK - CONVERTED TO WRF STRUCTURE
	1047	! 04-11-18 BLACK - THREADED
	1048	! 05-12-09 BLACK - CONVERTED FROM IKJ TO IJK
	1049	!
	1050	! USAGE: CALL DDAMP FROM SUBROUTINE SOLVE_RUNSTREAM
	1051	!
	1052	! INPUT ARGUMENT LIST:
	1053	!
	1054	! OUTPUT ARGUMENT LIST:
	1055	!
	1056	! OUTPUT FILES:
	1057	! NONE
	1058	!
	1059	! SUBPROGRAMS CALLED:
	1060	!
	1061	! UNIQUE: NONE
	1062	!
	1063	! LIBRARY: NONE
	1064	!
	1065	! ATTRIBUTES:
	1066	! LANGUAGE: FORTRAN 90
	1067	! MACHINE : IBM SP
	1068	!$$$
	1069	!***********************************************************************
	1070	!-----------------------------------------------------------------------
	1071	IMPLICIT NONE
	1072	!-----------------------------------------------------------------------
	1073	!
	1074	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
	1075	& ,IMS,IME,JMS,JME,KMS,KME &
	1076	& ,ITS,ITE,JTS,JTE,KTS,KTE
	1077	!
	1078	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
	1079	!
	1080	INTEGER,INTENT(IN) :: NTSD
	1081	!
	1082	REAL,INTENT(IN) :: DT,PDTOP
	1083	!
	1084	REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: DETA1,DETA2
	1085	!
	1086	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DDMPU,DDMPV &
	1087	& ,HBM2,PDSL
	1088	!
	1089	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DIV,T &
	1090	& ,U,V
	1091	!
	1092	!-----------------------------------------------------------------------
	1093	!*** LOCAL VARIABLES
	1094	!-----------------------------------------------------------------------
	1095	!
	1096	INTEGER :: I,J,K
	1097	!
	1098	REAL :: FCIM,FCXM,RDPDX,RDPDY
	1099	!
	1100	REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: DIVE,DPDE,PDE &
	1101	& ,XDIVX,XDIVY
	1102	!
	1103	!-----------------------------------------------------------------------
	1104	!***********************************************************************
	1105	!-----------------------------------------------------------------------
	1106	!
	1107	!$omp parallel do &
	1108	!$omp& private(i,j)
	1109	DO J=JTS-5,JTE+5
	1110	DO I=ITS-5,ITE+5
	1111	PDE(I,J)=0.
	1112	DPDE(I,J)=0.
	1113	XDIVX(I,J)=0.
	1114	XDIVY(I,J)=0.
	1115	ENDDO
	1116	ENDDO
	1117	!
	1118	!-----------------------------------------------------------------------
	1119	!
	1120	FCXM=1.
	1121	!
	1122	DO J=MYJS_P2,MYJE_P2
	1123	DO I=MYIS_P2,MYIE_P2
	1124	PDE (I,J)=PDSL(I,J)+PDTOP
	1125	DIVE(I,J)=0.
	1126	ENDDO
	1127	ENDDO
	1128	!
	1129	DO K=KTS,KTE
	1130	!$omp parallel do
	1131	DO J=MYJS_P2,MYJE_P2
	1132	DO I=MYIS_P2,MYIE_P2
	1133	DIVE(I,J)=DIV(I,J,K)*HBM2(I,J)+DIVE(I,J)
	1134	ENDDO
	1135	ENDDO
	1136	ENDDO
	1137	!
	1138	!$omp parallel do &
	1139	!$omp& private(i,j,rdpdx,rdpdy)
	1140	DO J=MYJS2,MYJE2
	1141	DO I=MYIS1_P1,MYIE1_P1
	1142	RDPDX=DDMPU(I,J)*FCXM &
	1143	& /(PDE(I+IVW(J),J) +PDE(I+IVE(J),J))
	1144	RDPDY=DDMPV(I,J)*FCXM &
	1145	& /(PDE(I ,J-1)+PDE(I ,J+1))
	1146	!
	1147	XDIVX(I,J)=(DIVE(I+IVE(J),J )-DIVE(I+IVW(J),J ))*RDPDX
	1148	XDIVY(I,J)=(DIVE(I ,J+1)-DIVE(I ,J-1))*RDPDY
	1149	ENDDO
	1150	ENDDO
	1151	!
	1152	!-----------------------------------------------------------------------
	1153	!
	1154	FCIM=1.
	1155	!
	1156	!$omp parallel do &
	1157	!$omp& private(dpde,i,j,k,rdpdx,rdpdy)
	1158	!
	1159	DO K=KTS,KTE
	1160	!
	1161	!-----------------------------------------------------------------------
	1162	!
	1163	DO J=MYJS_P2,MYJE_P2
	1164	DO I=MYIS_P1,MYIE_P1
	1165	DPDE(I,J)=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
	1166	DIV(I,J,K)=DIV(I,J,K)*HBM2(I,J)
	1167	ENDDO
	1168	ENDDO
	1169	!
	1170	DO J=MYJS2,MYJE2
	1171	DO I=MYIS1_P1,MYIE1_P1
	1172	RDPDX=DDMPU(I,J)*FCIM &
	1173	& /(DPDE(I+IVW(J),J) +DPDE(I+IVE(J),J))
	1174	RDPDY=DDMPV(I,J)*FCIM &
	1175	& /(DPDE(I ,J-1)+DPDE(I ,J+1))
	1176	U(I,J,K)=((DIV(I+IVE(J),J,K )-DIV(I+IVW(J),J,K ))*RDPDX &
	1177	& +XDIVX(I,J))+U(I,J,K)
	1178	V(I,J,K)=((DIV(I ,J+1,K)-DIV(I ,J-1,K))*RDPDY &
	1179	& +XDIVY(I,J))+V(I,J,K)
	1180	ENDDO
	1181	ENDDO
	1182	!
	1183	!-----------------------------------------------------------------------
	1184	!
	1185	ENDDO
	1186	!
	1187	!-----------------------------------------------------------------------
	1188	!
	1189	END SUBROUTINE DDAMP
	1190	!
	1191	!-----------------------------------------------------------------------
	1192	!
	1193	END MODULE MODULE_IGWAVE_ADJUST
	1194	!
	1195	!-----------------------------------------------------------------------

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

Download in other formats:

Original Format