Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_IGWAVE_ADJUST.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: 41.6 KB

Line
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