1 |
C $Header: /u/gcmpack/MITgcm/pkg/exch2/w2_set_tile2tiles.F,v 1.2 2009/06/19 03:01:24 jmc 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 |
ENDDO |
66 |
ENDDO |
67 |
|
68 |
tNx = sNx |
69 |
tNy = sNy |
70 |
DO is=1,nTiles |
71 |
js = exch2_myFace(is) |
72 |
C test "myFace" for blank tile; no need for connection if tile is blank |
73 |
IF ( js.NE.0 ) THEN |
74 |
js = exch2_myFace(is) |
75 |
iLo = exch2_tBasex(is)+1 |
76 |
iHi = exch2_tBasex(is)+exch2_tNx(is) |
77 |
jLo = exch2_tBasey(is)+1 |
78 |
jHi = exch2_tBasey(is)+exch2_tNy(is) |
79 |
|
80 |
nbNeighb = 0 |
81 |
DO i=1,4 |
82 |
ii1 = iLo |
83 |
ii2 = iHi |
84 |
jj1 = jLo |
85 |
jj2 = jHi |
86 |
IF ( i.EQ.1 ) THEN |
87 |
C-- Northern Edge: [iLo:iHi,jHi] |
88 |
jj1 = jHi+1 |
89 |
jj2 = jHi+1 |
90 |
internConnect = jHi.LT.exch2_mydNy(is) |
91 |
IF ( .NOT.internConnect ) exch2_isNedge(is) = 1 |
92 |
ELSEIF ( i.EQ.2 ) THEN |
93 |
C-- Southern Edge: [iLo:iHi,jLo] |
94 |
jj1 = jLo-1 |
95 |
jj2 = jLo-1 |
96 |
internConnect = jLo.GT.1 |
97 |
IF ( .NOT.internConnect ) exch2_isSedge(is) = 1 |
98 |
ELSEIF ( i.EQ.3 ) THEN |
99 |
C-- Eastern Edge: [iHi,jLo:jHi] |
100 |
ii1 = iHi+1 |
101 |
ii2 = iHi+1 |
102 |
internConnect = iHi.LT.exch2_mydNx(is) |
103 |
IF ( .NOT.internConnect ) exch2_isEedge(is) = 1 |
104 |
ELSE |
105 |
C-- Western Edge: [iLo,jLo:jHi] |
106 |
ii1 = iLo-1 |
107 |
ii2 = iLo-1 |
108 |
internConnect = iLo.GT.1 |
109 |
IF ( .NOT.internConnect ) exch2_isWedge(is) = 1 |
110 |
ENDIF |
111 |
ddi = MIN( ii2-ii1, 1) |
112 |
ddj = MIN( jj2-jj1, 1) |
113 |
|
114 |
IF ( internConnect ) THEN |
115 |
C--- Internal (from the same facet) |
116 |
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) |
117 |
C- get tile neighbour Id "it": |
118 |
nbTx = facet_dims(2*js-1)/tNx |
119 |
ii = 1 + MOD(i,2) |
120 |
it = 2*ii - 3 |
121 |
IF ( i.LE.2 ) THEN |
122 |
it = is + it*nbTx |
123 |
ELSE |
124 |
it = is + it |
125 |
ii = ii + 2 |
126 |
ENDIF |
127 |
IF ( exch2_myFace(it).NE.0 ) THEN |
128 |
nbNeighb = nbNeighb + 1 |
129 |
ns = MIN(nbNeighb,W2_maxNeighbours) |
130 |
exch2_neighbourId(ns,is) = it |
131 |
tile_edge2edge(ns,is) = 10*i + ii |
132 |
exch2_pij(1,ns,is) = 1 |
133 |
exch2_pij(2,ns,is) = 0 |
134 |
exch2_pij(3,ns,is) = 0 |
135 |
exch2_pij(4,ns,is) = 1 |
136 |
exch2_oi(ns,is) = 0 |
137 |
exch2_oj(ns,is) = 0 |
138 |
exch2_iLo(ns,is) = ii1 - ddi - exch2_tBasex(is) |
139 |
exch2_iHi(ns,is) = ii2 + ddi - exch2_tBasex(is) |
140 |
exch2_jLo(ns,is) = jj1 - ddj - exch2_tBasey(is) |
141 |
exch2_jHi(ns,is) = jj2 + ddj - exch2_tBasey(is) |
142 |
ENDIF |
143 |
|
144 |
ELSE |
145 |
|
146 |
C--- External (from an other facet) |
147 |
jt = INT(facet_link(i,js)) |
148 |
ii = MOD( NINT(facet_link(i,js)*10.), 10 ) |
149 |
IF ( jt.GT.0 ) THEN |
150 |
C-- needs to find list of tiles in target facet "jt" which connect to "is" |
151 |
C- index range on target facet: |
152 |
ibnd1 = facet_pij(1,ii,jt)*ii1 |
153 |
& + facet_pij(2,ii,jt)*jj1 + facet_oi(ii,jt) |
154 |
ibnd2 = facet_pij(1,ii,jt)*ii2 |
155 |
& + facet_pij(2,ii,jt)*jj2 + facet_oi(ii,jt) |
156 |
jbnd1 = facet_pij(3,ii,jt)*ii1 |
157 |
& + facet_pij(4,ii,jt)*jj1 + facet_oj(ii,jt) |
158 |
jbnd2 = facet_pij(3,ii,jt)*ii2 |
159 |
& + facet_pij(4,ii,jt)*jj2 + facet_oj(ii,jt) |
160 |
C- at least 1 index bnd is common (either ibnd1=ibnd2 or jbnd1=jbnd2) |
161 |
IF ( ibnd1.LE.ibnd2 ) THEN |
162 |
txbnd1 = ( ibnd1 -1 )/tNx |
163 |
txbnd2 = ( ibnd2 -1 )/tNx |
164 |
ELSE |
165 |
txbnd1 = ( ibnd2 -1 )/tNx |
166 |
txbnd2 = ( ibnd1 -1 )/tNx |
167 |
ENDIF |
168 |
IF ( jbnd1.LE.jbnd2 ) THEN |
169 |
tybnd1 = ( jbnd1 -1 )/tNy |
170 |
tybnd2 = ( jbnd2 -1 )/tNy |
171 |
ELSE |
172 |
tybnd1 = ( jbnd2 -1 )/tNy |
173 |
tybnd2 = ( jbnd1 -1 )/tNy |
174 |
ENDIF |
175 |
nbTx = facet_dims(2*jt-1)/tNx |
176 |
DO ty=tybnd1,tybnd2 |
177 |
DO tx=txbnd1,txbnd2 |
178 |
it = facet_owns(1,jt) + tx + ty*nbTx |
179 |
IF ( exch2_myFace(it).NE.0 ) THEN |
180 |
C- Save to common block this neighbour connection : |
181 |
nbNeighb = nbNeighb + 1 |
182 |
ns = MIN(nbNeighb,W2_maxNeighbours) |
183 |
exch2_neighbourId(ns,is) = it |
184 |
tile_edge2edge(ns,is) = 10*i + ii |
185 |
DO k=1,4 |
186 |
exch2_pij(k,ns,is) = facet_pij(k,i,js) |
187 |
ENDDO |
188 |
exch2_oi(ns,is) = facet_oi(i,js) |
189 |
exch2_oj(ns,is) = facet_oj(i,js) |
190 |
C Edge length to be exchanged between tiles is & it: |
191 |
itbd1 = MIN( MAX( ibnd1, exch2_tBasex(it)+1 ), |
192 |
& exch2_tBasex(it)+tNx ) |
193 |
itbd2 = MIN( MAX( ibnd2, exch2_tBasex(it)+1 ), |
194 |
& exch2_tBasex(it)+tNx ) |
195 |
jtbd1 = MIN( MAX( jbnd1, exch2_tBasey(it)+1 ), |
196 |
& exch2_tBasey(it)+tNy ) |
197 |
jtbd2 = MIN( MAX( jbnd2, exch2_tBasey(it)+1 ), |
198 |
& exch2_tBasey(it)+tNy ) |
199 |
isbd1 = facet_pij(1,i,js)*itbd1 |
200 |
& + facet_pij(2,i,js)*jtbd1 + facet_oi(i,js) |
201 |
isbd2 = facet_pij(1,i,js)*itbd2 |
202 |
& + facet_pij(2,i,js)*jtbd2 + facet_oi(i,js) |
203 |
jsbd1 = facet_pij(3,i,js)*itbd1 |
204 |
& + facet_pij(4,i,js)*jtbd1 + facet_oj(i,js) |
205 |
jsbd2 = facet_pij(3,i,js)*itbd2 |
206 |
& + facet_pij(4,i,js)*jtbd2 + facet_oj(i,js) |
207 |
exch2_iLo(ns,is) = isbd1 - ddi - exch2_tBasex(is) |
208 |
exch2_iHi(ns,is) = isbd2 + ddi - exch2_tBasex(is) |
209 |
exch2_jLo(ns,is) = jsbd1 - ddj - exch2_tBasey(is) |
210 |
exch2_jHi(ns,is) = jsbd2 + ddj - exch2_tBasey(is) |
211 |
C- end active tile "it" |
212 |
ENDIF |
213 |
C- end loops on tile indices tx,ty |
214 |
ENDDO |
215 |
ENDDO |
216 |
C- end active connection (it > 0) |
217 |
ENDIF |
218 |
C- end internal/external connection |
219 |
ENDIF |
220 |
C- end N,S,E,W Edge loop |
221 |
ENDDO |
222 |
exch2_nNeighbours(is) = nbNeighb |
223 |
IF ( prtFlag ) THEN |
224 |
WRITE(W2_oUnit,'(A,I5,A,I3,A,4(A,I2))') |
225 |
& 'Tile',is,' : nbNeighb=',nbNeighb,' ; is-at-Facet-Edge:', |
226 |
& ' N=', exch2_isNedge(is), ' , S=', exch2_isSedge(is), |
227 |
& ' , E=', exch2_isEedge(is), ' , W=', exch2_isWedge(is) |
228 |
DO ns=1,MIN(nbNeighb,W2_maxNeighbours) |
229 |
WRITE(W2_oUnit,'(A,I3,A,I5,2(A,2I6),A,4I3,A,2I6,A)') |
230 |
& ' ns:',ns,' it=',exch2_neighbourId(ns,is), |
231 |
& ', iLo,iHi=', exch2_iLo(ns,is), exch2_iHi(ns,is), |
232 |
& ', jLo,jHi=', exch2_jLo(ns,is), exch2_jHi(ns,is) |
233 |
c & , ' (pij=',(exch2_pij(k,ns,is),k=1,4), |
234 |
c & ', oi,oj=', exch2_oi(ns,is), exch2_oj(ns,is),')' |
235 |
ENDDO |
236 |
ENDIF |
237 |
C- end active tile "is" |
238 |
ENDIF |
239 |
C- end loop on tile "is" |
240 |
ENDDO |
241 |
|
242 |
C- Check nbNeighb =< W2_maxNeighbours |
243 |
nbNeighb = 0 |
244 |
it = 0 |
245 |
DO is=1,nTiles |
246 |
IF ( exch2_nNeighbours(is).GT.nbNeighb ) THEN |
247 |
nbNeighb = exch2_nNeighbours(is) |
248 |
it = is |
249 |
ENDIF |
250 |
ENDDO |
251 |
WRITE(msgBuf,'(A,I5,A,I3)') |
252 |
& 'current Max.Nb.Neighbours (e.g., on tile',it,' ) =',nbNeighb |
253 |
CALL PRINT_MESSAGE( msgBuf, W2_oUnit, SQUEEZE_RIGHT, myThid ) |
254 |
IF ( nbNeighb.GT.W2_maxNeighbours ) THEN |
255 |
WRITE(msgBuf,'(2(A,I4),A)') |
256 |
& 'W2_SET_TILE2TILES: Max.Nb.Neighbours=', nbNeighb, |
257 |
& ' >', W2_maxNeighbours,' =W2_maxNeighbours' |
258 |
CALL PRINT_ERROR( msgBuf, myThid ) |
259 |
WRITE(msgBuf,'(2A)') 'Must increase "W2_maxNeighbours"', |
260 |
& ' in "W2_EXCH2_SIZE.h" + recompile' |
261 |
CALL PRINT_ERROR( msgBuf, myThid ) |
262 |
STOP 'ABNORMAL END: S/R W2_SET_TILE2TILES (W2_maxNeighbours)' |
263 |
ENDIF |
264 |
|
265 |
C- Set exch2_opposingSend(ns,is) = Neighbour Id (in list of neighbours |
266 |
C of tile exch2_neighbourId(ns,is)) which is connected to tile "is" |
267 |
C neighbour Id "ns" with matching edge <-> edge connection (ii==i). |
268 |
errCnt = 0 |
269 |
DO is=1,nTiles |
270 |
DO ns=1,exch2_nNeighbours(is) |
271 |
i = tile_edge2edge(ns,is)/10 |
272 |
c ii = MOD(tile_edge2edge(ns,is),10) |
273 |
it = exch2_neighbourId(ns,is) |
274 |
DO nt=1,exch2_nNeighbours(it) |
275 |
c i = tile_edge2edge(nt,it)/10 |
276 |
ii = MOD(tile_edge2edge(nt,it),10) |
277 |
IF ( exch2_neighbourId(nt,it).EQ.is .AND. ii.EQ.i ) THEN |
278 |
IF ( exch2_opposingSend(ns,is).EQ.0 ) THEN |
279 |
exch2_opposingSend(ns,is) = nt |
280 |
ELSE |
281 |
nn = exch2_opposingSend(ns,is) |
282 |
WRITE(msgBuf,'(A,I5,2(A,I3),A,I5)') 'Tile',is,' neighb:', |
283 |
& ns,' (',tile_edge2edge(ns,is),' ) has multiple connection' |
284 |
CALL PRINT_ERROR( msgBuf, myThid ) |
285 |
WRITE(msgBuf,'(A,I5,5(A,I3))') ' with tile', it, ' :', |
286 |
& nn,' (',tile_edge2edge(nn,it),' ) and', |
287 |
& nt,' (',tile_edge2edge(nt,it),' )' |
288 |
CALL PRINT_ERROR( msgBuf, myThid ) |
289 |
errCnt = errCnt + 1 |
290 |
ENDIF |
291 |
ENDIF |
292 |
ENDDO |
293 |
IF ( exch2_opposingSend(ns,is).EQ.0 ) THEN |
294 |
WRITE(msgBuf,'(A,I5,2(A,I3),A,I5)') 'Tile',is,' neighb:', |
295 |
& ns,' (',tile_edge2edge(ns,is),' ) no connection from',it |
296 |
CALL PRINT_ERROR( msgBuf, myThid ) |
297 |
errCnt = errCnt + 1 |
298 |
ENDIF |
299 |
|
300 |
ENDDO |
301 |
ENDDO |
302 |
IF ( errCnt.GT.0 ) THEN |
303 |
WRITE(msgBuf,'(A,I3,A)') |
304 |
& ' W2_SET_TILE2TILES: found', errCnt, ' Dbl/No connection' |
305 |
CALL PRINT_ERROR( msgBuf, myThid ) |
306 |
STOP 'ABNORMAL END: S/R W2_SET_TILE2TILES (tile connection)' |
307 |
ENDIF |
308 |
C-- Check opposingSend reciprocity: |
309 |
errCnt = 0 |
310 |
DO is=1,nTiles |
311 |
DO ns=1,exch2_nNeighbours(is) |
312 |
it = exch2_neighbourId(ns,is) |
313 |
nt = exch2_opposingSend(ns,is) |
314 |
ii = exch2_neighbourId(nt,it) |
315 |
nn = exch2_opposingSend(nt,it) |
316 |
IF ( ii.NE.is .OR. nn.NE.ns ) THEN |
317 |
WRITE(msgBuf,'(A,I5,2(A,I3),A)') 'Tile',is,' neighb:', |
318 |
& ns,' (',tile_edge2edge(ns,is),' ) connected' |
319 |
CALL PRINT_ERROR( msgBuf, myThid ) |
320 |
WRITE(msgBuf,'(A,I5,5(A,I3))') ' with tile', it, ' :', |
321 |
& nt,' (',tile_edge2edge(nt,it),' )' |
322 |
CALL PRINT_ERROR( msgBuf, myThid ) |
323 |
WRITE(msgBuf,'(A,I5,2(A,I3),A)') ' but',it,' neighb:', |
324 |
& nt,' (',tile_edge2edge(nt,it),' ) connected' |
325 |
CALL PRINT_ERROR( msgBuf, myThid ) |
326 |
WRITE(msgBuf,'(A,I5,3(A,I3))') ' with tile', ii, ' :', |
327 |
& nn,' (',tile_edge2edge(nn,ii),' )' |
328 |
CALL PRINT_ERROR( msgBuf, myThid ) |
329 |
errCnt = errCnt + 1 |
330 |
ENDIF |
331 |
ENDDO |
332 |
ENDDO |
333 |
IF ( errCnt.GT.0 ) THEN |
334 |
WRITE(msgBuf,'(A,I3,A)') |
335 |
& ' W2_SET_TILE2TILES: found', errCnt, ' opposingSend error' |
336 |
CALL PRINT_ERROR( msgBuf, myThid ) |
337 |
STOP 'ABNORMAL END: S/R W2_SET_TILE2TILES (opposingSend)' |
338 |
ENDIF |
339 |
|
340 |
RETURN |
341 |
END |