pkg/exch2/w2_set_tile2tiles.F

017b6b2289 Jean*0001 #include "CPP_EEOPTIONS.h"
                0002 #include "W2_OPTIONS.h"
                0003
                0004 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0005 CBOP 0
                0006 C !ROUTINE: W2_SET_TILE2TILES
                0007
                0008 C !INTERFACE:
                0009       SUBROUTINE W2_SET_TILE2TILES( myThid )
                0010
                0011 C     !DESCRIPTION:
                0012 C     Set-up tile neighbours and index relations for EXCH2.
                0013
                0014 C     !USES:
                0015       IMPLICIT NONE
                0016
d6ea3164dc Jean*0017 C      Tile topology settings data structures
017b6b2289 Jean*0018 #include "SIZE.h"
                0019 #include "EEPARAMS.h"
                0020 #include "W2_EXCH2_SIZE.h"
                0021 #include "W2_EXCH2_PARAMS.h"
                0022 #include "W2_EXCH2_TOPOLOGY.h"
                0023
                0024 C     !INPUT PARAMETERS:
                0025 C     myThid  :: my Thread Id number
                0026 C               (Note: not relevant since threading has not yet started)
                0027       INTEGER myThid
                0028
                0029 C     !LOCAL VARIABLES:
                0030 C     === Local variables ===
d6ea3164dc Jean*0031 C     msgBuf  :: Informational/error message buffer
94b433b65b Jean*0032 C     tile_edge2edge(nId,tId) :: Tile edge to edge connection (of tile "tId"
                0033 C                                and neighbour "nId"):
                0034 C                1rst digit gives local tile Edge (10,20,30,40 <==> N,S,E,W)
                0035 C                2nd  digit gives remote tile Edge (1,2,3,4 <==> N,S,E,W)
                0036 C                corresponding to this neighbour connection.
                0037       INTEGER tile_edge2edge( W2_maxNeighbours, W2_maxNbTiles )
017b6b2289 Jean*0038       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0039       INTEGER tNx, tNy, nbTx, nbNeighb
94b433b65b Jean*0040       INTEGER i, k, ii, nn
                0041       INTEGER is, js, ns, it, jt, nt, tx, ty
017b6b2289 Jean*0042       INTEGER iLo, iHi, jLo, jHi
                0043       INTEGER ii1, ii2, jj1, jj2, ddi, ddj
                0044       INTEGER ibnd1, ibnd2, jbnd1, jbnd2
                0045       INTEGER itbd1, itbd2, jtbd1, jtbd2
                0046       INTEGER isbd1, isbd2, jsbd1, jsbd2
                0047       INTEGER txbnd1, txbnd2, tybnd1, tybnd2
                0048       INTEGER errCnt
                0049       LOGICAL internConnect, prtFlag
                0050 CEOP
                0051
                0052       WRITE(msgBuf,'(2A)') 'W2_SET_TILE2TILES:',
                0053      &       ' tile neighbours and index connection:'
                0054       CALL PRINT_MESSAGE( msgBuf, W2_oUnit, SQUEEZE_RIGHT, myThid )
                0055       prtFlag = ABS(W2_printMsg).GE.2
                0056      &       .OR. ( W2_printMsg .NE.0 .AND. myProcId.EQ.0 )
                0057
94b433b65b Jean*0058 C--   Initialise local arrays
                0059       DO is=1,W2_maxNbTiles
                0060        DO ns=1,W2_maxNeighbours
                0061         tile_edge2edge(ns,is) = 0
2b887796b0 Oliv*0062         exch2_neighbourDir(ns,is) = 0
94b433b65b Jean*0063        ENDDO
                0064       ENDDO
                0065
017b6b2289 Jean*0066       tNx = sNx
                0067       tNy = sNy
