source: lmdz_wrf/trunk/WRFV3/dyn_nmm/module_BNDRY_COND.F @ 1554

Last change on this file since 1554 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

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