Warning, /pkg/exch2/exch2_uv_agrid_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
d4e639dc4c Jean*0001 #include "CPP_EEOPTIONS.h"
0002 #include "W2_OPTIONS.h"
0003
0004 CBOP
0005 C !ROUTINE: EXCH2_UV_AGRID_3D_RX
0006
0007 C !INTERFACE:
0008 SUBROUTINE EXCH2_UV_AGRID_3D_RX(
e22a2cfed2 Jean*0009 U uPhi, vPhi,
d4e639dc4c Jean*0010 I withSigns, myNz, myThid )
0011
0012 C !DESCRIPTION:
0013 C*=====================================================================*
0014 C Purpose: SUBROUTINE EXCH2_UV_AGRID_3D_RX
0015 C handle exchanges for a 3D vector field on an A-grid.
0016 C
e22a2cfed2 Jean*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
d4e639dc4c Jean*0020 C withSigns (logical) :: true to use sign of components
e22a2cfed2 Jean*0021 C myNz :: 3rd dimension of input arrays uPhi,vPhi
d4e639dc4c Jean*0022 C myThid :: my Thread Id number
0023 C
e22a2cfed2 Jean*0024 C Output: uPhi and vPhi are updated (halo regions filled)
d4e639dc4c Jean*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"
d4e639dc4c Jean*0036 #include "W2_EXCH2_TOPOLOGY.h"
0037
0038 C !INPUT/OUTPUT PARAMETERS:
0039 C == Argument list variables ==
0040 INTEGER myNz
e22a2cfed2 Jean*0041 _RX uPhi(1-OLx:sNx+OLx,1-OLy:sNy+OLy,myNz,nSx,nSy)
0042 _RX vPhi(1-OLx:sNx+OLx,1-OLy:sNy+OLy,myNz,nSx,nSy)
d4e639dc4c Jean*0043 LOGICAL withSigns
0044 INTEGER myThid
0045
0046 C !LOCAL VARIABLES:
0047 C == Local variables ==
0048 C i,j,k,bi,bj :: loop indices.
0049 C OL[wens] :: Overlap extents in west, east, north, south.
e22a2cfed2 Jean*0050 C exchWidth[XY] :: Extent of regions that will be exchanged.
0051 C uLoc,vLoc :: copies of the vector components with haloes filled.
d4e639dc4c Jean*0052
0053 INTEGER i,j,k,bi,bj
0054 INTEGER OLw, OLe, OLn, OLs, exchWidthX, exchWidthY
e22a2cfed2 Jean*0055 _RX uLoc(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
0056 _RX vLoc(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
d4e639dc4c Jean*0057 _RX negOne
e22a2cfed2 Jean*0058 INTEGER myTile, myFace
d4e639dc4c Jean*0059 CEOP
0060
0061 OLw = OLx
0062 OLe = OLx
0063 OLn = OLy
0064 OLs = OLy
0065 exchWidthX = OLx
0066 exchWidthY = OLy
0067 negOne = 1.
0068 IF (withSigns) negOne = -1.
0069
e22a2cfed2 Jean*0070 C-- First call the exchanges for the two components
d4e639dc4c Jean*0071
8bc539472e Jean*0072 CALL EXCH2_RX1_CUBE( uPhi, .FALSE., 'T ',
d4e639dc4c Jean*0073 I OLw, OLe, OLs, OLn, myNz,
0074 I exchWidthX, exchWidthY,
1a3a8861a0 Jean*0075 I EXCH_IGNORE_CORNERS, myThid )
8bc539472e Jean*0076 CALL EXCH2_RX1_CUBE( uPhi, .FALSE., 'T ',
d4e639dc4c Jean*0077 I OLw, OLe, OLs, OLn, myNz,
0078 I exchWidthX, exchWidthY,
8bc539472e Jean*0079 I EXCH_UPDATE_CORNERS, myThid )
d4e639dc4c Jean*0080
8bc539472e Jean*0081 CALL EXCH2_RX1_CUBE( vPhi, .FALSE., 'T ',
d4e639dc4c Jean*0082 I OLw, OLe, OLs, OLn, myNz,
0083 I exchWidthX, exchWidthY,
1a3a8861a0 Jean*0084 I EXCH_IGNORE_CORNERS, myThid )
8bc539472e Jean*0085 CALL EXCH2_RX1_CUBE( vPhi, .FALSE., 'T ',
d4e639dc4c Jean*0086 I OLw, OLe, OLs, OLn, myNz,
0087 I exchWidthX, exchWidthY,
8bc539472e Jean*0088 I EXCH_UPDATE_CORNERS, myThid )
d4e639dc4c Jean*0089
0090 C- note: can substitute the low-level S/R calls above with:
e22a2cfed2 Jean*0091 c CALL EXCH2_3D_RX( uPhi, myNz, myThid )
0092 c CALL EXCH2_3D_RX( vPhi, myNz, myThid )
d4e639dc4c Jean*0093
5df640d755 Jean*0094 IF ( useCubedSphereExchange ) THEN
0095
e22a2cfed2 Jean*0096 C-- Then we may need to switch u and v components
0097 C and/or the signs depending on which cube face we are located.
d4e639dc4c Jean*0098
e22a2cfed2 Jean*0099 C-- Loops on tile indices:
d4e639dc4c Jean*0100 DO bj = myByLo(myThid), myByHi(myThid)
0101 DO bi = myBxLo(myThid), myBxHi(myThid)
e22a2cfed2 Jean*0102
8bc539472e Jean*0103 C- Choose what to do at each edge of the halo based on which face we are
5df640d755 Jean*0104 myTile = W2_myTileList(bi,bj)
e22a2cfed2 Jean*0105 myFace = exch2_myFace(myTile)
0106
0107 C-- Loops on level index:
d4e639dc4c Jean*0108 DO k = 1,myNz
0109
e22a2cfed2 Jean*0110 C- First we copy the component info into local dummy arrays
d4e639dc4c Jean*0111 DO j = 1-OLy,sNy+OLy
0112 DO i = 1-OLx,sNx+OLx
e22a2cfed2 Jean*0113 uLoc(i,j) = uPhi(i,j,k,bi,bj)
0114 vLoc(i,j) = vPhi(i,j,k,bi,bj)
d4e639dc4c Jean*0115 ENDDO
0116 ENDDO
0117
e22a2cfed2 Jean*0118 C- odd faces share disposition of all sections of the halo
0119 IF ( MOD(myFace,2).EQ.1 ) THEN
0120 C- North:
0121 IF (exch2_isNedge(myTile).EQ.1) THEN
d4e639dc4c Jean*0122 DO j = 1,exchWidthY
0123 DO i = 1-OLx,sNx+OLx
e22a2cfed2 Jean*0124 uPhi(i,sNy+j,k,bi,bj) = vLoc(i,sNy+j)*negOne
0125 vPhi(i,sNy+j,k,bi,bj) = uLoc(i,sNy+j)
d4e639dc4c Jean*0126 ENDDO
0127 ENDDO
0128 ENDIF
e22a2cfed2 Jean*0129 C- South: (nothing to change)
0130 c IF (exch2_isSedge(myTile).EQ.1) THEN
d4e639dc4c Jean*0131 c DO j = 1,exchWidthY
0132 c DO i = 1-OLx,sNx+OLx
e22a2cfed2 Jean*0133 c uPhi(i,1-j,k,bi,bj) = uLoc(i,1-j)
0134 c vPhi(i,1-j,k,bi,bj) = vLoc(i,1-j)
0135 c ENDDO
0136 c ENDDO
0137 c ENDIF
0138 C- East: (nothing to change)
0139 c IF (exch2_isEedge(myTile).EQ.1) THEN
0140 c DO j = 1-OLy,sNy+OLy
0141 c DO i = 1,exchWidthX
0142 c uPhi(sNx+i,j,k,bi,bj) = uLoc(sNx+i,j)
0143 c vPhi(sNx+i,j,k,bi,bj) = vLoc(sNx+i,j)
d4e639dc4c Jean*0144 c ENDDO
0145 c ENDDO
0146 c ENDIF
e22a2cfed2 Jean*0147 C- West:
0148 IF (exch2_isWedge(myTile).EQ.1) THEN
0149 DO j = 1-OLy,sNy+OLy
0150 DO i = 1,exchWidthX
0151 uPhi(1-i,j,k,bi,bj) = vLoc(1-i,j)
0152 vPhi(1-i,j,k,bi,bj) = uLoc(1-i,j)*negOne
0153 ENDDO
0154 ENDDO
0155 ENDIF
d4e639dc4c Jean*0156
0157 ELSE
e22a2cfed2 Jean*0158 C- Now the even faces (share disposition of all sections of the halo)
d4e639dc4c Jean*0159
e22a2cfed2 Jean*0160 C- East:
0161 IF (exch2_isEedge(myTile).EQ.1) THEN
d4e639dc4c Jean*0162 DO j = 1-OLy,sNy+OLy
0163 DO i = 1,exchWidthX
e22a2cfed2 Jean*0164 uPhi(sNx+i,j,k,bi,bj) = vLoc(sNx+i,j)
0165 vPhi(sNx+i,j,k,bi,bj) = uLoc(sNx+i,j)*negOne
d4e639dc4c Jean*0166 ENDDO
0167 ENDDO
0168 ENDIF
e22a2cfed2 Jean*0169 C- West: (nothing to change)
0170 c IF (exch2_isWedge(myTile).EQ.1) THEN
d4e639dc4c Jean*0171 c DO j = 1-OLy,sNy+OLy
0172 c DO i = 1,exchWidthX
e22a2cfed2 Jean*0173 c uPhi(1-i,j,k,bi,bj) = uLoc(1-i,j)
0174 c vPhi(1-i,j,k,bi,bj) = vLoc(1-i,j)
d4e639dc4c Jean*0175 c ENDDO
0176 c ENDDO
0177 c ENDIF
e22a2cfed2 Jean*0178 C- North: (nothing to change)
0179 c IF (exch2_isNedge(myTile).EQ.1) THEN
d4e639dc4c Jean*0180 c DO j = 1,exchWidthY
0181 c DO i = 1-OLx,sNx+OLx
e22a2cfed2 Jean*0182 c uPhi(i,sNy+j,k,bi,bj) = uLoc(i,sNy+j)
0183 c vPhi(i,sNy+j,k,bi,bj) = vLoc(i,sNy+j)
d4e639dc4c Jean*0184 c ENDDO
0185 c ENDDO
0186 c ENDIF
e22a2cfed2 Jean*0187 C- South:
0188 IF (exch2_isSedge(myTile).EQ.1) THEN
d4e639dc4c Jean*0189 DO j = 1,exchWidthY
0190 DO i = 1-OLx,sNx+OLx
e22a2cfed2 Jean*0191 uPhi(i,1-j,k,bi,bj) = vLoc(i,1-j)*negOne
0192 vPhi(i,1-j,k,bi,bj) = uLoc(i,1-j)
d4e639dc4c Jean*0193 ENDDO
0194 ENDDO
0195 ENDIF
0196
0197 C end odd / even faces
0198 ENDIF
0199
0200 C-- end of Loops on tile and level indices (k,bi,bj).
0201 ENDDO
0202 ENDDO
0203 ENDDO
0204
0205 C--- using or not using CubedSphereExchange: end
0206 ENDIF
0207
0208 RETURN
0209 END
0210
0211 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
0212
0213 CEH3 ;;; Local Variables: ***
0214 CEH3 ;;; mode:fortran ***
0215 CEH3 ;;; End: ***