71f938ee99 Jean*0068       DO is=1,exch2_nTiles
017b6b2289 Jean*0069        js  = exch2_myFace(is)
                0070 C     test "myFace" for blank tile; no need for connection if tile is blank
                0071        IF ( js.NE.0 ) THEN
                0072         js  = exch2_myFace(is)
                0073         iLo = exch2_tBasex(is)+1
                0074         iHi = exch2_tBasex(is)+exch2_tNx(is)
                0075         jLo = exch2_tBasey(is)+1
                0076         jHi = exch2_tBasey(is)+exch2_tNy(is)
                0077
                0078         nbNeighb = 0
                0079         DO i=1,4
                0080          ii1 = iLo
                0081          ii2 = iHi
                0082          jj1 = jLo
                0083          jj2 = jHi
                0084          IF ( i.EQ.1 ) THEN
                0085 C--   Northern Edge: [iLo:iHi,jHi]
                0086           jj1 = jHi+1
                0087           jj2 = jHi+1
                0088           internConnect = jHi.LT.exch2_mydNy(is)
                0089           IF ( .NOT.internConnect ) exch2_isNedge(is) = 1
                0090          ELSEIF ( i.EQ.2 ) THEN
                0091 C--   Southern Edge: [iLo:iHi,jLo]
                0092           jj1 = jLo-1
                0093           jj2 = jLo-1
                0094           internConnect = jLo.GT.1
                0095           IF ( .NOT.internConnect ) exch2_isSedge(is) = 1
                0096          ELSEIF ( i.EQ.3 ) THEN
                0097 C--   Eastern Edge: [iHi,jLo:jHi]
                0098           ii1 = iHi+1
                0099           ii2 = iHi+1
                0100           internConnect = iHi.LT.exch2_mydNx(is)
                0101           IF ( .NOT.internConnect ) exch2_isEedge(is) = 1
                0102          ELSE
                0103 C--   Western Edge: [iLo,jLo:jHi]
                0104           ii1 = iLo-1
                0105           ii2 = iLo-1
                0106           internConnect = iLo.GT.1
                0107           IF ( .NOT.internConnect ) exch2_isWedge(is) = 1
                0108          ENDIF
                0109          ddi = MIN( ii2-ii1, 1)
                0110          ddj = MIN( jj2-jj1, 1)
                0111
                0112          IF ( internConnect ) THEN
                0113 C---  Internal (from the same facet)
94b433b65b Jean*0114 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)
                0115 C-    get tile neighbour Id "it":
017b6b2289 Jean*0116             nbTx = facet_dims(2*js-1)/tNx
94b433b65b Jean*0117             ii = 1 + MOD(i,2)
                0118             it = 2*ii - 3
017b6b2289 Jean*0119             IF ( i.LE.2 ) THEN
94b433b65b Jean*0120                it = is + it*nbTx
017b6b2289 Jean*0121             ELSE
94b433b65b Jean*0122                it = is + it
                0123                ii = ii + 2
017b6b2289 Jean*0124             ENDIF
                0125             IF ( exch2_myFace(it).NE.0 ) THEN
                0126                nbNeighb = nbNeighb + 1
                0127                ns = MIN(nbNeighb,W2_maxNeighbours)
                0128                exch2_neighbourId(ns,is) = it
94b433b65b Jean*0129                tile_edge2edge(ns,is) = 10*i + ii
017b6b2289 Jean*0130                exch2_pij(1,ns,is) = 1
                0131                exch2_pij(2,ns,is) = 0
                0132                exch2_pij(3,ns,is) = 0
                0133                exch2_pij(4,ns,is) = 1
                0134                exch2_oi(ns,is) = 0
                0135                exch2_oj(ns,is) = 0
                0136                exch2_iLo(ns,is) = ii1 - ddi - exch2_tBasex(is)
                0137                exch2_iHi(ns,is) = ii2 + ddi - exch2_tBasex(is)
                0138                exch2_jLo(ns,is) = jj1 - ddj - exch2_tBasey(is)
                0139                exch2_jHi(ns,is) = jj2 + ddj - exch2_tBasey(is)
                0140             ENDIF
                0141
                0142          ELSE
                0143
                0144 C---  External (from an other facet)
                0145           jt = INT(facet_link(i,js))
                0146           ii = MOD( NINT(facet_link(i,js)*10.), 10 )
                0147           IF ( jt.GT.0 ) THEN
                0148 C--   needs to find list of tiles in target facet "jt" which connect to "is"
                0149 C-    index range on target facet:
                0150            ibnd1 = facet_pij(1,ii,jt)*ii1
                0151      &           + facet_pij(2,ii,jt)*jj1 + facet_oi(ii,jt)
                0152            ibnd2 = facet_pij(1,ii,jt)*ii2
                0153      &           + facet_pij(2,ii,jt)*jj2 + facet_oi(ii,jt)
                0154            jbnd1 = facet_pij(3,ii,jt)*ii1
                0155      &           + facet_pij(4,ii,jt)*jj1 + facet_oj(ii,jt)
                0156            jbnd2 = facet_pij(3,ii,jt)*ii2
                0157      &           + facet_pij(4,ii,jt)*jj2 + facet_oj(ii,jt)
                0158 C-    at least 1 index bnd is common (either ibnd1=ibnd2 or jbnd1=jbnd2)
                0159            IF ( ibnd1.LE.ibnd2 ) THEN
                0160              txbnd1 = ( ibnd1 -1 )/tNx
                0161              txbnd2 = ( ibnd2 -1 )/tNx
                0162            ELSE
                0163              txbnd1 = ( ibnd2 -1 )/tNx
                0164              txbnd2 = ( ibnd1 -1 )/tNx
                0165            ENDIF
                0166            IF ( jbnd1.LE.jbnd2 ) THEN
                0167              tybnd1 = ( jbnd1 -1 )/tNy
                0168              tybnd2 = ( jbnd2 -1 )/tNy
                0169            ELSE
                0170              tybnd1 = ( jbnd2 -1 )/tNy
                0171              tybnd2 = ( jbnd1 -1 )/tNy
                0172            ENDIF
                0173            nbTx = facet_dims(2*jt-1)/tNx
                0174            DO ty=tybnd1,tybnd2
                0175             DO tx=txbnd1,txbnd2
                0176              it = facet_owns(1,jt) + tx + ty*nbTx
                0177              IF ( exch2_myFace(it).NE.0 ) THEN
                0178 C-    Save to common block this neighbour connection :
                0179                nbNeighb = nbNeighb + 1
                0180                ns = MIN(nbNeighb,W2_maxNeighbours)
                0181                exch2_neighbourId(ns,is)  = it
