Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_BNDRY_COND.F @ 3968

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

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

Download in other formats:

Original Format