| 1 |
C $Header: /u/gcmpack/MITgcm/pkg/exch2/w2_set_tile2tiles.F,v 1.4 2010/12/22 21:22:46 jahn Exp $ |
| 2 |
C $Name: $ |
| 3 |
|
| 4 |
#include "CPP_EEOPTIONS.h" |
| 5 |
#include "W2_OPTIONS.h" |
| 6 |
|
| 7 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
| 8 |
CBOP 0 |
| 9 |
C !ROUTINE: W2_SET_TILE2TILES |
| 10 |
|
| 11 |
C !INTERFACE: |
| 12 |
SUBROUTINE W2_SET_TILE2TILES( myThid ) |
| 13 |
|
| 14 |
C !DESCRIPTION: |
| 15 |
C Set-up tile neighbours and index relations for EXCH2. |
| 16 |
|
| 17 |
C !USES: |
| 18 |
IMPLICIT NONE |
| 19 |
|
| 20 |
C Tile topology settings data structures |
| 21 |
#include "SIZE.h" |
| 22 |
#include "EEPARAMS.h" |
| 23 |
#include "W2_EXCH2_SIZE.h" |
| 24 |
#include "W2_EXCH2_PARAMS.h" |
| 25 |
#include "W2_EXCH2_TOPOLOGY.h" |
| 26 |
|
| 27 |
C !INPUT PARAMETERS: |
| 28 |
C myThid :: my Thread Id number |
| 29 |
C (Note: not relevant since threading has not yet started) |
| 30 |
INTEGER myThid |
| 31 |
|
| 32 |
C !LOCAL VARIABLES: |
| 33 |
C === Local variables === |
| 34 |
C msgBuf :: Informational/error message buffer |
| 35 |
C tile_edge2edge(nId,tId) :: Tile edge to edge connection (of tile "tId" |
| 36 |
C and neighbour "nId"): |
| 37 |
C 1rst digit gives local tile Edge (10,20,30,40 <==> N,S,E,W) |
| 38 |
C 2nd digit gives remote tile Edge (1,2,3,4 <==> N,S,E,W) |
| 39 |
C corresponding to this neighbour connection. |
| 40 |
INTEGER tile_edge2edge( W2_maxNeighbours, W2_maxNbTiles ) |
| 41 |
CHARACTER*(MAX_LEN_MBUF) msgBuf |
| 42 |
INTEGER tNx, tNy, nbTx, nbNeighb |
| 43 |
INTEGER i, k, ii, nn |
| 44 |
INTEGER is, js, ns, it, jt, nt, tx, ty |
| 45 |
INTEGER iLo, iHi, jLo, jHi |
| 46 |
INTEGER ii1, ii2, jj1, jj2, ddi, ddj |
| 47 |
INTEGER ibnd1, ibnd2, jbnd1, jbnd2 |
| 48 |
INTEGER itbd1, itbd2, jtbd1, jtbd2 |
| 49 |
INTEGER isbd1, isbd2, jsbd1, jsbd2 |
| 50 |
INTEGER txbnd1, txbnd2, tybnd1, tybnd2 |
| 51 |
INTEGER errCnt |
| 52 |
LOGICAL internConnect, prtFlag |
| 53 |
CEOP |
| 54 |
|
| 55 |
WRITE(msgBuf,'(2A)') 'W2_SET_TILE2TILES:', |
| 56 |
& ' tile neighbours and index connection:' |
| 57 |
CALL PRINT_MESSAGE( msgBuf, W2_oUnit, SQUEEZE_RIGHT, myThid ) |
| 58 |
prtFlag = ABS(W2_printMsg).GE.2 |
| 59 |
& .OR. ( W2_printMsg .NE.0 .AND. myProcId.EQ.0 ) |
| 60 |
|
| 61 |
C-- Initialise local arrays |
| 62 |
DO is=1,W2_maxNbTiles |
| 63 |
DO ns=1,W2_maxNeighbours |
| 64 |
tile_edge2edge(ns,is) = 0 |
| 65 |
exch2_neighbourDir(ns,is) = 0 |
| 66 |
ENDDO |
| 67 |
ENDDO |
| 68 |
|
| 69 |
tNx = sNx |
| 70 |
tNy = sNy |
| 71 |
DO is=1,exch2_nTiles |
| 72 |
js = exch2_myFace(is) |
| 73 |
C test "myFace" for blank tile; no need for connection if tile is blank |
| 74 |
IF ( js.NE.0 ) THEN |
| 75 |
js = exch2_myFace(is) |
| 76 |
iLo = exch2_tBasex(is)+1 |
| 77 |
iHi = exch2_tBasex(is)+exch2_tNx(is) |
| 78 |
jLo = exch2_tBasey(is)+1 |
| 79 |
jHi = exch2_tBasey(is)+exch2_tNy(is) |
| 80 |
|
| 81 |
nbNeighb = 0 |
| 82 |
DO i=1,4 |
| 83 |
ii1 = iLo |
| 84 |
ii2 = iHi |
| 85 |
jj1 = jLo |
| 86 |
jj2 = jHi |
| 87 |
IF ( i.EQ.1 ) THEN |
| 88 |
C-- Northern Edge: [iLo:iHi,jHi] |
| 89 |
jj1 = jHi+1 |
| 90 |
jj2 = jHi+1 |
| 91 |
internConnect = jHi.LT.exch2_mydNy(is) |
| 92 |
IF ( .NOT.internConnect ) exch2_isNedge(is) = 1 |
| 93 |
ELSEIF ( i.EQ.2 ) THEN |
| 94 |
C-- Southern Edge: [iLo:iHi,jLo] |
| 95 |
jj1 = jLo-1 |
| 96 |
jj2 = jLo-1 |
| 97 |
internConnect = jLo.GT.1 |
| 98 |
IF ( .NOT.internConnect ) exch2_isSedge(is) = 1 |
| 99 |
ELSEIF ( i.EQ.3 ) THEN |
| 100 |
C-- Eastern Edge: [iHi,jLo:jHi] |
| 101 |
ii1 = iHi+1 |
| 102 |
ii2 = iHi+1 |
| 103 |
internConnect = iHi.LT.exch2_mydNx(is) |
| 104 |
IF ( .NOT.internConnect ) exch2_isEedge(is) = 1 |
| 105 |
ELSE |
| 106 |
C-- Western Edge: [iLo,jLo:jHi] |
| 107 |
ii1 = iLo-1 |
| 108 |
ii2 = iLo-1 |
| 109 |
internConnect = iLo.GT.1 |
| 110 |
IF ( .NOT.internConnect ) exch2_isWedge(is) = 1 |
| 111 |
ENDIF |
| 112 |
ddi = MIN( ii2-ii1, 1) |
| 113 |
ddj = MIN( jj2-jj1, 1) |
| 114 |
|
| 115 |
IF ( internConnect ) THEN |
| 116 |
C--- Internal (from the same facet) |
| 117 |
C- N(i=1) -> S(ii=2); S(i=2) -> N(ii=1); E(i=3) -> W(ii=4); W(i=4) -> E(ii=3) |
| 118 |
C- get tile neighbour Id "it": |
| 119 |
nbTx = facet_dims(2*js-1)/tNx |
| 120 |
ii = 1 + MOD(i,2) |
| 121 |
it = 2*ii - 3 |
| 122 |
IF ( i.LE.2 ) THEN |
| 123 |
it = is + it*nbTx |
| 124 |
ELSE |
| 125 |
it = is + it |
| 126 |
ii = ii + 2 |
| 127 |
ENDIF |
| 128 |
IF ( exch2_myFace(it).NE.0 ) THEN |
| 129 |
nbNeighb = nbNeighb + 1 |
| 130 |
ns = MIN(nbNeighb,W2_maxNeighbours) |
| 131 |
exch2_neighbourId(ns,is) = it |
| 132 |
tile_edge2edge(ns,is) = 10*i + ii |
| 133 |
exch2_pij(1,ns,is) = 1 |
| 134 |
exch2_pij(2,ns,is) = 0 |
| 135 |
exch2_pij(3,ns,is) = 0 |
| 136 |
exch2_pij(4,ns,is) = 1 |
| 137 |
exch2_oi(ns,is) = 0 |
| 138 |
exch2_oj(ns,is) = 0 |
| 139 |
exch2_iLo(ns,is) = ii1 - ddi - exch2_tBasex(is) |
| 140 |
exch2_iHi(ns,is) = ii2 + ddi - exch2_tBasex(is) |
| 141 |
exch2_jLo(ns,is) = jj1 - ddj - exch2_tBasey(is) |
| 142 |
exch2_jHi(ns,is) = jj2 + ddj - exch2_tBasey(is) |
| 143 |
ENDIF |
| 144 |
|
| 145 |
ELSE |
| 146 |
|
| 147 |
C--- External (from an other facet) |
| 148 |
jt = INT(facet_link(i,js)) |
| 149 |
ii = MOD( NINT(facet_link(i,js)*10.), 10 ) |
| 150 |
IF ( jt.GT.0 ) THEN |
| 151 |
C-- needs to find list of tiles in target facet "jt" which connect to "is" |
| 152 |
C- index range on target facet: |
| 153 |
ibnd1 = facet_pij(1,ii,jt)*ii1 |
| 154 |
& + facet_pij(2,ii,jt)*jj1 + facet_oi(ii,jt) |
| 155 |
ibnd2 = facet_pij(1,ii,jt)*ii2 |
| 156 |
& + facet_pij(2,ii,jt)*jj2 + facet_oi(ii,jt) |
| 157 |
jbnd1 = facet_pij(3,ii,jt)*ii1 |
| 158 |
& + facet_pij(4,ii,jt)*jj1 + facet_oj(ii,jt) |
| 159 |
jbnd2 = facet_pij(3,ii,jt)*ii2 |
| 160 |
& + facet_pij(4,ii,jt)*jj2 + facet_oj(ii,jt) |
| 161 |
C- at least 1 index bnd is common (either ibnd1=ibnd2 or jbnd1=jbnd2) |
| 162 |
IF ( ibnd1.LE.ibnd2 ) THEN |
| 163 |
txbnd1 = ( ibnd1 -1 )/tNx |
| 164 |
txbnd2 = ( ibnd2 -1 )/tNx |
| 165 |
ELSE |
| 166 |
txbnd1 = ( ibnd2 -1 )/tNx |
| 167 |
txbnd2 = ( ibnd1 -1 )/tNx |
| 168 |
ENDIF |
| 169 |
IF ( jbnd1.LE.jbnd2 ) THEN |
| 170 |
tybnd1 = ( jbnd1 -1 )/tNy |
| 171 |
tybnd2 = ( jbnd2 -1 )/tNy |
| 172 |
ELSE |
| 173 |
tybnd1 = ( jbnd2 -1 )/tNy |
| 174 |
tybnd2 = ( jbnd1 -1 )/tNy |
| 175 |
ENDIF |
| 176 |
nbTx = facet_dims(2*jt-1)/tNx |
| 177 |
DO ty=tybnd1,tybnd2 |
| 178 |
DO tx=txbnd1,txbnd2 |
| 179 |
it = facet_owns(1,jt) + tx + ty*nbTx |
| 180 |
IF ( exch2_myFace(it).NE.0 ) THEN |
| 181 |
C- Save to common block this neighbour connection : |
| 182 |
nbNeighb = nbNeighb + 1 |
| 183 |
ns = MIN(nbNeighb,W2_maxNeighbours) |
| 184 |
exch2_neighbourId(ns,is) = it |
| 185 |
tile_edge2edge(ns,is) = 10*i + ii |
| 186 |
DO k=1,4 |
| 187 |
exch2_pij(k,ns,is) = facet_pij(k,i,js) |
| 188 |
ENDDO |
| 189 |
exch2_oi(ns,is) = facet_oi(i,js) |
| 190 |
exch2_oj(ns,is) = facet_oj(i,js) |
| 191 |
C Edge length to be exchanged between tiles is & it: |
| 192 |
itbd1 = MIN( MAX( ibnd1, exch2_tBasex(it)+1 ), |
| 193 |
& exch2_tBasex(it)+tNx ) |
| 194 |
itbd2 = MIN( MAX( ibnd2, exch2_tBasex(it)+1 ), |
| 195 |
& exch2_tBasex(it)+tNx ) |
| 196 |
jtbd1 = MIN( MAX( jbnd1, exch2_tBasey(it)+1 ), |
| 197 |
& exch2_tBasey(it)+tNy ) |
| 198 |
jtbd2 = MIN( MAX( jbnd2, exch2_tBasey(it)+1 ), |
| 199 |
& exch2_tBasey(it)+tNy ) |
| 200 |
isbd1 = facet_pij(1,i,js)*itbd1 |
| 201 |
& + facet_pij(2,i,js)*jtbd1 + facet_oi(i,js) |
| 202 |
isbd2 = facet_pij(1,i,js)*itbd2 |
| 203 |
& + facet_pij(2,i,js)*jtbd2 + facet_oi(i,js) |
| 204 |
jsbd1 = facet_pij(3,i,js)*itbd1 |
| 205 |
& + facet_pij(4,i,js)*jtbd1 + facet_oj(i,js) |
| 206 |
jsbd2 = facet_pij(3,i,js)*itbd2 |
| 207 |
& + facet_pij(4,i,js)*jtbd2 + facet_oj(i,js) |
| 208 |
exch2_iLo(ns,is) = isbd1 - ddi - exch2_tBasex(is) |
| 209 |
exch2_iHi(ns,is) = isbd2 + ddi - exch2_tBasex(is) |
| 210 |
exch2_jLo(ns,is) = jsbd1 - ddj - exch2_tBasey(is) |
| 211 |
exch2_jHi(ns,is) = jsbd2 + ddj - exch2_tBasey(is) |
| 212 |
C- end active tile "it" |
| 213 |
ENDIF |
| 214 |
C- end loops on tile indices tx,ty |
| 215 |
ENDDO |
| 216 |
ENDDO |
| 217 |
C- end active connection (it > 0) |
| 218 |
ENDIF |
| 219 |
C- end internal/external connection |
| 220 |
ENDIF |
| 221 |
C- end N,S,E,W Edge loop |
| 222 |
ENDDO |
| 223 |
exch2_nNeighbours(is) = nbNeighb |
| 224 |
IF ( prtFlag ) THEN |
| 225 |
WRITE(W2_oUnit,'(A,I5,A,I3,A,4(A,I2))') |
| 226 |
& 'Tile',is,' : nbNeighb=',nbNeighb,' ; is-at-Facet-Edge:', |
| 227 |
& ' N=', exch2_isNedge(is), ' , S=', exch2_isSedge(is), |
| 228 |
& ' , E=', exch2_isEedge(is), ' , W=', exch2_isWedge(is) |
| 229 |
DO ns=1,MIN(nbNeighb,W2_maxNeighbours) |
| 230 |
WRITE(W2_oUnit,'(A,I3,A,I5,2(A,2I6),A,4I3,A,2I6,A)') |
| 231 |
& ' ns:',ns,' it=',exch2_neighbourId(ns,is), |
| 232 |
& ', iLo,iHi=', exch2_iLo(ns,is), exch2_iHi(ns,is), |
| 233 |
& ', jLo,jHi=', exch2_jLo(ns,is), exch2_jHi(ns,is) |
| 234 |
c & , ' (pij=',(exch2_pij(k,ns,is),k=1,4), |
| 235 |
c & ', oi,oj=', exch2_oi(ns,is), exch2_oj(ns,is),')' |
| 236 |
ENDDO |
| 237 |
ENDIF |
| 238 |
C- end active tile "is" |
| 239 |
ENDIF |
| 240 |
C- end loop on tile "is" |
| 241 |
ENDDO |
| 242 |
|
| 243 |
C- Check nbNeighb =< W2_maxNeighbours |
| 244 |
nbNeighb = 0 |
| 245 |
it = 0 |
| 246 |
DO is=1,exch2_nTiles |
| 247 |
IF ( exch2_nNeighbours(is).GT.nbNeighb ) THEN |
| 248 |
nbNeighb = exch2_nNeighbours(is) |
| 249 |
it = is |
| 250 |
ENDIF |
| 251 |
ENDDO |
| 252 |
WRITE(msgBuf,'(A,I5,A,I3)') |
| 253 |
& 'current Max.Nb.Neighbours (e.g., on tile',it,' ) =',nbNeighb |
| 254 |
CALL PRINT_MESSAGE( msgBuf, W2_oUnit, SQUEEZE_RIGHT, myThid ) |
| 255 |
IF ( nbNeighb.GT.W2_maxNeighbours ) THEN |
| 256 |
WRITE(msgBuf,'(2(A,I4),A)') |
| 257 |
& 'W2_SET_TILE2TILES: Max.Nb.Neighbours=', nbNeighb, |
| 258 |
& ' >', W2_maxNeighbours,' =W2_maxNeighbours' |
| 259 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 260 |
WRITE(msgBuf,'(2A)') 'Must increase "W2_maxNeighbours"', |
| 261 |
& ' in "W2_EXCH2_SIZE.h" + recompile' |
| 262 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 263 |
STOP 'ABNORMAL END: S/R W2_SET_TILE2TILES (W2_maxNeighbours)' |
| 264 |
ENDIF |
| 265 |
|
| 266 |
C- Set exch2_opposingSend(ns,is) = Neighbour Id (in list of neighbours |
| 267 |
C of tile exch2_neighbourId(ns,is)) which is connected to tile "is" |
| 268 |
C neighbour Id "ns" with matching edge <-> edge connection (ii==i). |
| 269 |
errCnt = 0 |
| 270 |
DO is=1,exch2_nTiles |
| 271 |
DO ns=1,exch2_nNeighbours(is) |
| 272 |
i = tile_edge2edge(ns,is)/10 |
| 273 |
ii = MOD(tile_edge2edge(ns,is),10) |
| 274 |
IF ( ii .NE. 0) THEN |
| 275 |
exch2_neighbourDir(ns,is) = i |
| 276 |
ENDIF |
| 277 |
it = exch2_neighbourId(ns,is) |
| 278 |
DO nt=1,exch2_nNeighbours(it) |
| 279 |
c i = tile_edge2edge(nt,it)/10 |
| 280 |
ii = MOD(tile_edge2edge(nt,it),10) |
| 281 |
IF ( exch2_neighbourId(nt,it).EQ.is .AND. ii.EQ.i ) THEN |
| 282 |
IF ( exch2_opposingSend(ns,is).EQ.0 ) THEN |
| 283 |
exch2_opposingSend(ns,is) = nt |
| 284 |
ELSE |
| 285 |
nn = exch2_opposingSend(ns,is) |
| 286 |
WRITE(msgBuf,'(A,I5,2(A,I3),A,I5)') 'Tile',is,' neighb:', |
| 287 |
& ns,' (',tile_edge2edge(ns,is),' ) has multiple connection' |
| 288 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 289 |
WRITE(msgBuf,'(A,I5,5(A,I3))') ' with tile', it, ' :', |
| 290 |
& nn,' (',tile_edge2edge(nn,it),' ) and', |
| 291 |
& nt,' (',tile_edge2edge(nt,it),' )' |
| 292 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 293 |
errCnt = errCnt + 1 |
| 294 |
ENDIF |
| 295 |
ENDIF |
| 296 |
ENDDO |
| 297 |
IF ( exch2_opposingSend(ns,is).EQ.0 ) THEN |
| 298 |
WRITE(msgBuf,'(A,I5,2(A,I3),A,I5)') 'Tile',is,' neighb:', |
| 299 |
& ns,' (',tile_edge2edge(ns,is),' ) no connection from',it |
| 300 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 301 |
errCnt = errCnt + 1 |
| 302 |
ENDIF |
| 303 |
|
| 304 |
ENDDO |
| 305 |
ENDDO |
| 306 |
IF ( errCnt.GT.0 ) THEN |
| 307 |
WRITE(msgBuf,'(A,I3,A)') |
| 308 |
& ' W2_SET_TILE2TILES: found', errCnt, ' Dbl/No connection' |
| 309 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 310 |
STOP 'ABNORMAL END: S/R W2_SET_TILE2TILES (tile connection)' |
| 311 |
ENDIF |
| 312 |
C-- Check opposingSend reciprocity: |
| 313 |
errCnt = 0 |
| 314 |
DO is=1,exch2_nTiles |
| 315 |
DO ns=1,exch2_nNeighbours(is) |
| 316 |
it = exch2_neighbourId(ns,is) |
| 317 |
nt = exch2_opposingSend(ns,is) |
| 318 |
ii = exch2_neighbourId(nt,it) |
| 319 |
nn = exch2_opposingSend(nt,it) |
| 320 |
IF ( ii.NE.is .OR. nn.NE.ns ) THEN |
| 321 |
WRITE(msgBuf,'(A,I5,2(A,I3),A)') 'Tile',is,' neighb:', |
| 322 |
& ns,' (',tile_edge2edge(ns,is),' ) connected' |
| 323 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 324 |
WRITE(msgBuf,'(A,I5,5(A,I3))') ' with tile', it, ' :', |
| 325 |
& nt,' (',tile_edge2edge(nt,it),' )' |
| 326 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 327 |
WRITE(msgBuf,'(A,I5,2(A,I3),A)') ' but',it,' neighb:', |
| 328 |
& nt,' (',tile_edge2edge(nt,it),' ) connected' |
| 329 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 330 |
WRITE(msgBuf,'(A,I5,3(A,I3))') ' with tile', ii, ' :', |
| 331 |
& nn,' (',tile_edge2edge(nn,ii),' )' |
| 332 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 333 |
errCnt = errCnt + 1 |
| 334 |
ENDIF |
| 335 |
ENDDO |
| 336 |
ENDDO |
| 337 |
IF ( errCnt.GT.0 ) THEN |
| 338 |
WRITE(msgBuf,'(A,I3,A)') |
| 339 |
& ' W2_SET_TILE2TILES: found', errCnt, ' opposingSend error' |
| 340 |
CALL PRINT_ERROR( msgBuf, myThid ) |
| 341 |
STOP 'ABNORMAL END: S/R W2_SET_TILE2TILES (opposingSend)' |
| 342 |
ENDIF |
| 343 |
|
| 344 |
RETURN |
| 345 |
END |
Parent Directory
| 
Revision Log
| 
Revision Graph