94b433b65b Jean*0182                tile_edge2edge(ns,is) = 10*i + ii
017b6b2289 Jean*0183                DO k=1,4
                0184                  exch2_pij(k,ns,is) = facet_pij(k,i,js)
                0185                ENDDO
                0186                exch2_oi(ns,is) = facet_oi(i,js)
                0187                exch2_oj(ns,is) = facet_oj(i,js)
                0188 C     Edge length to be exchanged between tiles is & it:
                0189                itbd1 = MIN( MAX( ibnd1, exch2_tBasex(it)+1 ),
                0190      &                                  exch2_tBasex(it)+tNx )
                0191                itbd2 = MIN( MAX( ibnd2, exch2_tBasex(it)+1 ),
                0192      &                                  exch2_tBasex(it)+tNx )
                0193                jtbd1 = MIN( MAX( jbnd1, exch2_tBasey(it)+1 ),
                0194      &                                  exch2_tBasey(it)+tNy )
                0195                jtbd2 = MIN( MAX( jbnd2, exch2_tBasey(it)+1 ),
                0196      &                                  exch2_tBasey(it)+tNy )
                0197                isbd1 = facet_pij(1,i,js)*itbd1
                0198      &               + facet_pij(2,i,js)*jtbd1 + facet_oi(i,js)
                0199                isbd2 = facet_pij(1,i,js)*itbd2
                0200      &               + facet_pij(2,i,js)*jtbd2 + facet_oi(i,js)
                0201                jsbd1 = facet_pij(3,i,js)*itbd1
                0202      &               + facet_pij(4,i,js)*jtbd1 + facet_oj(i,js)
                0203                jsbd2 = facet_pij(3,i,js)*itbd2
                0204      &               + facet_pij(4,i,js)*jtbd2 + facet_oj(i,js)
                0205                exch2_iLo(ns,is) = isbd1 - ddi - exch2_tBasex(is)
                0206                exch2_iHi(ns,is) = isbd2 + ddi - exch2_tBasex(is)
                0207                exch2_jLo(ns,is) = jsbd1 - ddj - exch2_tBasey(is)
                0208                exch2_jHi(ns,is) = jsbd2 + ddj - exch2_tBasey(is)
                0209 C-           end active tile "it"
                0210              ENDIF
                0211 C-         end loops on tile indices tx,ty
                0212             ENDDO
                0213            ENDDO
                0214 C-        end active connection (it > 0)
                0215           ENDIF
d6ea3164dc Jean*0216 C-       end internal/external connection
017b6b2289 Jean*0217          ENDIF
                0218 C-      end N,S,E,W Edge loop
                0219         ENDDO
                0220         exch2_nNeighbours(is) = nbNeighb
                0221         IF ( prtFlag ) THEN
