| blob | a65a093096cd62393e6f9dd588413cda312f9bb5 |
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 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=2*LB*(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
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
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
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
279 ELSEIF(N_BDY.AND.IBDY==2) THEN
280 JB=1 ! Which cell in from boundary
281 JJ=JJM ! Which cell in the domain
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
307 ! ENDIF ! for N/S boundaries
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_D*T(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
409 ELSEIF(E_BDY.AND.IBDY==2) THEN
410 IB=1 ! Which cell in from boundary
411 II=IIM ! Which cell in the domain
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_D*T(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
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
537 ENDDO
538 ENDIF
539 !
540 !*** ONE ROW SOUTH OF NORTHERN BOUNDARY
541 !
542 IF(N_BDY)THEN
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
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
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
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
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
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 !
981 ELSEIF(N_BDY.AND.IBDY==2) THEN
982 JB=1 ! Which cell in from Boundary
983 JJ=JJM ! Which cell in the Domain
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
997 ENDIF
998 ENDDO
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
1027 ELSEIF (E_BDY.AND.IBDY==2) THEN
1028 IB=1 ! Which cell in from boundary
1029 II=IIM ! Which cell in the domain
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
1044 !
1045 ENDIF
1049 ENDDO
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
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
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 !-----------------------------------------------------------------------