| blob | c1292bdde3c78db937deae76a147c71c85ccd298 |
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
150 REAL,DIMENSION(JMS:JME,1,SPEC_BDY_WIDTH) &
151 & ,INTENT(INOUT) :: PD_BXS, PD_BXE &
152 & ,PD_BTXS,PD_BTXE
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
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=2*LB*(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
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
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
276 ELSEIF(N_BDY.AND.IBDY==2) THEN
277 JB=1 ! Which cell in from boundary
278 JJ=JJM ! Which cell in the domain
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
304 ! ENDIF ! for N/S boundaries
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_D*T(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
406 ELSEIF(E_BDY.AND.IBDY==2) THEN
407 IB=1 ! Which cell in from boundary
408 II=IIM ! Which cell in the domain
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_D*T(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
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
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
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
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
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 !
929 ELSEIF(N_BDY.AND.IBDY==2) THEN
930 JB=1 ! Which cell in from Boundary
931 JJ=JJM ! Which cell in the Domain
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
945 ENDIF
946 ENDDO
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
975 ELSEIF (E_BDY.AND.IBDY==2) THEN
976 IB=1 ! Which cell in from boundary
977 II=IIM ! Which cell in the domain
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
992 !
993 ENDIF
997 ENDDO
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
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
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 !-----------------------------------------------------------------------