Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_BNDRY_COND.F @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

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

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

Download in other formats:

Original Format