Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_BNDRY_COND.F @ 3567

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

Line
1	!-----------------------------------------------------------------------
2	!
3	!NCEP_MESO:MODEL_LAYER: BOUNDARY CONDITION UPDATES
4	!
5	!-----------------------------------------------------------------------
6	!
7	#include "nmm_loop_basemacros.h"
8	#include "nmm_loop_macros.h"
9	!
10	!-----------------------------------------------------------------------
11	!
12	MODULE MODULE_BNDRY_COND
13	!
14	!-----------------------------------------------------------------------
15	USE MODULE_STATE_DESCRIPTION
16	USE MODULE_MODEL_CONSTANTS
17	!-----------------------------------------------------------------------
18	REAL :: D06666=0.06666666
19	!-----------------------------------------------------------------------
20	!
21	CONTAINS
22	!
23	!***********************************************************************
24	SUBROUTINE BOCOH(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH &
25	& ,LB,ETA1,ETA2,PDTOP,PT,RES &
26	& ,PD_BXS, PD_BXE, PD_BYS, PD_BYE &
27	& ,T_BXS, T_BXE, T_BYS, T_BYE &
28	& ,Q_BXS, Q_BXE, Q_BYS, Q_BYE &
29	& ,U_BXS, U_BXE, U_BYS, U_BYE &
30	& ,V_BXS, V_BXE, V_BYS, V_BYE &
31	& ,Q2_BXS, Q2_BXE, Q2_BYS, Q2_BYE &
32	& ,CWM_BXS, CWM_BXE, CWM_BYS, CWM_BYE &
33	& ,PD_BTXS, PD_BTXE, PD_BTYS, PD_BTYE &
34	& ,T_BTXS, T_BTXE, T_BTYS, T_BTYE &
35	& ,Q_BTXS, Q_BTXE, Q_BTYS, Q_BTYE &
36	& ,U_BTXS, U_BTXE, U_BTYS, U_BTYE &
37	& ,V_BTXS, V_BTXE, V_BTYS, V_BTYE &
38	& ,Q2_BTXS, Q2_BTXE, Q2_BTYS, Q2_BTYE &
39	& ,CWM_BTXS, CWM_BTXE, CWM_BTYS, CWM_BTYE &
40	& ,PD,T,Q,Q2,CWM,PINT &
41	& ,MOIST,N_MOIST,SCALAR,N_SCALAR &
42	#ifdef WRF_CHEM
43	& ,CHEM,NUMG,CONFIG_FLAGS &
44	#endif
45	& ,SPEC_BDY_WIDTH,Z &
46	& ,IHE,IHW,IVE,IVW &
47	& ,IDS,IDE,JDS,JDE,KDS,KDE &
48	& ,IMS,IME,JMS,JME,KMS,KME &
49	& ,ITS,ITE,JTS,JTE,KTS,KTE)
50	!***********************************************************************
51	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
52	! . . .
53	! SUBPROGRAM: BOCOH UPDATE MASS POINTS ON BOUNDARY
54	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 94-03-08
55	!
56	! ABSTRACT:
57	! TEMPERATURE, SPECIFIC HUMIDITY, AND SURFACE PRESSURE
58	! ARE UPDATED ON THE DOMAIN BOUNDARY BY APPLYING THE
59	! PRE-COMPUTED TENDENCIES AT EACH TIME STEP.
60	!
61	! PROGRAM HISTORY LOG:
62	! 87-??-?? MESINGER - ORIGINATOR
63	! 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D in HORIZONTAL
64	! 96-12-13 BLACK - FINAL MODIFICATION FOR NESTED RUNS
65	! 98-10-30 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
66	! 00-01-06 BLACK - MODIFIED FOR JANJIC NONHYDROSTATIC CODE
67	! 00-09-14 BLACK - MODIFIED FOR DIRECT ACCESS READ
68	! 01-03-12 BLACK - CONVERTED TO WRF STRUCTURE
69	! 02-08-29 MICHALAKES - CHANGED II=I-MY_IS_GLB+1 TO II=I
70	! ADDED CONDITIONAL COMPILATION AROUND MPI
71	! CONVERT INDEXING FROM LOCAL TO GLOBAL
72	! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
73	! 04-11-18 BLACK - THREADED
74	! 05-12-19 BLACK - CONVERTED FROM IKJ TO IJK
75	! 06-06-02 GOPAL - MODIFICATIONS FOR NESTING
76	! 07-11-14 PYLE - UPDATED FOR NEW WRF BOUNDARY FILE STRUCTURE
77	!
78	! USAGE: CALL BOCOH FROM SUBROUTINE SOLVE_NMM
79	! INPUT ARGUMENT LIST:
80	!
81	! NOTE THAT IDE AND JDE INSIDE ROUTINE SHOULD BE PASSED IN
82	! AS WHAT WRF CONSIDERS THE UNSTAGGERED GRID DIMENSIONS; THAT
83	! IS, 1 LESS THAN THE IDE AND JDE SET BY WRF FRAMEWORK, JM
84	!
85	! OUTPUT ARGUMENT LIST:
86	!
87	! OUTPUT FILES:
88	! NONE
89	!
90	! SUBPROGRAMS CALLED:
91	!
92	! UNIQUE: NONE
93	!
94	! LIBRARY: NONE
95	!
96	! ATTRIBUTES:
97	! LANGUAGE: FORTRAN 90
98	! MACHINE : IBM
99	!$$$
100	!***********************************************************************
101	!-----------------------------------------------------------------------
102	#ifdef WRF_CHEM
103	USE MODULE_INPUT_CHEM_DATA
104	#endif
105	!-----------------------------------------------------------------------
106	!
107	IMPLICIT NONE
108	!
109	!-----------------------------------------------------------------------
110	LOGICAL,INTENT(IN) :: NEST
111	!
112	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
113	& ,IMS,IME,JMS,JME,KMS,KME &
114	& ,ITS,ITE,JTS,JTE,KTS,KTE
115	INTEGER,INTENT(IN) :: SPEC_BDY_WIDTH
116	INTEGER,INTENT(IN) :: N_MOIST, N_SCALAR
117	#ifdef WRF_CHEM
118	INTEGER,INTENT(IN) :: NUMG
119	#endif
120	!
121	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
122	!
123	INTEGER,INTENT(IN) :: GRIDID
124	INTEGER,INTENT(IN) :: LB,NBC,NTSD
125	LOGICAL,INTENT(IN) :: LAST_TIME
126	INTEGER,INTENT(INOUT) :: NBOCO
127	!
128	REAL,INTENT(IN) :: DT0,PDTOP,PT,TSPH
129	!
130	REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA1,ETA2
131	!
132	REAL,DIMENSION(IMS:IME,1,SPEC_BDY_WIDTH) &
133	& ,INTENT(INOUT) :: PD_BYS, PD_BYE &
134	& ,PD_BTYS,PD_BTYE
135	!
136	REAL,DIMENSION(IMS:IME,KMS:KME,SPEC_BDY_WIDTH) &
137	& ,INTENT(INOUT) :: T_BYS, T_BYE &
138	& ,U_BYS, U_BYE &
139	& ,V_BYS, V_BYE &
140	& ,Q_BYS, Q_BYE &
141	& ,Q2_BYS, Q2_BYE &
142	& ,CWM_BYS, CWM_BYE &
143	& ,T_BTYS, T_BTYE &
144	& ,U_BTYS, U_BTYE &
145	& ,V_BTYS, V_BTYE &
146	& ,Q_BTYS, Q_BTYE &
147	& ,Q2_BTYS, Q2_BTYE &
148	& ,CWM_BTYS, CWM_BTYE
149
150	REAL,DIMENSION(JMS:JME,1,SPEC_BDY_WIDTH) &
151	& ,INTENT(INOUT) :: PD_BXS, PD_BXE &
152	& ,PD_BTXS,PD_BTXE
153
154	REAL,DIMENSION(JMS:JME,KMS:KME,SPEC_BDY_WIDTH) &
155	& ,INTENT(INOUT) :: T_BXS, T_BXE &
156	& ,U_BXS, U_BXE &
157	& ,V_BXS, V_BXE &
158	& ,Q_BXS, Q_BXE &
159	& ,Q2_BXS, Q2_BXE &
160	& ,CWM_BXS, CWM_BXE &
161	& ,T_BTXS, T_BTXE &
162	& ,U_BTXS, U_BTXE &
163	& ,V_BTXS, V_BTXE &
164	& ,Q_BTXS, Q_BTXE &
165	& ,Q2_BTXS, Q2_BTXE &
166	& ,CWM_BTXS, CWM_BTXE
167
168	!
169	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: RES
170	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: PD
171	!
172	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM &
173	& ,PINT,Q &
174	& ,Q2,T,Z
175	!
176	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,NUM_MOIST) &
177	& ,INTENT(INOUT) :: MOIST
178	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,NUM_SCALAR) &
179	& ,INTENT(INOUT) :: SCALAR
180	!
181	#ifdef WRF_CHEM
182	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,NUM_CHEM) &
183	& ,INTENT(INOUT) :: CHEM
184	TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
185	#endif
186	!
187	!-----------------------------------------------------------------------
188	!
189	!*** LOCAL VARIABLES
190	!
191	INTEGER :: I,IB,IBDY,II,IIM,IM,IRTN,ISIZ1,ISIZ2 &
192	& ,J,JB,JJ,JJM,JM,K,KK,N,NN,NREC,NUMGAS,NV,REC
193	INTEGER :: MY_IS_GLB,MY_JS_GLB,MY_IE_GLB,MY_JE_GLB
194	INTEGER :: I_M,ILPAD1,IRPAD1,JBPAD1,JTPAD1
195	!
196	REAL :: BCHR,CONVFAC,CWK,DT,PLYR,RRI
197	!
198	LOGICAL :: E_BDY,W_BDY,N_BDY,S_BDY
199	!-----------------------------------------------------------------------
200	!***********************************************************************
201	!-----------------------------------------------------------------------
202	!
203	#ifdef WRF_CHEM
204	!*** DETERMINE THE INDEX OF THE LAST GAS SPECIES
205	NUMGAS=P_HO2
206	NUMGAS=NUMG
207	! NUMGAS = GET_LAST_GAS(CONFIG_FLAGS%CHEM_OPT)
208	!
209	#endif
210	IM=IDE-IDS+1
211	JM=JDE-JDS+1
212	IIM=IM
213	JJM=JM
214	!
215	ISIZ1=2*LB
216	ISIZ2=2LB(KME-KMS)
217	!
218	W_BDY=(ITS==IDS)
219	E_BDY=(ITE==IDE)
220	S_BDY=(JTS==JDS)
221	N_BDY=(JTE==JDE)
222	!
223	ILPAD1=1
224	IF(W_BDY)ILPAD1=0
225	IRPAD1=1
226	IF(E_BDY)IRPAD1=0
227	JBPAD1=1
228	IF(S_BDY)JBPAD1=0
229	JTPAD1=1
230	IF(N_BDY)JTPAD1=0
231	!
232	MY_IS_GLB=ITS
233	MY_IE_GLB=ITE
234	MY_JS_GLB=JTS
235	MY_JE_GLB=JTE
236	!
237	DT=DT0
238	!
239	!-----------------------------------------------------------------------
240	!*** SOUTH AND NORTH BOUNDARIES
241	!-----------------------------------------------------------------------
242	!
243	!*** USE IBDY=1 FOR SOUTH; 2 FOR NORTH
244	!
245	DO IBDY=1,2
246	!
247	!*** MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
248	!
249	IF(S_BDY.AND.IBDY==1) THEN
250	JB=1 ! Which cell in from boundary
251	JJ=1 ! Which cell in the domain
252
253	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
254	PD_BYS(I,1,JB)=PD_BYS(I,1,JB)+PD_BTYS(I,1,JB)*DT
255	PD(I,JJ)=PD_BYS(I,1,JB)
256	ENDDO
257
258	!$omp parallel do &
259	!$omp& private(i,k)
260	DO K=KTS,KTE
261	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
262	T_BYS(I,K,JB)=T_BYS(I,K,JB)+T_BTYS(I,K,JB)*DT
263	Q_BYS(I,K,JB)=Q_BYS(I,K,JB)+Q_BTYS(I,K,JB)*DT
264	Q2_BYS(I,K,JB)=Q2_BYS(I,K,JB)+Q2_BTYS(I,K,JB)*DT
265	CWM_BYS(I,K,JB)=CWM_BYS(I,K,JB)+CWM_BTYS(I,K,JB)*DT
266	!
267	T(I,JJ,K)=T_BYS(I,K,JB)
268	Q(I,JJ,K)=Q_BYS(I,K,JB)
269	Q2(I,JJ,K)=Q2_BYS(I,K,JB)
270	CWM(I,JJ,K)=CWM_BYS(I,K,JB)
271	PINT(I,JJ,K)=ETA1(K)*PDTOP &
272	& +ETA2(K)PD(I,JJ)RES(I,JJ)+PT
273	ENDDO
274	ENDDO
275
276	ELSEIF(N_BDY.AND.IBDY==2) THEN
277	JB=1 ! Which cell in from boundary
278	JJ=JJM ! Which cell in the domain
279
280	!
281	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
282	PD_BYE(I,1,JB)=PD_BYE(I,1,JB)+PD_BTYE(I,1,JB)*DT
283	PD(I,JJ)=PD_BYE(I,1,JB)
284	ENDDO
285	!
286	!$omp parallel do &
287	!$omp& private(i,k)
288	DO K=KTS,KTE
289	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
290	T_BYE(I,K,JB)=T_BYE(I,K,JB)+T_BTYE(I,K,JB)*DT
291	Q_BYE(I,K,JB)=Q_BYE(I,K,JB)+Q_BTYE(I,K,JB)*DT
292	Q2_BYE(I,K,JB)=Q2_BYE(I,K,JB)+Q2_BTYE(I,K,JB)*DT
293	CWM_BYE(I,K,JB)=CWM_BYE(I,K,JB)+CWM_BTYE(I,K,JB)*DT
294	!
295	T(I,JJ,K)=T_BYE(I,K,JB)
296	Q(I,JJ,K)=Q_BYE(I,K,JB)
297	Q2(I,JJ,K)=Q2_BYE(I,K,JB)
298	CWM(I,JJ,K)=CWM_BYE(I,K,JB)
299	PINT(I,JJ,K)=ETA1(K)*PDTOP &
300	& +ETA2(K)PD(I,JJ)RES(I,JJ)+PT
301	ENDDO
302	ENDDO
303
304	! ENDIF ! for N/S boundaries
305
306	!
307	DO I_M=1,N_MOIST
308	IF(I_M==P_QV)THEN
309	!$omp parallel do &
310	!$omp& private(i,k)
311	DO K=KTS,KTE
312	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
313	MOIST(I,JJ,K,I_M)=Q(I,JJ,K)/(1.-Q(I,JJ,K))
314	ENDDO
315	ENDDO
316	ELSE
317	!$omp parallel do &
318	!$omp& private(i,k)
319	DO K=KTS,KTE
320	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
321	MOIST(I,JJ,K,I_M)=0.
322	ENDDO
323	ENDDO
324	ENDIF
325	ENDDO
326	DO I_M=2,N_SCALAR
327	!$omp parallel do &
328	!$omp& private(i,k)
329	DO K=KTS,KTE
330	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
331	SCALAR(I,JJ,K,I_M)=0.
332	ENDDO
333	ENDDO
334	ENDDO
335	#ifdef WRF_CHEM
336	!$omp parallel do &
337	!$omp& private(i,k,nv)
338	DO NV=2,NUMG
339	DO K=KTS,KTE
340	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
341	CALL BDY_CHEM_VALUE (CHEM(I,K,JJ,NV),Z(I,JJ,K),NV,NUMG)
342	ENDDO
343	ENDDO
344	ENDDO
345	!$omp parallel do &
346	!$omp& private(i,k,nv)
347	DO NV=NUMG+1,NUM_CHEM
348	DO K=KTS,KTE
349	KK=MIN(K+1,KTE)
350	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
351	PLYR=(PINT(I,JJ,K)+PINT(I,JJ,KK))*0.5
352	RRI=R_DT(I,JJ,K)(1.+.608*Q(I,JJ,K))/PLYR
353	CONVFAC=PLYR/RGASUNIV/T(I,JJ,K)
354	CALL BDY_CHEM_VALUE_SORGAM (CHEM(I,K,JJ,NV),Z(I,JJ,K),NV, &
355	CONFIG_FLAGS,RRI,CONVFAC,G)
356	ENDDO
357	ENDDO
358	ENDDO
359	#endif
360	ENDIF
361	ENDDO
362	!
363	!-----------------------------------------------------------------------
364	!*** WEST AND EAST BOUNDARIES
365	!-----------------------------------------------------------------------
366	!
367	!*** USE IBDY=1 FOR WEST; 2 FOR EAST.
368	!
369	DO IBDY=1,2
370	!
371	!*** MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
372	!
373	IF(W_BDY.AND.IBDY==1) THEN
374	IB=1 ! Which cell in from boundary
375	II=1 ! Which cell in the domain
376	!
377	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
378	IF(MOD(J,2)==1)THEN
379	PD_BXS(J,1,IB)=PD_BXS(J,1,IB)+PD_BTXS(J,1,IB)*DT
380	PD(II,J)=PD_BXS(J,1,IB)
381	ENDIF
382	ENDDO
383	!
384	!$omp parallel do &
385	!$omp& private(j,k)
386	DO K=KTS,KTE
387	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
388	!
389	IF(MOD(J,2)==1)THEN
390	T_BXS(J,K,IB)=T_BXS(J,K,IB)+T_BTXS(J,K,IB)*DT
391	Q_BXS(J,K,IB)=Q_BXS(J,K,IB)+Q_BTXS(J,K,IB)*DT
392	Q2_BXS(J,K,IB)=Q2_BXS(J,K,IB)+Q2_BTXS(J,K,IB)*DT
393	CWM_BXS(J,K,IB)=CWM_BXS(J,K,IB)+CWM_BTXS(J,K,IB)*DT
394	!
395	T(II,J,K)=T_BXS(J,K,IB)
396	Q(II,J,K)=Q_BXS(J,K,IB)
397	Q2(II,J,K)=Q2_BXS(J,K,IB)
398	CWM(II,J,K)=CWM_BXS(J,K,IB)
399	PINT(II,J,K)=ETA1(K)*PDTOP &
400	& +ETA2(K)PD(II,J)RES(II,J)+PT
401	ENDIF
402	!
403	ENDDO
404	ENDDO
405
406	ELSEIF(E_BDY.AND.IBDY==2) THEN
407	IB=1 ! Which cell in from boundary
408	II=IIM ! Which cell in the domain
409
410	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
411	IF(MOD(J,2)==1)THEN
412	PD_BXE(J,1,IB)=PD_BXE(J,1,IB)+PD_BTXE(J,1,IB)*DT
413	PD(II,J)=PD_BXE(J,1,IB)
414	ENDIF
415	ENDDO
416	!
417	!$omp parallel do &
418	!$omp& private(j,k)
419	DO K=KTS,KTE
420	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
421	!
422	IF(MOD(J,2)==1)THEN
423	T_BXE(J,K,IB)=T_BXE(J,K,IB)+T_BTXE(J,K,IB)*DT
424	Q_BXE(J,K,IB)=Q_BXE(J,K,IB)+Q_BTXE(J,K,IB)*DT
425	Q2_BXE(J,K,IB)=Q2_BXE(J,K,IB)+Q2_BTXE(J,K,IB)*DT
426	CWM_BXE(J,K,IB)=CWM_BXE(J,K,IB)+CWM_BTXE(J,K,IB)*DT
427	!
428	T(II,J,K)=T_BXE(J,K,IB)
429	Q(II,J,K)=Q_BXE(J,K,IB)
430	Q2(II,J,K)=Q2_BXE(J,K,IB)
431	CWM(II,J,K)=CWM_BXE(J,K,IB)
432	PINT(II,J,K)=ETA1(K)*PDTOP &
433	& +ETA2(K)PD(II,J)RES(II,J)+PT
434	ENDIF
435	!
436	ENDDO
437	ENDDO
438	!
439	! ENDIF ! for W/E boundaries
440	!
441	DO I_M=1,N_MOIST
442	IF(I_M==P_QV)THEN
443	!$omp parallel do &
444	!$omp& private(j,k)
445	DO K=KTS,KTE
446	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
447	IF(MOD(J,2)==1)THEN
448	MOIST(II,J,K,I_M)=Q(II,J,K)/(1.-Q(II,J,K))
449	ENDIF
450	ENDDO
451	ENDDO
452	!
453	ELSE
454	!$omp parallel do &
455	!$omp& private(j,k)
456	DO K=KTS,KTE
457	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
458	IF(MOD(J,2)==1)THEN
459	MOIST(II,J,K,I_M)=0.
460	ENDIF
461	ENDDO
462	ENDDO
463	!
464	ENDIF
465	ENDDO
466	!
467	DO I_M=2,N_SCALAR
468	!$omp parallel do &
469	!$omp& private(j,k)
470	DO K=KTS,KTE
471	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
472	IF(MOD(J,2)==1)THEN
473	SCALAR(II,J,K,I_M)=0.
474	ENDIF
475	ENDDO
476	ENDDO
477	ENDDO
478	!
479	#ifdef WRF_CHEM
480	!$omp parallel do &
481	!$omp& private(nv,j,k)
482	DO K=KTS,KTE
483	KK=MIN(K+1,KTE)
484	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
485	IF(MOD(J,2)==1)THEN
486	DO NV=2,NUMG
487	CALL BDY_CHEM_VALUE (CHEM(II,K,J,NV),Z(II,J,K),NV,NUMG)
488	ENDDO
489	!$omp parallel do &
490	!$omp& private(nv)
491	DO NV=NUMG+1,NUM_CHEM
492	PLYR=(PINT(II,J,K)+PINT(II,J,KK))*0.5
493	RRI=R_DT(II,J,K)(1.+P608*Q(II,J,K))/PLYR
494	CONVFAC=PLYR/RGASUNIV/T(II,J,K)
495	CALL BDY_CHEM_VALUE_SORGAM (CHEM(II,K,J,NV),Z(II,J,K),NV, &
496	& CONFIG_FLAGS,RRI,CONVFAC,G)
497	ENDDO
498	ENDIF
499	ENDDO
500	ENDDO
501
502	#endif
503	ENDIF
504	ENDDO
505	!
506	!-----------------------------------------------------------------------
507	!*** SPACE INTERPOLATION OF PD THEN REMAINING MASS VARIABLES
508	!*** AT INNER BOUNDARY
509	!-----------------------------------------------------------------------
510	!
511	!*** ONE ROW NORTH OF SOUTHERN BOUNDARY
512	!
513	IF(S_BDY)THEN
514	DO I=MYIS,MYIE1
515	PD(I,2)=0.25*(PD(I,1)+PD(I+1,1)+PD(I,3)+PD(I+1,3))
516	ENDDO
517	ENDIF
518	!
519	!*** ONE ROW SOUTH OF NORTHERN BOUNDARY
520	!
521	IF(N_BDY)THEN
522	DO I=MYIS,MYIE1
523	CWK=PD(I,JJM-1)
524	PD(I,JJM-1)=0.25*(PD(I,JJM-2)+PD(I+1,JJM-2) &
525	& +PD(I,JJM)+PD(I+1,JJM))
526	!
527	!*** NESTING TEST
528	!
529	IF(I<=IDE-1.AND.ABS(CWK-PD(I,JJM-1))>=300.)THEN
530	WRITE(0,*)'PSEUDO HYDROSTATIC IMBALANCE AT THE NORTHERN BOUNDARY AT',I,JJM-1,'GRID #',GRIDID
531	WRITE(0,*)' ',CWK/100.
532	WRITE(0,*)PD(I,JJM)/100.,' ',PD(I+1,JJM)/100.
533	WRITE(0,*)' ',PD(I,JJM-1)/100.
534	WRITE(0,*)PD(I,JJM-2)/100.,' ',PD(I+1,JJM-2)/100.
535	WRITE(0,*)
536	ENDIF
537
538	ENDDO
539	ENDIF
540	!
541	!*** ONE ROW EAST OF WESTERN BOUNDARY
542	!
543	IF(W_BDY)THEN
544	DO J=4,JM-3,2
545	!
546	IF(W_BDY.AND.J>=MY_JS_GLB-JBPAD1 &
547	& .AND.J<=MY_JE_GLB+JTPAD1)THEN
548	CWK=PD(1,J)
549	JJ=J
550	PD(1,JJ)=0.25*(PD(1,JJ-1)+PD(2,JJ-1)+PD(1,JJ+1)+PD(2,JJ+1))
551	!
552	!*** NESTING TEST
553	!
554	IF(ABS(CWK-PD(1,JJ))>300.)THEN
555	WRITE(0,*)'PSEUDO HYDROSTATIC IMBALANCE AT THE WESTERN BOUNDARY AT',J,1,'GRID #',GRIDID
556	WRITE(0,*)' ',CWK/100.
557	WRITE(0,*)PD(1,JJ+1)/100.,' ',PD(2,JJ+1)/100.
558	WRITE(0,*)' ',PD(1,JJ)/100.
559	WRITE(0,*)PD(1,JJ-1)/100,' ',PD(2,JJ-1)/100.
560	WRITE(0,*)
561	ENDIF
562
563	ENDIF
564	!
565	ENDDO
566	ENDIF
567	!
568	!*** ONE ROW WEST OF EASTERN BOUNDARY
569	!
570	IF(E_BDY)THEN
571	DO J=4,JM-3,2
572	!
573	IF(E_BDY.AND.J>=MY_JS_GLB-JBPAD1 &
574	& .AND.J<=MY_JE_GLB+JTPAD1)THEN
575	JJ=J
576	PD(IIM-1,JJ)=0.25*(PD(IIM-1,JJ-1)+PD(IIM,JJ-1) &
577	& +PD(IIM-1,JJ+1)+PD(IIM,JJ+1))
578	ENDIF
579	!
580	ENDDO
581	ENDIF
582	!
583	!-----------------------------------------------------------------------
584	!
585	!$omp parallel do &
586	!$omp& private(i,j,jj,k)
587	DO 200 K=KTS,KTE
588	!
589	!-----------------------------------------------------------------------
590	!
591	!*** ONE ROW NORTH OF SOUTHERN BOUNDARY
592	!
593	IF(S_BDY)THEN
594	DO I=MYIS,MYIE1
595	T(I,2,K)=(T(I,1,K)+T(I+1,1,K)+T(I,3,K)+T(I+1,3,K))*0.25
596	Q(I,2,K)=(Q(I,1,K)+Q(I+1,1,K)+Q(I,3,K)+Q(I+1,3,K))*0.25
597	Q2(I,2,K)=(Q2(I,1,K)+Q2(I+1,1,K)+Q2(I,3,K)+Q2(I+1,3,K))*0.25
598	CWM(I,2,K)=(CWM(I,1,K)+CWM(I+1,1,K)+CWM(I,3,K)+CWM(I+1,3,K)) &
599	& *0.25
600	PINT(I,2,K)=ETA1(K)PDTOP+ETA2(K)PD(I,2)*RES(I,2)+PT
601	ENDDO
602	!
603	DO I_M=1,N_MOIST
604	IF(I_M==P_QV)THEN
605	DO I=MYIS,MYIE1
606	MOIST(I,2,K,I_M)=Q(I,2,K)/(1.-Q(I,2,K))
607	ENDDO
608	ELSE
609	DO I=MYIS,MYIE1
610	MOIST(I,2,K,I_M)=(MOIST(I,1,K,I_M) &
611	& +MOIST(I+1,1,K,I_M) &
612	& +MOIST(I,3,K,I_M) &
613	& +MOIST(I+1,3,K,I_M))*0.25
614	ENDDO
615	ENDIF
616	ENDDO
617	!
618	DO I_M=2,N_SCALAR
619	DO I=MYIS,MYIE1
620	SCALAR(I,2,K,I_M)=(SCALAR(I,1,K,I_M) &
621	& +SCALAR(I+1,1,K,I_M) &
622	& +SCALAR(I,3,K,I_M) &
623	& +SCALAR(I+1,3,K,I_M))*0.25
624	ENDDO
625	ENDDO
626	!
627	ENDIF
628	!
629	!*** ONE ROW SOUTH OF NORTHERN BOUNDARY
630	!
631	IF(N_BDY)THEN
632	DO I=MYIS,MYIE1
633	T(I,JJM-1,K)=(T(I,JJM-2,K)+T(I+1,JJM-2,K) &
634	& +T(I,JJM,K)+T(I+1,JJM,K)) &
635	& *0.25
636	Q(I,JJM-1,K)=(Q(I,JJM-2,K)+Q(I+1,JJM-2,K) &
637	& +Q(I,JJM,K)+Q(I+1,JJM,K)) &
638	& *0.25
639	Q2(I,JJM-1,K)=(Q2(I,JJM-2,K)+Q2(I+1,JJM-2,K) &
640	& +Q2(I,JJM,K)+Q2(I+1,JJM,K)) &
641	& *0.25
642	CWM(I,JJM-1,K)=(CWM(I,JJM-2,K)+CWM(I+1,JJM-2,K) &
643	& +CWM(I,JJM,K)+CWM(I+1,JJM,K)) &
644	& *0.25
645	PINT(I,JJM-1,K)=ETA1(K)*PDTOP &
646	& +ETA2(K)PD(I,JJM-1)RES(I,JJM-1)+PT
647	ENDDO
648	!
649	DO I_M=1,N_MOIST
650	IF(I_M==P_QV)THEN
651	DO I=MYIS,MYIE1
652	MOIST(I,JJM-1,K,I_M)=Q(I,JJM-1,K)/(1.-Q(I,JJM-1,K))
653	ENDDO
654	ELSE
655	DO I=MYIS,MYIE1
656	MOIST(I,JJM-1,K,I_M)=(MOIST(I,JJM-2,K,I_M) &
657	& +MOIST(I+1,JJM-2,K,I_M) &
658	& +MOIST(I,JJM,K,I_M) &
659	& +MOIST(I+1,JJM,K,I_M))*0.25
660	ENDDO
661
662	ENDIF
663	ENDDO
664	!
665	DO I_M=2,N_SCALAR
666	DO I=MYIS,MYIE1
667	SCALAR(I,JJM-1,K,I_M)=(SCALAR(I,JJM-2,K,I_M) &
668	& +SCALAR(I+1,JJM-2,K,I_M) &
669	& +SCALAR(I,JJM,K,I_M) &
670	& +SCALAR(I+1,JJM,K,I_M))*0.25
671	ENDDO
672	ENDDO
673	!
674	ENDIF
675	!
676	!*** ONE ROW EAST OF WESTERN BOUNDARY
677	!
678	IF(W_BDY)THEN
679	DO J=4,JM-3,2
680	!
681	IF(W_BDY.AND.J>=MY_JS_GLB-JBPAD1 &
682	& .AND.J<=MY_JE_GLB+JTPAD1)THEN
683	JJ=J
684	T(1,JJ,K)=(T(1,JJ-1,K)+T(2,JJ-1,K) &
685	& +T(1,JJ+1,K)+T(2,JJ+1,K)) &
686	& *0.25
687	Q(1,JJ,K)=(Q(1,JJ-1,K)+Q(2,JJ-1,K) &
688	& +Q(1,JJ+1,K)+Q(2,JJ+1,K)) &
689	& *0.25
690	Q2(1,JJ,K)=(Q2(1,JJ-1,K)+Q2(2,JJ-1,K) &
691	& +Q2(1,JJ+1,K)+Q2(2,JJ+1,K)) &
692	& *0.25
693	CWM(1,JJ,K)=(CWM(1,JJ-1,K)+CWM(2,JJ-1,K) &
694	& +CWM(1,JJ+1,K)+CWM(2,JJ+1,K)) &
695	& *0.25
696	PINT(1,JJ,K)=ETA1(K)*PDTOP &
697	& +ETA2(K)PD(1,JJ)RES(1,JJ)+PT
698	!
699	DO I_M=1,N_MOIST
700	IF(I_M==P_QV)THEN
701	MOIST(1,JJ,K,I_M)=Q(1,JJ,K)/(1.-Q(1,JJ,K))
702	ELSE
703	MOIST(1,JJ,K,I_M)=(MOIST(1,JJ-1,K,I_M) &
704	& +MOIST(2,JJ-1,K,I_M) &
705	& +MOIST(1,JJ+1,K,I_M) &
706	& +MOIST(2,JJ+1,K,I_M))*0.25
707	ENDIF
708	ENDDO
709	!
710	DO I_M=2,N_SCALAR
711	SCALAR(1,JJ,K,I_M)=(SCALAR(1,JJ-1,K,I_M) &
712	& +SCALAR(2,JJ-1,K,I_M) &
713	& +SCALAR(1,JJ+1,K,I_M) &
714	& +SCALAR(2,JJ+1,K,I_M))*0.25
715	ENDDO
716	!
717	ENDIF
718	!
719	ENDDO
720	!
721	ENDIF
722	!
723	!*** ONE ROW WEST OF EASTERN BOUNDARY
724	!
725	IF(E_BDY)THEN
726	DO J=4,JM-3,2
727	!
728	IF(E_BDY.AND.J>=MY_JS_GLB-JBPAD1 &
729	& .AND.J<=MY_JE_GLB+JTPAD1)THEN
730	JJ=J
731	T(IIM-1,JJ,K)=(T(IIM-1,JJ-1,K)+T(IIM,JJ-1,K) &
732	& +T(IIM-1,JJ+1,K)+T(IIM,JJ+1,K)) &
733	& *0.25
734	Q(IIM-1,JJ,K)=(Q(IIM-1,JJ-1,K)+Q(IIM,JJ-1,K) &
735	& +Q(IIM-1,JJ+1,K)+Q(IIM,JJ+1,K)) &
736	& *0.25
737	Q2(IIM-1,JJ,K)=(Q2(IIM-1,JJ-1,K)+Q2(IIM,JJ-1,K) &
738	& +Q2(IIM-1,JJ+1,K)+Q2(IIM,JJ+1,K)) &
739	& *0.25
740	CWM(IIM-1,JJ,K)=(CWM(IIM-1,JJ-1,K)+CWM(IIM,JJ-1,K) &
741	& +CWM(IIM-1,JJ+1,K)+CWM(IIM,JJ+1,K)) &
742	& *0.25
743	PINT(IIM-1,JJ,K)=ETA1(K)*PDTOP &
744	& +ETA2(K)PD(IIM-1,JJ)RES(IIM-1,JJ)+PT
745	!
746	DO I_M=1,N_MOIST
747	IF(I_M==P_QV)THEN
748	MOIST(IIM-1,JJ,K,I_M)=Q(IIM-1,JJ,K)/(1.-Q(IIM-1,JJ,K))
749	ELSE
750	MOIST(IIM-1,JJ,K,I_M)=(MOIST(IIM-1,JJ-1,K,I_M) &
751	& +MOIST(IIM,JJ-1,K,I_M) &
752	& +MOIST(IIM-1,JJ+1,K,I_M) &
753	& +MOIST(IIM,JJ+1,K,I_M))*0.25
754	ENDIF
755	ENDDO
756	!
757	DO I_M=2,N_SCALAR
758	SCALAR(IIM-1,JJ,K,I_M)=(SCALAR(IIM-1,JJ-1,K,I_M) &
759	& +SCALAR(IIM,JJ-1,K,I_M) &
760	& +SCALAR(IIM-1,JJ+1,K,I_M) &
761	& +SCALAR(IIM,JJ+1,K,I_M))*0.25
762	ENDDO
763	!
764	ENDIF
765	!
766	ENDDO
767	ENDIF
768	!-----------------------------------------------------------------------
769	!
770	200 CONTINUE
771	!
772	!-----------------------------------------------------------------------
773	END SUBROUTINE BOCOH
774	!-----------------------------------------------------------------------
775	!***********************************************************************
776	!-----------------------------------------------------------------------
777	SUBROUTINE BOCOV(GRIDID,NTSD,DT,LB &
778	& ,U_BXS,U_BXE,U_BYS,U_BYE &
779	& ,V_BXS,V_BXE,V_BYS,V_BYE &
780	& ,U_BTXS,U_BTXE,U_BTYS,U_BTYE &
781	& ,V_BTXS,V_BTXE,V_BTYS,V_BTYE &
782	& ,U,V &
783	& ,SPEC_BDY_WIDTH &
784	& ,IHE,IHW,IVE,IVW &
785	& ,IDS,IDE,JDS,JDE,KDS,KDE &
786	& ,IMS,IME,JMS,JME,KMS,KME &
787	& ,ITS,ITE,JTS,JTE,KTS,KTE)
788	!***********************************************************************
789	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
790	! . . .
791	! SUBPROGRAM: BOCOV UPDATE WIND POINTS ON BOUNDARY
792	! PRGRMMR: JANJIC ORG: W/NP22 DATE: 94-03-08
793	!
794	! ABSTRACT:
795	! U AND V COMPONENTS OF THE WIND ARE UPDATED ON THE
796	! DOMAIN BOUNDARY BY APPLYING THE PRE-COMPUTED
797	! TENDENCIES AT EACH TIME STEP. AN EXTRAPOLATION FROM
798	! INSIDE THE DOMAIN IS USED FOR THE COMPONENT TANGENTIAL
799	! TO THE BOUNDARY IF THE NORMAL COMPONENT IS OUTWARD.
800	!
801	! PROGRAM HISTORY LOG:
802	! 87-??-?? MESINGER - ORIGINATOR
803	! 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
804	! 98-10-30 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
805	! 01-03-13 BLACK - CONVERTED TO WRF STRUCTURE
806	! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
807	! 04-11-23 BLACK - THREADED
808	! 05-12-19 BLACK - CONVERTED FROM IKJ TO IJK
809	! 06-06-02 GOPAL - MODIFICATIONS FOR NESTING
810	!
811	! USAGE: CALL BOCOH FROM SUBROUTINE SOLVE_NMM
812	! INPUT ARGUMENT LIST:
813	!
814	! NOTE THAT IDE AND JDE INSIDE ROUTINE SHOULD BE PASSED IN
815	! AS WHAT WRF CONSIDERS THE UNSTAGGERED GRID DIMENSIONS; THAT
816	! IS, 1 LESS THAN THE IDE AND JDE SET BY WRF FRAMEWORK, JM
817	!
818	! OUTPUT ARGUMENT LIST:
819	!
820	! OUTPUT FILES:
821	! NONE
822	!
823	! SUBPROGRAMS CALLED:
824	!
825	! UNIQUE: NONE
826	!
827	! LIBRARY: NONE
828	!
829	! ATTRIBUTES:
830	! LANGUAGE: FORTRAN 90
831	! MACHINE : IBM
832	!$$$
833	!***********************************************************************
834	!-----------------------------------------------------------------------
835	!
836	IMPLICIT NONE
837	!
838	!-----------------------------------------------------------------------
839	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
840	& ,IMS,IME,JMS,JME,KMS,KME &
841	& ,ITS,ITE,JTS,JTE,KTS,KTE
842	INTEGER,INTENT(IN) :: SPEC_BDY_WIDTH
843	!
844	INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
845	!
846	INTEGER,INTENT(IN) :: GRIDID
847	INTEGER,INTENT(IN) :: LB,NTSD
848	!
849	REAL,INTENT(IN) :: DT
850	!
851	REAL,DIMENSION(IMS:IME,KMS:KME,SPEC_BDY_WIDTH),INTENT(INOUT) :: &
852	& U_BYS,U_BYE,V_BYS,V_BYE &
853	& ,U_BTYS,U_BTYE &
854	& ,V_BTYS,V_BTYE
855
856	REAL,DIMENSION(JMS:JME,KMS:KME,SPEC_BDY_WIDTH),INTENT(INOUT) :: &
857	& U_BXS,U_BXE,V_BXS,V_BXE &
858	& ,U_BTXS,U_BTXE &
859	& ,V_BTXS,V_BTXE
860	!
861	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: U,V
862	!-----------------------------------------------------------------------
863	!
864	!*** LOCAL VARIABLES
865	!
866	INTEGER :: I,II,IIM,IM,J,JJ,JJM,JM,K,N
867	INTEGER :: MY_IS_GLB, MY_JS_GLB,MY_IE_GLB,MY_JE_GLB
868	INTEGER :: IBDY,JB,IB
869	INTEGER :: ILPAD1,IRPAD1,JBPAD1,JTPAD1
870	LOGICAL :: E_BDY,W_BDY,N_BDY,S_BDY
871	!-----------------------------------------------------------------------
872	!***********************************************************************
873	!-----------------------------------------------------------------------
874	!
875	!-----------------------------------------------------------------------
876	!*** TIME INTERPOLATION OF U AND V AT THE OUTER BOUNDARY
877	!-----------------------------------------------------------------------
878	!
879	IM=IDE-IDS+1
880	JM=JDE-JDS+1
881	IIM=IM
882	JJM=JM
883	!
884	W_BDY=(ITS==IDS)
885	E_BDY=(ITE==IDE)
886	S_BDY=(JTS==JDS)
887	N_BDY=(JTE==JDE)
888	!
889	ILPAD1=1
890	IF(ITS==IDS)ILPAD1=0
891	IRPAD1=1
892	IF(ITE==IDE)ILPAD1=0
893	JBPAD1=1
894	IF(JTS==JDS)JBPAD1=0
895	JTPAD1=1
896	IF(JTE==JDE)JTPAD1=0
897	!
898	MY_IS_GLB=ITS
899	MY_IE_GLB=ITE
900	MY_JS_GLB=JTS
901	MY_JE_GLB=JTE
902	!
903	!-----------------------------------------------------------------------
904	!*** SOUTH AND NORTH BOUNDARIES
905	!*** USE IBDY=1 FOR SOUTH; 2 FOR NORTH.
906	!-----------------------------------------------------------------------
907	!
908	DO IBDY=1,2
909	!
910	!*** MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
911	!
912	IF(S_BDY.AND.IBDY==1) THEN
913	!
914	JB=1 ! Which cell in from Boundary
915	JJ=1 ! Which cell in the Domain
916	!
917	!$omp parallel do &
918	!$omp& private(i,k)
919	DO K=KTS,KTE
920	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
921	U_BYS(I,K,JB)=U_BYS(I,K,JB)+U_BTYS(I,K,JB)*DT
922	V_BYS(I,K,JB)=V_BYS(I,K,JB)+V_BTYS(I,K,JB)*DT
923	U(I,JJ,K)=U_BYS(I,K,JB)
924	V(I,JJ,K)=V_BYS(I,K,JB)
925	ENDDO
926	ENDDO
927	!
928
929	ELSEIF(N_BDY.AND.IBDY==2) THEN
930	JB=1 ! Which cell in from Boundary
931	JJ=JJM ! Which cell in the Domain
932
933	!$omp parallel do &
934	!$omp& private(i,k)
935	DO K=KTS,KTE
936	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
937	U_BYE(I,K,JB)=U_BYE(I,K,JB)+U_BTYE(I,K,JB)*DT
938	V_BYE(I,K,JB)=V_BYE(I,K,JB)+V_BTYE(I,K,JB)*DT
939	U(I,JJ,K)=U_BYE(I,K,JB)
940	V(I,JJ,K)=V_BYE(I,K,JB)
941	ENDDO
942	ENDDO
943
944
945	ENDIF
946	ENDDO
947
948	!
949	!-----------------------------------------------------------------------
950	!*** WEST AND EAST BOUNDARIES
951	!*** USE IBDY=1 FOR WEST; 2 FOR EAST.
952	!-----------------------------------------------------------------------
953	!
954	DO IBDY=1,2
955	!
956	!*** MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
957	!
958	IF(W_BDY.AND.IBDY==1) THEN
959	IB=1 ! Which cell in from boundary
960	II=1 ! Which cell in the domain
961	!
962	!$omp parallel do &
963	!$omp& private(j,k)
964	DO K=KTS,KTE
965	DO J=MAX(JTS-1,JDS+2-1),MIN(JTE+1,JDE-1)
966	IF(MOD(J,2)==0)THEN
967	U_BXS(J,K,IB)=U_BXS(J,K,IB)+U_BTXS(J,K,IB)*DT
968	V_BXS(J,K,IB)=V_BXS(J,K,IB)+V_BTXS(J,K,IB)*DT
969	U(II,J,K)=U_BXS(J,K,IB)
970	V(II,J,K)=V_BXS(J,K,IB)
971	ENDIF
972	ENDDO
973	ENDDO
974
975	ELSEIF (E_BDY.AND.IBDY==2) THEN
976	IB=1 ! Which cell in from boundary
977	II=IIM ! Which cell in the domain
978
979	!$omp parallel do &
980	!$omp& private(j,k)
981	DO K=KTS,KTE
982	DO J=MAX(JTS-1,JDS+2-1),MIN(JTE+1,JDE-1)
983	IF(MOD(J,2)==0)THEN
984	U_BXE(J,K,IB)=U_BXE(J,K,IB)+U_BTXE(J,K,IB)*DT
985	V_BXE(J,K,IB)=V_BXE(J,K,IB)+V_BTXE(J,K,IB)*DT
986	U(II,J,K)=U_BXE(J,K,IB)
987	V(II,J,K)=V_BXE(J,K,IB)
988	ENDIF
989	ENDDO
990	ENDDO
991
992	!
993	ENDIF
994
995
996
997	ENDDO
998
999	!
1000	!-----------------------------------------------------------------------
1001	!*** EXTRAPOLATION OF TANGENTIAL VELOCITY AT OUTFLOW POINTS
1002	!*** BASED ON SOME DISCUSSIONS WITH ZAVISA, AND MY EXPERIMENTS
1003	!*** ON GRAVITY PULSE FOR NESTED DOMAIN.
1004	!-----------------------------------------------------------------------
1005	!
1006	IF(GRIDID/=1)GO TO 201
1007	!
1008	!-----------------------------------------------------------------------
1009	!
1010	!$omp parallel do &
1011	!$omp& private(i,j,jj,k)
1012	DO 200 K=KTS,KTE
1013	!
1014	!-----------------------------------------------------------------------
1015	!
1016	!*** SOUTHERN BOUNDARY
1017	!
1018	IF(S_BDY)THEN
1019	DO I=MYIS1_P1,MYIE2_P1
1020	IF(V(I,1,K)<0.)U(I,1,K)=2.*U(I,3,K)-U(I,5,K)
1021	ENDDO
1022	ENDIF
1023	!
1024	!*** NORTHERN BOUNDARY
1025	!
1026	IF(N_BDY)THEN
1027	DO I=MYIS1_P1,MYIE2_P1
1028	IF(V(I,JJM,K)>0.) &
1029	& U(I,JJM,K)=2.*U(I,JJM-2,K)-U(I,JJM-4,K)
1030	ENDDO
1031	ENDIF
1032	!
1033	!*** WESTERN BOUNDARY
1034	!
1035	DO J=4,JM-3,2
1036	IF(W_BDY)THEN
1037	!
1038	IF(W_BDY.AND.J>=MY_JS_GLB-JBPAD1 &
1039	& .AND.J<=MY_JE_GLB+JTPAD1)THEN
1040	JJ=J
1041	IF(U(1,JJ,K)<0.) &
1042	& V(1,JJ,K)=2.*V(2,JJ,K)-V(3,JJ,K)
1043	ENDIF
1044	!
1045	ENDIF
1046	ENDDO
1047	!
1048	!*** EASTERN BOUNDARY
1049	!
1050	DO J=4,JM-3,2
1051	IF(E_BDY)THEN
1052	!
1053	IF(E_BDY.AND.J>=MY_JS_GLB-JBPAD1 &
1054	& .AND.J<=MY_JE_GLB+JTPAD1)THEN
1055	JJ=J
1056	IF(U(IIM,JJ,K)>0.) &
1057	& V(IIM,JJ,K)=2.*V(IIM-1,JJ,K)-V(IIM-2,JJ,K)
1058	ENDIF
1059	!
1060	ENDIF
1061	ENDDO
1062	!-----------------------------------------------------------------------
1063	!
1064	200 CONTINUE
1065
1066	201 CONTINUE
1067	!
1068	!-----------------------------------------------------------------------
1069	!
1070	!-----------------------------------------------------------------------
1071	!*** SPACE INTERPOLATION OF U AND V AT THE INNER BOUNDARY
1072	!-----------------------------------------------------------------------
1073	!
1074	!-----------------------------------------------------------------------
1075	!
1076	!$omp parallel do &
1077	!$omp& private(i,j,jj,k)
1078	DO 300 K=KTS,KTE
1079	!
1080	!-----------------------------------------------------------------------
1081	!
1082	!*** SOUTHWEST CORNER
1083	!
1084	IF(S_BDY.AND.W_BDY)THEN
1085	U(2,2,K)=D06666(4.(U(1,1,K)+U(2,1,K)+U(2,3,K)) &
1086	& + U(1,2,K)+U(1,4,K)+U(2,4,K))
1087	V(2,2,K)=D06666(4.(V(1,1,K)+V(2,1,K)+V(2,3,K)) &
1088	& +V(1,2,K)+V(1,4,K)+V(2,4,K))
1089	ENDIF
1090	!
1091	!*** SOUTHEAST CORNER
1092	!
1093	IF(S_BDY.AND.E_BDY)THEN
1094	U(IIM-1,2,K)=D06666(4.(U(IIM-2,1,K)+U(IIM-1,1,K) &
1095	& +U(IIM-2,3,K)) &
1096	& +U(IIM,2,K)+U(IIM,4,K)+U(IIM-1,4,K))
1097	V(IIM-1,2,K)=D06666(4.(V(IIM-2,1,K)+V(IIM-1,1,K) &
1098	& +V(IIM-2,3,K)) &
1099	& +V(IIM,2,K)+V(IIM,4,K)+V(IIM-1,4,K))
1100	ENDIF
1101	!
1102	!*** NORTHWEST CORNER
1103	!
1104	IF(N_BDY.AND.W_BDY)THEN
1105	U(2,JJM-1,K)=D06666(4.(U(1,JJM,K)+U(2,JJM,K)+U(2,JJM-2,K)) &
1106	& +U(1,JJM-1,K)+U(1,JJM-3,K) &
1107	& +U(2,JJM-3,K))
1108	V(2,JJM-1,K)=D06666(4.(V(1,JJM,K)+V(2,JJM,K)+V(2,JJM-2,K)) &
1109	& +V(1,JJM-1,K)+V(1,JJM-3,K) &
1110	& +V(2,JJM-3,K))
1111	ENDIF
1112	!
1113	!*** NORTHEAST CORNER
1114	!
1115	IF(N_BDY.AND.E_BDY)THEN
1116	U(IIM-1,JJM-1,K)= &
1117	& D06666(4.(U(IIM-2,JJM,K)+U(IIM-1,JJM,K)+U(IIM-2,JJM-2,K)) &
1118	& +U(IIM,JJM-1,K)+U(IIM,JJM-3,K)+U(IIM-1,JJM-3,K))
1119	V(IIM-1,JJM-1,K)= &
1120	& D06666(4.(V(IIM-2,JJM,K)+V(IIM-1,JJM,K)+V(IIM-2,JJM-2,K)) &
1121	& +V(IIM,JJM-1,K)+V(IIM,JJM-3,K)+V(IIM-1,JJM-3,K))
1122	ENDIF
1123	!
1124	!-----------------------------------------------------------------------
1125	!*** SPACE INTERPOLATION OF U AND V AT THE INNER BOUNDARY
1126	!-----------------------------------------------------------------------
1127	!
1128	!*** ONE ROW NORTH OF SOUTHERN BOUNDARY
1129	!
1130	IF(S_BDY)THEN
1131	DO I=MYIS2,MYIE2
1132	U(I,2,K)=(U(I-1,1,K)+U(I,1,K)+U(I-1,3,K)+U(I,3,K))*0.25
1133	V(I,2,K)=(V(I-1,1,K)+V(I,1,K)+V(I-1,3,K)+V(I,3,K))*0.25
1134	ENDDO
1135	ENDIF
1136	!
1137	!*** ONE ROW SOUTH OF NORTHERN BOUNDARY
1138	!
1139	IF(N_BDY)THEN
1140	DO I=MYIS2,MYIE2
1141	U(I,JJM-1,K)=(U(I-1,JJM-2,K)+U(I,JJM-2,K) &
1142	& +U(I-1,JJM,K)+U(I,JJM,K))*0.25
1143	V(I,JJM-1,K)=(V(I-1,JJM-2,K)+V(I,JJM-2,K) &
1144	& +V(I-1,JJM,K)+V(I,JJM,K))*0.25
1145	ENDDO
1146	ENDIF
1147	!
1148	!*** ONE ROW EAST OF WESTERN BOUNDARY
1149	!
1150	DO J=3,JM-2,2
1151	IF(W_BDY)THEN
1152	IF(W_BDY.AND.J>=MY_JS_GLB-JBPAD1 &
1153	& .AND.J<=MY_JE_GLB+JTPAD1)THEN
1154	JJ=J
1155	U(1,JJ,K)=(U(1,JJ-1,K)+U(2,JJ-1,K) &
1156	& +U(1,JJ+1,K)+U(2,JJ+1,K))*0.25
1157	V(1,JJ,K)=(V(1,JJ-1,K)+V(2,JJ-1,K) &
1158	& +V(1,JJ+1,K)+V(2,JJ+1,K))*0.25
1159
1160
1161	ENDIF
1162	ENDIF
1163	ENDDO
1164	!
1165	!*** ONE ROW WEST OF EASTERN BOUNDARY
1166	!
1167	IF(E_BDY)THEN
1168	DO J=3,JM-2,2
1169	IF(E_BDY.AND.J>=MY_JS_GLB-JBPAD1 &
1170	& .AND.J<=MY_JE_GLB+JTPAD1)THEN
1171	JJ=J
1172	U(IIM-1,JJ,K)=0.25*(U(IIM-1,JJ-1,K)+U(IIM,JJ-1,K) &
1173	& +U(IIM-1,JJ+1,K)+U(IIM,JJ+1,K))
1174	V(IIM-1,JJ,K)=0.25*(V(IIM-1,JJ-1,K)+V(IIM,JJ-1,K) &
1175	& +V(IIM-1,JJ+1,K)+V(IIM,JJ+1,K))
1176	ENDIF
1177	ENDDO
1178	ENDIF
1179	!-----------------------------------------------------------------------
1180	!
1181	300 CONTINUE
1182	!
1183	!-----------------------------------------------------------------------
1184	!
1185	END SUBROUTINE BOCOV
1186	!
1187	!-----------------------------------------------------------------------
1188	!
1189	END MODULE MODULE_BNDRY_COND
1190	!
1191	!-----------------------------------------------------------------------

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

Download in other formats:

Original Format