b9dadda204 Mart*0222          WRITE(W2_oUnit,'(A,I8,A,I3,A,4(A,I2))')
017b6b2289 Jean*0223      &    'Tile',is,' : nbNeighb=',nbNeighb,' ; is-at-Facet-Edge:',
                0224      &        ' N=', exch2_isNedge(is), ' , S=', exch2_isSedge(is),
                0225      &      ' , E=', exch2_isEedge(is), ' , W=', exch2_isWedge(is)
                0226          DO ns=1,MIN(nbNeighb,W2_maxNeighbours)
b9dadda204 Mart*0227           WRITE(W2_oUnit,'(A,I3,A,I8,2(A,2I6),A,4I3,A,2I6,A)')
017b6b2289 Jean*0228      &     ' ns:',ns,' it=',exch2_neighbourId(ns,is),
                0229      &     ', iLo,iHi=', exch2_iLo(ns,is), exch2_iHi(ns,is),
                0230      &     ', jLo,jHi=', exch2_jLo(ns,is), exch2_jHi(ns,is)
                0231 c    &     , ' (pij=',(exch2_pij(k,ns,is),k=1,4),
                0232 c    &     ', oi,oj=', exch2_oi(ns,is), exch2_oj(ns,is),')'
                0233          ENDDO
                0234         ENDIF
                0235 C-     end active tile "is"
                0236        ENDIF
                0237 C-    end loop on tile "is"
                0238       ENDDO
                0239
                0240 C-  Check nbNeighb =< W2_maxNeighbours
                0241       nbNeighb = 0
                0242       it = 0
71f938ee99 Jean*0243       DO is=1,exch2_nTiles
017b6b2289 Jean*0244         IF ( exch2_nNeighbours(is).GT.nbNeighb ) THEN
                0245           nbNeighb = exch2_nNeighbours(is)
                0246           it = is
                0247         ENDIF
                0248       ENDDO
                0249       WRITE(msgBuf,'(A,I5,A,I3)')
                0250      &  'current Max.Nb.Neighbours (e.g., on tile',it,' ) =',nbNeighb
                0251       CALL PRINT_MESSAGE( msgBuf, W2_oUnit, SQUEEZE_RIGHT, myThid )
                0252       IF ( nbNeighb.GT.W2_maxNeighbours ) THEN
                0253         WRITE(msgBuf,'(2(A,I4),A)')
                0254      &           'W2_SET_TILE2TILES: Max.Nb.Neighbours=', nbNeighb,
                0255      &           ' >', W2_maxNeighbours,' =W2_maxNeighbours'
                0256         CALL PRINT_ERROR( msgBuf, myThid )
                0257         WRITE(msgBuf,'(2A)') 'Must increase "W2_maxNeighbours"',
                0258      &                       ' in "W2_EXCH2_SIZE.h" + recompile'
                0259         CALL PRINT_ERROR( msgBuf, myThid )
                0260         STOP 'ABNORMAL END: S/R W2_SET_TILE2TILES (W2_maxNeighbours)'
                0261       ENDIF
                0262
                0263 C-    Set exch2_opposingSend(ns,is) = Neighbour Id (in list of neighbours
                0264 C     of tile exch2_neighbourId(ns,is)) which is connected to tile "is"
94b433b65b Jean*0265 C     neighbour Id "ns" with matching edge <-> edge connection (ii==i).
017b6b2289 Jean*0266       errCnt = 0
71f938ee99 Jean*0267       DO is=1,exch2_nTiles
017b6b2289 Jean*0268        DO ns=1,exch2_nNeighbours(is)
94b433b65b Jean*0269         i  = tile_edge2edge(ns,is)/10
2b887796b0 Oliv*0270         ii = MOD(tile_edge2edge(ns,is),10)
                0271         IF ( ii .NE. 0) THEN
                0272           exch2_neighbourDir(ns,is) = i
                0273         ENDIF
017b6b2289 Jean*0274         it = exch2_neighbourId(ns,is)
                0275         DO nt=1,exch2_nNeighbours(it)
94b433b65b Jean*0276 c         i  = tile_edge2edge(nt,it)/10
                0277           ii = MOD(tile_edge2edge(nt,it),10)
                0278           IF ( exch2_neighbourId(nt,it).EQ.is .AND. ii.EQ.i ) THEN
017b6b2289 Jean*0279            IF ( exch2_opposingSend(ns,is).EQ.0 ) THEN
                0280             exch2_opposingSend(ns,is) = nt
                0281            ELSE
