Warning, /eesupp/src/exch1_uv_rx_cube.template is written in an unsupported language. File is not indexed.
view on githubraw file Latest commit aa6b2555 on 2021-06-06 02:50:10 UTC
ba0dad37f4 Jean*0001 #include "CPP_EEOPTIONS.h"
0002
0003 CBOP
0004 C !ROUTINE: EXCH1_UV_RX_CUBE
0005
0006 C !INTERFACE:
0007 SUBROUTINE EXCH1_UV_RX_CUBE(
0008 U Uarray, Varray,
0009 I withSigns,
0010 I myOLw, myOLe, myOLs, myOLn, myNz,
0011 I exchWidthX, exchWidthY,
0012 I cornerMode, myThid )
0013
0014 C !DESCRIPTION:
aa6b2555c8 Jean*0015 C *==============================================================*
ba0dad37f4 Jean*0016 C | SUBROUTINE EXCH1_UV_RX_CUBE
0017 C | o Forward-mode edge exchanges for RX vector on CS config.
aa6b2555c8 Jean*0018 C *==============================================================*
ba0dad37f4 Jean*0019 C | Controlling routine for exchange of XY edges of an array
aa6b2555c8 Jean*0020 C | distributed in X and Y.
0021 C | This is a preliminary (exch1), simpler version with few
0022 C | limitations (no MPI, 1 tile per face, regular 6 squared faces,
0023 C | multi-threads only on shared arrays, i.e., in commom block)
0024 C | that are fixed in generalised pkg/exch2 implementation.
0025 C | Notes:
0026 C | Exchanges on the cube of vector quantities need to be
0027 C | paired to allow rotations and sign reversal to be applied
0028 C | consistently between vector components as they rotate.
0029 C *==============================================================*
ba0dad37f4 Jean*0030
0031 C !USES:
0032 IMPLICIT NONE
0033
0034 C == Global data ==
0035 #include "SIZE.h"
0036 #include "EEPARAMS.h"
0037
0038 C !INPUT/OUTPUT PARAMETERS:
0039 C == Routine arguments ==
0040 C Uarray :: (u-type) Array with edges to exchange.
0041 C Varray :: (v-type) Array with edges to exchange.
0042 C withSigns :: sign of Uarray,Varray depends on orientation
0043 C myOLw,myOLe :: West and East overlap region sizes.
0044 C myOLs,myOLn :: South and North overlap region sizes.
0045 C exchWidthX :: Width of data region exchanged in X.
0046 C exchWidthY :: Width of data region exchanged in Y.
0047 C Note --
0048 C 1. In theory one could have a send width and
0049 C a receive width for each face of each tile. The only
0050 C restriction would be that the send width of one
0051 C face should equal the receive width of the sent to
0052 C tile face. Dont know if this would be useful. I
0053 C have left it out for now as it requires additional
0054 C bookeeping.
0055 C cornerMode :: Flag indicating whether corner updates are needed.
0056 C myThid :: my Thread Id number
0057
0058 INTEGER myOLw, myOLe, myOLs, myOLn, myNz
0059 _RX Uarray( 1-myOLw:sNx+myOLe,
0060 & 1-myOLs:sNy+myOLn,
0061 & myNz, nSx, nSy )
0062 _RX Varray( 1-myOLw:sNx+myOLe,
0063 & 1-myOLs:sNy+myOLn,
0064 & myNz, nSx, nSy )
0065 LOGICAL withSigns
0066 INTEGER exchWidthX
0067 INTEGER exchWidthY
0068 INTEGER cornerMode
0069 INTEGER myThid
0070
0071 C !LOCAL VARIABLES:
0072 C == Local variables ==
0073 C theSimulationMode :: Holds working copy of simulation mode
0074 C theCornerMode :: Holds working copy of corner mode
0075 C I,J,K :: Loop and index counters
0076 C bl,bt,bn,bs,be,bw :: tile indices
0077 C negOne, Utmp,Vtmp :: Temps used in swapping and rotating vectors
0078 c INTEGER theSimulationMode
0079 c INTEGER theCornerMode
0080 INTEGER I,J,K, repeat
0081 INTEGER bl,bt,bn,bs,be,bw
0082 CHARACTER*(MAX_LEN_MBUF) msgBuf
0083 _RX negOne, Utmp, Vtmp
0084
0085 C == Statement function ==
0086 C tilemod :: Permutes indices to return neighboring tile index
0087 C on six face cube.
0088 INTEGER tilemod
0089 tilemod(I)=1+mod(I-1+6,6)
0090 CEOP
0091
0092 c theSimulationMode = FORWARD_SIMULATION
0093 c theCornerMode = cornerMode
0094
0095 c IF ( simulationMode.EQ.REVERSE_SIMULATION ) THEN
0096 c WRITE(msgBuf,'(A)')'EXCH1_UV_RX_CUBE: AD mode not implemented'
0097 c CALL PRINT_ERROR( msgBuf, myThid )
0098 c STOP 'ABNORMAL END: EXCH1_UV_RX_CUBE: no AD code'
0099 c ENDIF
0100 IF ( sNx.NE.sNy .OR.
0101 & nSx.NE.6 .OR. nSy.NE.1 .OR.
0102 & nPx.NE.1 .OR. nPy.NE.1 ) THEN
0103 WRITE(msgBuf,'(2A)') 'EXCH1_UV_RX_CUBE: Wrong Tiling'
0104 CALL PRINT_ERROR( msgBuf, myThid )
0105 WRITE(msgBuf,'(2A)') 'EXCH1_UV_RX_CUBE: ',
0106 & 'works only with sNx=sNy & nSx=6 & nSy=nPx=nPy=1'
0107 CALL PRINT_ERROR( msgBuf, myThid )
0108 STOP 'ABNORMAL END: EXCH1_UV_RX_CUBE: Wrong Tiling'
0109 ENDIF
0110
0111 negOne = 1.
0112 IF (withSigns) negOne = -1.
0113
0114 C For now tile<->tile exchanges are sequentialised through
0115 C thread 1. This is a temporary feature for preliminary testing until
0116 C general tile decomposistion is in place (CNH April 11, 2001)
0117 CALL BAR2( myThid )
0118 IF ( myThid .EQ. 1 ) THEN
0119
0120 DO repeat=1,2
0121
0122 DO bl = 1, 5, 2
0123
0124 bt = bl
0125 bn=tilemod(bt+2)
0126 bs=tilemod(bt-1)
0127 be=tilemod(bt+1)
0128 bw=tilemod(bt-2)
0129
0130 DO K = 1,myNz
0131
0132 C Tile Odd:Odd+2 [get] [North<-West]
0133 DO J = 1,sNy+1
0134 DO I = 1,exchWidthX
0135 Uarray(J,sNy+I,K,bt,1) = negOne*Varray(I,sNy+2-J,K,bn,1)
0136 ENDDO
0137 ENDDO
0138 DO J = 1,sNy
0139 DO I = 1,exchWidthX
0140 Varray(J,sNy+I,K,bt,1) = Uarray(I,sNy+1-J,K,bn,1)
0141 ENDDO
0142 ENDDO
0143 C Tile Odd:Odd-1 [get] [South<-North]
0144 DO J = 1,sNy+1
0145 DO I = 1,exchWidthX
0146 Uarray(J,1-I,K,bt,1) = Uarray(J,sNy+1-I,K,bs,1)
0147 ENDDO
0148 ENDDO
0149 DO J = 1,sNy
0150 DO I = 1,exchWidthX
0151 Varray(J,1-I,K,bt,1) = Varray(J,sNy+1-I,K,bs,1)
0152 ENDDO
0153 ENDDO
0154 C Tile Odd:Odd+1 [get] [East<-West]
0155 DO J = 1,sNy
0156 DO I = 1,exchWidthX
0157 Uarray(sNx+I,J,K,bt,1) = Uarray(I,J,K,be,1)
0158 ENDDO
0159 ENDDO
0160 DO J = 1,sNy+1
0161 DO I = 1,exchWidthX
0162 Varray(sNx+I,J,K,bt,1) = Varray(I,J,K,be,1)
0163 ENDDO
0164 ENDDO
0165 C Tile Odd:Odd-2 [get] [West<-North]
0166 DO J = 1,sNy
0167 DO I = 1,exchWidthX
0168 Uarray(1-I,J,K,bt,1) = Varray(sNx+1-J,sNy+1-I,K,bw,1)
0169 ENDDO
0170 ENDDO
0171 DO J = 1,sNy+1
0172 DO I = 1,exchWidthX
0173 Varray(1-I,J,K,bt,1) = negOne*Uarray(sNx+2-J,sNy+1-I,K,bw,1)
0174 ENDDO
0175 ENDDO
0176
aa6b2555c8 Jean*0177 C-- end "K" loop
ba0dad37f4 Jean*0178 ENDDO
0179
0180 bt = bl+1
0181 bn=tilemod(bt+1)
0182 bs=tilemod(bt-2)
0183 be=tilemod(bt+2)
0184 bw=tilemod(bt-1)
0185
0186 DO K = 1,myNz
0187
0188 C Tile Even:Even+1 [get] [North<-South]
0189 DO J = 1,sNy+1
0190 DO I = 1,exchWidthX
0191 Uarray(J,sNy+I,K,bt,1) = Uarray(J,I,K,bn,1)
0192 ENDDO
0193 ENDDO
0194 DO J = 1,sNy
0195 DO I = 1,exchWidthX
0196 Varray(J,sNy+I,K,bt,1) = Varray(J,I,K,bn,1)
0197 ENDDO
0198 ENDDO
0199 C Tile Even:Even-2 [get] [South<-East]
0200 DO J = 1,sNy+1
0201 DO I = 1,exchWidthX
0202 Uarray(J,1-I,K,bt,1) = negOne*Varray(sNx+1-I,sNy+2-J,K,bs,1)
0203 ENDDO
0204 ENDDO
0205 DO J = 1,sNy
0206 DO I = 1,exchWidthX
0207 Varray(J,1-I,K,bt,1) = Uarray(sNx+1-I,sNy+1-J,K,bs,1)
0208 ENDDO
0209 ENDDO
0210 C Tile Even:Even+2 [get] [East<-South]
0211 DO J = 1,sNy
0212 DO I = 1,exchWidthX
0213 Uarray(sNx+I,J,K,bt,1) = Varray(sNx+1-J,I,K,be,1)
0214 ENDDO
0215 ENDDO
0216 DO J = 1,sNy+1
0217 DO I = 1,exchWidthX
0218 Varray(sNx+I,J,K,bt,1) = negOne*Uarray(sNx+2-J,I,K,be,1)
0219 ENDDO
0220 ENDDO
0221 C Tile Even:Even-1 [get] [West<-East]
0222 DO J = 1,sNy
0223 DO I = 1,exchWidthX
0224 Uarray(1-I,J,K,bt,1) = Uarray(sNx+1-I,J,K,bw,1)
0225 ENDDO
0226 ENDDO
0227 DO J = 1,sNy+1
0228 DO I = 1,exchWidthX
0229 Varray(1-I,J,K,bt,1) = Varray(sNx+1-I,J,K,bw,1)
0230 ENDDO
0231 ENDDO
0232
aa6b2555c8 Jean*0233 C-- end "K" loop
ba0dad37f4 Jean*0234 ENDDO
0235
aa6b2555c8 Jean*0236 C-- end "bl" loop
ba0dad37f4 Jean*0237 ENDDO
0238
aa6b2555c8 Jean*0239 IF ( OLx.GE.2 .AND. OLy.GE.2 ) THEN
ba0dad37f4 Jean*0240 C- Add one valid uVel,vVel value next to the corner, that allows
aa6b2555c8 Jean*0241 C to compute vorticity on a wider stencil (e.g., vort3(0,1) & (1,0))
0242 DO bt = 1,6
0243 DO K = 1,myNz
ba0dad37f4 Jean*0244 C SW corner:
0245 Uarray(0,0,K,bt,1)=Varray(1,0,K,bt,1)
0246 Varray(0,0,K,bt,1)=Uarray(0,1,K,bt,1)
0247 C NW corner:
0248 Uarray(0,sNy+1,K,bt,1)= negOne*Varray(1,sNy+2,K,bt,1)
0249 Varray(0,sNy+2,K,bt,1)= negOne*Uarray(0,sNy,K,bt,1)
0250 C SE corner:
0251 Uarray(sNx+2,0,K,bt,1)= negOne*Varray(sNx,0,K,bt,1)
0252 Varray(sNx+1,0,K,bt,1)= negOne*Uarray(sNx+2,1,K,bt,1)
0253 C NE corner:
0254 Uarray(sNx+2,sNy+1,K,bt,1)=Varray(sNx,sNy+2,K,bt,1)
0255 Varray(sNx+1,sNy+2,K,bt,1)=Uarray(sNx+2,sNy,K,bt,1)
aa6b2555c8 Jean*0256 ENDDO
ba0dad37f4 Jean*0257 ENDDO
aa6b2555c8 Jean*0258 ENDIF
ba0dad37f4 Jean*0259
0260 C Fix degeneracy at corners
0261 IF (.FALSE.) THEN
0262 c IF (withSigns) THEN
0263 DO bt = 1, 6
0264 DO K = 1,myNz
0265 C Top left
0266 Utmp=0.5*(Uarray(1,sNy,K,bt,1)+Uarray(0,sNy,K,bt,1))
0267 Vtmp=0.5*(Varray(0,sNy+1,K,bt,1)+Varray(0,sNy,K,bt,1))
0268 Varray(0,sNx+1,K,bt,1)=(Vtmp-Utmp)*0.70710678
0269 Utmp=0.5*(Uarray(1,sNy+1,K,bt,1)+Uarray(2,sNy+1,K,bt,1))
0270 Vtmp=0.5*(Varray(1,sNy+1,K,bt,1)+Varray(1,sNy+2,K,bt,1))
0271 Uarray(1,sNy+1,K,bt,1)=(Utmp-Vtmp)*0.70710678
0272 C Bottom right
0273 Utmp=0.5*(Uarray(sNx+1,1,K,bt,1)+Uarray(sNx+2,1,K,bt,1))
0274 Vtmp=0.5*(Varray(sNx+1,1,K,bt,1)+Varray(sNx+1,2,K,bt,1))
0275 Varray(sNx+1,1,K,bt,1)=(Vtmp-Utmp)*0.70710678
0276 Utmp=0.5*(Uarray(sNx+1,0,K,bt,1)+Uarray(sNx,0,K,bt,1))
0277 Vtmp=0.5*(Varray(sNx,1,K,bt,1)+Varray(sNx,0,K,bt,1))
0278 Uarray(sNx+1,0,K,bt,1)=(Utmp-Vtmp)*0.70710678
0279 C Bottom left
0280 Utmp=0.5*(Uarray(1,1,K,bt,1)+Uarray(0,1,K,bt,1))
0281 Vtmp=0.5*(Varray(0,1,K,bt,1)+Varray(0,2,K,bt,1))
0282 Varray(0,1,K,bt,1)=(Vtmp+Utmp)*0.70710678
0283 Utmp=0.5*(Uarray(1,0,K,bt,1)+Uarray(2,0,K,bt,1))
0284 Vtmp=0.5*(Varray(1,1,K,bt,1)+Varray(1,0,K,bt,1))
0285 Uarray(1,0,K,bt,1)=(Utmp+Vtmp)*0.70710678
0286 C Top right
0287 Utmp=0.5*(Uarray(sNx+1,sNy,K,bt,1)+Uarray(sNx+2,sNy,K,bt,1))
0288 Vtmp=0.5*(Varray(sNx+1,sNy+1,K,bt,1)+Varray(sNx+1,sNy,K,bt,1))
0289 Varray(sNx+1,sNy+1,K,bt,1)=(Vtmp+Utmp)*0.70710678
0290 Utmp=0.5*(Uarray(sNx+1,sNy+1,K,bt,1)+Uarray(sNx,sNy+1,K,bt,1))
0291 Vtmp=0.5*(Varray(sNx,sNy+1,K,bt,1)+Varray(sNx,sNy+2,K,bt,1))
0292 Uarray(sNx+1,sNy+1,K,bt,1)=(Utmp+Vtmp)*0.70710678
0293 ENDDO
0294 ENDDO
0295 ENDIF
0296
aa6b2555c8 Jean*0297 C-- end "repeat" loop
ba0dad37f4 Jean*0298 ENDDO
0299
0300 ENDIF
0301 CALL BAR2(myThid)
0302
0303 RETURN
0304 END
