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 |