94b433b65b Jean*0282             nn = exch2_opposingSend(ns,is)
b9dadda204 Mart*0283             WRITE(msgBuf,'(A,I8,2(A,I3),A)') 'Tile',is,' neighb:',
                0284      &      ns,' (',tile_edge2edge(ns,is),' ) has multiple connections'
017b6b2289 Jean*0285             CALL PRINT_ERROR( msgBuf, myThid )
b9dadda204 Mart*0286             WRITE(msgBuf,'(A,I8,5(A,I3))') ' with tile', it, ' :',
94b433b65b Jean*0287      &      nn,' (',tile_edge2edge(nn,it),' ) and',
                0288      &      nt,' (',tile_edge2edge(nt,it),' )'
017b6b2289 Jean*0289             CALL PRINT_ERROR( msgBuf, myThid )
                0290             errCnt = errCnt + 1
                0291            ENDIF
                0292           ENDIF
                0293         ENDDO
                0294         IF ( exch2_opposingSend(ns,is).EQ.0 ) THEN
b9dadda204 Mart*0295             WRITE(msgBuf,'(A,I8,2(A,I3),A,I8)') 'Tile',is,' neighb:',
94b433b65b Jean*0296      &      ns,' (',tile_edge2edge(ns,is),' ) no connection from',it
017b6b2289 Jean*0297             CALL PRINT_ERROR( msgBuf, myThid )
                0298             errCnt = errCnt + 1
                0299         ENDIF
                0300
                0301        ENDDO
                0302       ENDDO
                0303       IF ( errCnt.GT.0 ) THEN
                0304         WRITE(msgBuf,'(A,I3,A)')
                0305      &   ' W2_SET_TILE2TILES: found', errCnt, ' Dbl/No connection'
                0306         CALL PRINT_ERROR( msgBuf, myThid )
                0307         STOP 'ABNORMAL END: S/R W2_SET_TILE2TILES (tile connection)'
                0308       ENDIF
94b433b65b Jean*0309 C--  Check opposingSend reciprocity:
                0310       errCnt = 0
71f938ee99 Jean*0311       DO is=1,exch2_nTiles
94b433b65b Jean*0312        DO ns=1,exch2_nNeighbours(is)
                0313         it = exch2_neighbourId(ns,is)
                0314         nt = exch2_opposingSend(ns,is)
                0315         ii = exch2_neighbourId(nt,it)
                0316         nn = exch2_opposingSend(nt,it)
                0317         IF ( ii.NE.is .OR. nn.NE.ns ) THEN
b9dadda204 Mart*0318           WRITE(msgBuf,'(A,I8,2(A,I3),A)') 'Tile',is,' neighb:',
94b433b65b Jean*0319      &      ns,' (',tile_edge2edge(ns,is),' ) connected'
                0320           CALL PRINT_ERROR( msgBuf, myThid )
b9dadda204 Mart*0321           WRITE(msgBuf,'(A,I8,5(A,I3))') ' with tile', it, ' :',
94b433b65b Jean*0322      &      nt,' (',tile_edge2edge(nt,it),' )'
                0323           CALL PRINT_ERROR( msgBuf, myThid )
b9dadda204 Mart*0324           WRITE(msgBuf,'(A,I8,2(A,I3),A)') ' but',it,' neighb:',
94b433b65b Jean*0325      &      nt,' (',tile_edge2edge(nt,it),' ) connected'
                0326           CALL PRINT_ERROR( msgBuf, myThid )
b9dadda204 Mart*0327           WRITE(msgBuf,'(A,I8,3(A,I3))') ' with tile', ii, ' :',
94b433b65b Jean*0328      &      nn,' (',tile_edge2edge(nn,ii),' )'
                0329           CALL PRINT_ERROR( msgBuf, myThid )
                0330           errCnt = errCnt + 1
                0331         ENDIF
                0332        ENDDO
                0333       ENDDO
                0334       IF ( errCnt.GT.0 ) THEN
                0335         WRITE(msgBuf,'(A,I3,A)')
                0336      &   ' W2_SET_TILE2TILES: found', errCnt, ' opposingSend error'
                0337         CALL PRINT_ERROR( msgBuf, myThid )
                0338         STOP 'ABNORMAL END: S/R W2_SET_TILE2TILES (opposingSend)'
                0339       ENDIF
017b6b2289 Jean*0340
                0341       RETURN
                0342       END