Warning, /pkg/exch2/exch2_uv_bgrid_3d_rx.template is written in an unsupported language. File is not indexed.
view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
fc624899fa Jean*0001 #include "CPP_EEOPTIONS.h"
0002 #include "W2_OPTIONS.h"
0003
0004 CBOP
0005 C !ROUTINE: EXCH2_UV_BGRID_3D_RX
0006
0007 C !INTERFACE:
0008 SUBROUTINE EXCH2_UV_BGRID_3D_RX(
0009 U uPhi, vPhi,
0010 I withSigns, myNz, myThid )
0011
0012 C !DESCRIPTION:
0013 C*=====================================================================*
0014 C Purpose: SUBROUTINE EXCH2_UV_BGRID_3D_RX
0015 C handle exchanges for a 3D vector field on a B-grid.
0016 C
0017 C Input:
0018 C uPhi(lon,lat,levs,bi,bj) :: first component of vector
0019 C vPhi(lon,lat,levs,bi,bj) :: second component of vector
0020 C withSigns (logical) :: true to use sign of components
0021 C myNz :: 3rd dimension of input arrays uPhi,vPhi
0022 C myThid :: my Thread Id number
0023 C
0024 C Output: uPhi and vPhi are updated (halo regions filled)
0025 C
0026 C Calls: exch_RX (exch2_RX1_cube) - for each component
0027 C
0028 C*=====================================================================*
0029
0030 C !USES:
0031 IMPLICIT NONE
0032
0033 #include "SIZE.h"
0034 #include "EEPARAMS.h"
90219e5912 Jean*0035 #include "W2_EXCH2_SIZE.h"
fc624899fa Jean*0036 #include "W2_EXCH2_TOPOLOGY.h"
d0ce7fc1dc Jean*0037 c#ifdef W2_FILL_NULL_REGIONS
0038 c#include "W2_EXCH2_PARAMS.h"
0039 c#endif
fc624899fa Jean*0040
0041 C !INPUT/OUTPUT PARAMETERS:
0042 C == Argument list variables ==
0043 INTEGER myNz
0044 _RX uPhi(1-OLx:sNx+OLx,1-OLy:sNy+OLy,myNz,nSx,nSy)
0045 _RX vPhi(1-OLx:sNx+OLx,1-OLy:sNy+OLy,myNz,nSx,nSy)
0046 LOGICAL withSigns
0047 INTEGER myThid
0048
0049 C !LOCAL VARIABLES:
0050 C == Local variables ==
0051 C local_maxDim :: upper limit of 3rd dimension value
0052 C i,j,k,bi,bj :: loop indices.
0053 C OL[wens] :: Overlap extents in west, east, north, south.
0054 C exchWidth[XY] :: Extent of regions that will be exchanged.
0055 C uPhiNW,uPhiSE :: temporary array to hold corner value (CS grid)
0056 C vPhiNW,vPhiSE :: temporary array to hold corner value (CS grid)
0057 C uLoc,vLoc :: local copy of the vector components with haloes filled.
d6ea3164dc Jean*0058 C msgBuf :: Informational/error message buffer
fc624899fa Jean*0059
0060 INTEGER local_maxDim
0061 PARAMETER( local_maxDim = 8*Nr )
0062 INTEGER i,j,k,bi,bj
0063 INTEGER myTile, myFace
0064 INTEGER OLw, OLe, OLn, OLs, exchWidthX, exchWidthY
0065 _RX uPhiNW(local_maxDim,nSx,nSy), uPhiSE(local_maxDim,nSx,nSy)
0066 _RX vPhiNW(local_maxDim,nSx,nSy), vPhiSE(local_maxDim,nSx,nSy)
0067 _RX uLoc(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
0068 _RX vLoc(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
0069 _RX negOne
0070 CHARACTER*(MAX_LEN_MBUF) msgBuf
0071
0072 CEOP
0073
0074 OLw = OLx
0075 OLe = OLx
0076 OLn = OLy
0077 OLs = OLy
0078 exchWidthX = OLx
0079 exchWidthY = OLy
0080 negOne = 1.
0081 IF (withSigns) negOne = -1.
0082
0083 IF ( useCubedSphereExchange ) THEN
0084 C--- using CubedSphereExchange:
0085 IF ( myNz.GT.local_maxDim ) THEN
0086 WRITE(msgBuf,'(2A,2(I4,A))') 'EXCH2_UV_BGRID_3D_RX :',
0087 & ' 3rd dimension=', myNz,
0088 & ' exceeds local_maxDim (=', local_maxDim, ' )'
0089 CALL PRINT_ERROR( msgBuf , myThid )
0090 WRITE(msgBuf,'(2A)') 'EXCH2_UV_BGRID_3D_RX :',
0091 & ' Increase "local_maxDim" and recompile'
0092 CALL PRINT_ERROR( msgBuf , myThid )
0093 STOP 'ABNORMAL END: S/R EXCH2_UV_BGRID_3D_RX'
0094 ENDIF
0095
0096 C- save 2 corners value (in case we find 1 "missing corner")
0097 DO bj=myByLo(myThid),myByHi(myThid)
0098 DO bi=myBxLo(myThid),myBxHi(myThid)
0099 DO k=1,myNz
0100 uPhiNW(k,bi,bj) = uPhi(1,sNy+1,k,bi,bj)
0101 vPhiNW(k,bi,bj) = vPhi(1,sNy+1,k,bi,bj)
0102 uPhiSE(k,bi,bj) = uPhi(sNx+1,1,k,bi,bj)
0103 vPhiSE(k,bi,bj) = vPhi(sNx+1,1,k,bi,bj)
0104 ENDDO
0105 ENDDO
0106 ENDDO
5df640d755 Jean*0107 C--- using or not using CubedSphereExchange: end
0108 ENDIF
fc624899fa Jean*0109
0110 C-- First call the exchanges for the two components
0111
8bc539472e Jean*0112 CALL EXCH2_RX1_CUBE( uPhi, .FALSE., 'T ',
fc624899fa Jean*0113 I OLw, OLe, OLs, OLn, myNz,
0114 I exchWidthX, exchWidthY,
1a3a8861a0 Jean*0115 I EXCH_IGNORE_CORNERS, myThid )
8bc539472e Jean*0116 CALL EXCH2_RX1_CUBE( uPhi, .FALSE., 'T ',
fc624899fa Jean*0117 I OLw, OLe, OLs, OLn, myNz,
0118 I exchWidthX, exchWidthY,
8bc539472e Jean*0119 I EXCH_UPDATE_CORNERS, myThid )
fc624899fa Jean*0120
8bc539472e Jean*0121 CALL EXCH2_RX1_CUBE( vPhi, .FALSE., 'T ',
fc624899fa Jean*0122 I OLw, OLe, OLs, OLn, myNz,
0123 I exchWidthX, exchWidthY,
1a3a8861a0 Jean*0124 I EXCH_IGNORE_CORNERS, myThid )
8bc539472e Jean*0125 CALL EXCH2_RX1_CUBE( vPhi, .FALSE., 'T ',
fc624899fa Jean*0126 I OLw, OLe, OLs, OLn, myNz,
0127 I exchWidthX, exchWidthY,
8bc539472e Jean*0128 I EXCH_UPDATE_CORNERS, myThid )
fc624899fa Jean*0129
0130 C- note: can substitute the low-level S/R calls above with:
0131 c CALL EXCH2_3D_RX( uPhi, myNz, myThid )
0132 c CALL EXCH2_3D_RX( vPhi, myNz, myThid )
0133
5df640d755 Jean*0134 IF ( useCubedSphereExchange ) THEN
0135
fc624899fa Jean*0136 C-- Then, depending on which tile we are, we may need
0137 C 1) to switch u and v components and also to switch the signs
0138 C 2) to shift the index along the face edge.
0139 C 3) ensure that near-corner halo regions is filled in the correct order
0140 C (i.e. with velocity component already available after 1 exch)
0141 C- note: because of index shift, the order really matter:
0142 C odd faces, do North 1rst and then West;
0143 C even faces, do East 1rst and then South.
0144
0145 C-- Loops on tile indices:
0146 DO bj = myByLo(myThid), myByHi(myThid)
0147 DO bi = myBxLo(myThid), myBxHi(myThid)
0148
8bc539472e Jean*0149 C- Choose what to do at each edge of the halo based on which face we are
5df640d755 Jean*0150 myTile = W2_myTileList(bi,bj)
fc624899fa Jean*0151 myFace = exch2_myFace(myTile)
0152
0153 C-- Loops on level index:
0154 DO k = 1,myNz
0155
0156 C- First we copy the 2 components info into local dummy arrays uLoc,vLoc
0157 DO j = 1-OLy,sNy+OLy
0158 DO i = 1-OLx,sNx+OLx
0159 uLoc(i,j) = uPhi(i,j,k,bi,bj)
0160 vLoc(i,j) = vPhi(i,j,k,bi,bj)
0161 ENDDO
0162 ENDDO
0163
0164 C- odd faces share disposition of all sections of the halo
0165 IF ( MOD(myFace,2).EQ.1 ) THEN
0166 C- North:
0167 IF (exch2_isNedge(myTile).EQ.1) THEN
0168 C switch u <- v , reverse the sign & shift i+1 <- i
0169 C switch v <- u , keep the sign & shift i+1 <- i
0170 DO j = 1,exchWidthY
0171 DO i = 1-OLx,sNx+OLx-1
0172 uPhi(i+1,sNy+j,k,bi,bj) = vLoc(i,sNy+j)*negOne
0173 vPhi(i+1,sNy+j,k,bi,bj) = uLoc(i,sNy+j)
0174 ENDDO
0175 ENDDO
0176 ENDIF
0177 C- South (nothing to change)
0178 c IF (exch2_isSedge(myTile).EQ.1) THEN
0179 c DO j = 1,exchWidthY
0180 c DO i = 1-OLx,sNx+OLx
0181 c uPhi(i,1-j,k,bi,bj) = uLoc(i,1-j)
0182 c vPhi(i,1-j,k,bi,bj) = vLoc(i,1-j)
0183 c ENDDO
0184 c ENDDO
0185 c ENDIF
0186 C- East (nothing to change)
0187 c IF (exch2_isEedge(myTile).EQ.1) THEN
0188 c DO j = 1-OLy,sNy+OLy
0189 c DO i = 1,exchWidthX
0190 c uPhi(sNx+i,j,k,bi,bj) = uLoc(sNx+i,j)
0191 c vPhi(sNx+i,j,k,bi,bj) = vLoc(sNx+i,j)
0192 c ENDDO
0193 c ENDDO
0194 c ENDIF
0195 C- West:
0196 IF (exch2_isWedge(myTile).EQ.1) THEN
0197 C switch u <- v , keep the sign & shift j+1 <- j
0198 C switch v <- u , reverse the sign & shift j+1 <- j
0199 DO j = 1-OLy,sNy+OLy-1
0200 DO i = 1,exchWidthX
0201 uPhi(1-i,j+1,k,bi,bj) = vLoc(1-i,j)
0202 vPhi(1-i,j+1,k,bi,bj) = uLoc(1-i,j)*negOne
0203 ENDDO
0204 ENDDO
0205 ENDIF
0206
0207 ELSE
0208 C- Now the even faces (share disposition of all sections of the halo)
0209
0210 C- East:
0211 IF (exch2_isEedge(myTile).EQ.1) THEN
0212 C switch u <- v , keep the sign & shift j+1 <- j
0213 C switch v <- u , reverse the sign & shift j+1 <- j
0214 DO j = 1-OLy,sNy+OLy-1
0215 DO i = 1,exchWidthX
0216 uPhi(sNx+i,j+1,k,bi,bj) = vLoc(sNx+i,j)
0217 vPhi(sNx+i,j+1,k,bi,bj) = uLoc(sNx+i,j)*negOne
0218 ENDDO
0219 ENDDO
0220 ENDIF
0221 C- West (nothing to change)
0222 c IF (exch2_isWedge(myTile).EQ.1) THEN
0223 c DO j = 1-OLy,sNy+OLy
0224 c DO i = 1,exchWidthX
0225 c uPhi(1-i,j,k,bi,bj) = uLoc(1-i,j)
0226 c vPhi(1-i,j,k,bi,bj) = vLoc(1-i,j)
0227 c ENDDO
0228 c ENDDO
0229 c ENDIF
0230 C- North (nothing to change)
0231 c IF (exch2_isNedge(myTile).EQ.1) THEN
0232 c DO j = 1,exchWidthY
0233 c DO i = 1-OLx,sNx+OLx
0234 c uPhi(i,sNy+j,k,bi,bj) = uLoc(i,sNy+j)
0235 c vPhi(i,sNy+j,k,bi,bj) = vLoc(i,sNy+j)
0236 c ENDDO
0237 c ENDDO
0238 c ENDIF
0239 C- South:
0240 IF (exch2_isSedge(myTile).EQ.1) THEN
0241 C switch u <- v , reverse the sign & shift i+1 <- i
0242 C switch v <- u , keep the sign & shift i+1 <- i
0243 DO j = 1,exchWidthY
0244 DO i = 1-OLx,sNx+OLx-1
0245 uPhi(i+1,1-j,k,bi,bj) = vLoc(i,1-j)*negOne
0246 vPhi(i+1,1-j,k,bi,bj) = uLoc(i,1-j)
0247 ENDDO
0248 ENDDO
0249 ENDIF
0250
0251 C- end odd / even faces
0252 ENDIF
0253
0254 C-- end of Loops on level index k.
0255 ENDDO
0256
0257 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
0258 C-- Now fix edges near cube-corner
0259
0260 C- South-West corner
0261 IF ( exch2_isWedge(myTile) .EQ. 1 .AND.
0262 & exch2_isSedge(myTile) .EQ. 1 ) THEN
0263 IF ( MOD(myFace,2).EQ.1 ) THEN
0264 DO k=1,myNz
0265 DO i=1,OLx
0266 vPhi(1-i,1,k,bi,bj) = uPhi(1,1-i,k,bi,bj)*negOne
0267 uPhi(1-i,1,k,bi,bj) = vPhi(1,1-i,k,bi,bj)
0268 ENDDO
0269 ENDDO
0270 ELSE
0271 DO k=1,myNz
0272 DO i=1,OLx
0273 uPhi(1,1-i,k,bi,bj) = vPhi(1-i,1,k,bi,bj)*negOne
0274 vPhi(1,1-i,k,bi,bj) = uPhi(1-i,1,k,bi,bj)
0275 ENDDO
0276 ENDDO
0277 ENDIF
0278 ENDIF
0279
0280 C- South-East corner
0281 IF ( exch2_isEedge(myTile) .EQ. 1 .AND.
0282 & exch2_isSedge(myTile) .EQ. 1 ) THEN
0283 IF ( MOD(myFace,2).EQ.1 ) THEN
0284 DO k=1,myNz
0285 DO i=2,OLx
0286 uPhi(sNx+1,2-i,k,bi,bj) = vPhi(sNx+i,1,k,bi,bj)
0287 vPhi(sNx+1,2-i,k,bi,bj) = uPhi(sNx+i,1,k,bi,bj)*negOne
0288 ENDDO
0289 ENDDO
0290 ELSE
0291 DO k=1,myNz
0292 uPhi(sNx+1,1,k,bi,bj) = uPhiSE(k,bi,bj)
0293 vPhi(sNx+1,1,k,bi,bj) = vPhiSE(k,bi,bj)
0294 DO i=2,OLx
0295 uPhi(sNx+i,1,k,bi,bj) = vPhi(sNx+1,2-i,k,bi,bj)*negOne
0296 vPhi(sNx+i,1,k,bi,bj) = uPhi(sNx+1,2-i,k,bi,bj)
0297 ENDDO
0298 ENDDO
0299 ENDIF
0300 ENDIF
0301
0302 C- North-East corner
0303 IF ( exch2_isEedge(myTile) .EQ. 1 .AND.
0304 & exch2_isNedge(myTile) .EQ. 1 ) THEN
0305 IF ( MOD(myFace,2).EQ.1 ) THEN
0306 DO k=1,myNz
0307 DO i=2,OLx
0308 uPhi(sNx+i,sNy+1,k,bi,bj)=vPhi(sNx+1,sNy+i,k,bi,bj)
0309 vPhi(sNx+i,sNy+1,k,bi,bj)=uPhi(sNx+1,sNy+i,k,bi,bj)*negOne
0310 ENDDO
0311 ENDDO
0312 ELSE
0313 DO k=1,myNz
0314 DO i=2,OLx
0315 uPhi(sNx+1,sNy+i,k,bi,bj)=vPhi(sNx+i,sNy+1,k,bi,bj)*negOne
0316 vPhi(sNx+1,sNy+i,k,bi,bj)=uPhi(sNx+i,sNy+1,k,bi,bj)
0317 ENDDO
0318 ENDDO
0319 ENDIF
0320 ENDIF
0321
0322 C- North-West corner
0323 IF ( exch2_isWedge(myTile) .EQ. 1 .AND.
0324 & exch2_isNedge(myTile) .EQ. 1 ) THEN
0325 IF ( MOD(myFace,2).EQ.1 ) THEN
0326 DO k=1,myNz
55e3339a8c Jean*0327 uPhi(1,sNy+1,k,bi,bj) = uPhiNW(k,bi,bj)
0328 vPhi(1,sNy+1,k,bi,bj) = vPhiNW(k,bi,bj)
fc624899fa Jean*0329 DO i=2,OLx
0330 uPhi(1,sNy+i,k,bi,bj) = vPhi(2-i,sNy+1,k,bi,bj)
0331 vPhi(1,sNy+i,k,bi,bj) = uPhi(2-i,sNy+1,k,bi,bj)*negOne
0332 ENDDO
0333 ENDDO
0334 ELSE
0335 DO k=1,myNz
0336 DO i=2,OLx
0337 uPhi(2-i,sNy+1,k,bi,bj) = vPhi(1,sNy+i,k,bi,bj)*negOne
0338 vPhi(2-i,sNy+1,k,bi,bj) = uPhi(1,sNy+i,k,bi,bj)
0339 ENDDO
0340 ENDDO
0341 ENDIF
0342 ENDIF
0343
0344 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
0345
0346 #ifdef W2_FILL_NULL_REGIONS
0347 C-- Now zero out the null areas that should not be used in the numerics
0348
0349 IF ( exch2_isWedge(myTile) .EQ. 1 .AND.
0350 & exch2_isSedge(myTile) .EQ. 1 ) THEN
0351 C Zero SW corner points
0352 DO k=1,myNz
0353 DO j=1-OLy,0
0354 DO i=1-OLx,0
0355 uPhi(i,j,k,bi,bj)=e2FillValue_RX
0356 vPhi(i,j,k,bi,bj)=e2FillValue_RX
0357 ENDDO
0358 ENDDO
0359 ENDDO
0360 ENDIF
0361
0362 IF ( exch2_isWedge(myTile) .EQ. 1 .AND.
0363 & exch2_isNedge(myTile) .EQ. 1 ) THEN
0364 C Zero NW corner points
0365 DO k=1,myNz
0366 DO j=sNy+2,sNy+OLy
0367 DO i=1-OLx,0
0368 uPhi(i,j,k,bi,bj)=e2FillValue_RX
0369 vPhi(i,j,k,bi,bj)=e2FillValue_RX
0370 ENDDO
0371 ENDDO
0372 ENDDO
0373 ENDIF
0374
0375 IF ( exch2_isEedge(myTile) .EQ. 1 .AND.
0376 & exch2_isSedge(myTile) .EQ. 1 ) THEN
0377 C Zero SE corner points
0378 DO k=1,myNz
0379 DO j=1-OLy,0
0380 DO i=sNx+2,sNx+OLx
0381 uPhi(i,j,k,bi,bj)=e2FillValue_RX
0382 vPhi(i,j,k,bi,bj)=e2FillValue_RX
0383 ENDDO
0384 ENDDO
0385 ENDDO
0386 ENDIF
0387
0388 IF ( exch2_isEedge(myTile) .EQ. 1 .AND.
0389 & exch2_isNedge(myTile) .EQ. 1 ) THEN
0390 C Zero NE corner points
0391 DO k=1,myNz
0392 DO j=sNy+2,sNy+OLy
0393 DO i=sNx+2,sNx+OLx
0394 uPhi(i,j,k,bi,bj)=e2FillValue_RX
0395 vPhi(i,j,k,bi,bj)=e2FillValue_RX
0396 ENDDO
0397 ENDDO
0398 ENDDO
0399 ENDIF
0400
0401 #endif /* W2_FILL_NULL_REGIONS */
0402
0403 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
0404
0405 C-- end of Loops on tile indices (bi,bj).
0406 ENDDO
0407 ENDDO
0408
0409 C--- using or not using CubedSphereExchange: end
0410 ENDIF
0411
0412 RETURN
0413 END
0414
0415 CEH3 ;;; Local Variables: ***
0416 CEH3 ;;; mode:fortran ***
0417 CEH3 ;;; End: ***
