/[MITgcm]/MITgcm/pkg/exch2/exch2_send_rx2.template
ViewVC logotype

Contents of /MITgcm/pkg/exch2/exch2_send_rx2.template

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.8 - (show annotations) (download)
Tue Aug 5 18:31:55 2008 UTC (15 years, 9 months ago) by cnh
Branch: MAIN
CVS Tags: checkpoint61f, checkpoint61g, checkpoint61d, checkpoint61e, checkpoint61c, checkpoint61n, checkpoint61l, checkpoint61m, checkpoint61j, checkpoint61k, checkpoint61h, checkpoint61i
Changes since 1.7: +1 -7 lines
Olivers awesome tag fixes.

1 C $Header: /u/u0/gcmpack/MITgcm/pkg/exch2/exch2_send_rx2.template,v 1.7 2008/08/01 00:45:16 jmc Exp $
2 C $Name: $
3
4 #include "CPP_EEOPTIONS.h"
5 #include "W2_OPTIONS.h"
6
7 SUBROUTINE EXCH2_SEND_RX2 (
8 I tIlo1, tIhi1, tIlo2, tIhi2, tiStride,
9 I tJlo1, tJhi1, tJlo2, tJhi2, tjStride,
10 I tKlo, tKhi, tkStride,
11 I thisTile, nN, oIs1, oJs1, oIs2, oJs2,
12 O e2Bufr1_RX, e2Bufr2_RX,
13 I e2BufrRecSize,
14 I array1,
15 I i1Lo, i1Hi, j1Lo, j1Hi, k1Lo, k1Hi,
16 I array2,
17 I i2Lo, i2Hi, j2Lo, j2Hi, k2Lo, k2Hi,
18 O e2_msgHandle1,
19 O e2_msgHandle2,
20 I commSetting, withSigns, myThid )
21
22 C Vector exchange with bufr1 along +i axis in target tile and
23 C bufr2 along +j axis in target tile.
24
25 IMPLICIT NONE
26
27 #include "SIZE.h"
28 #include "EEPARAMS.h"
29 #include "EESUPPORT.h"
30 #include "W2_EXCH2_TOPOLOGY.h"
31
32 C === Routine arguments ===
33 INTEGER tIlo1, tIhi1, tIlo2, tIhi2, tiStride
34 INTEGER tJlo1, tJhi1, tJlo2, tJhi2, tjStride
35 INTEGER tKlo, tKhi, tkStride
36 INTEGER i1Lo, i1Hi, j1Lo, j1Hi, k1Lo, k1Hi
37 INTEGER i2Lo, i2Hi, j2Lo, j2Hi, k2Lo, k2Hi
38 INTEGER thisTile, nN
39 INTEGER oIs1, oJs1, oIs2, oJs2
40 INTEGER e2BufrRecSize
41 _RX e2Bufr1_RX( e2BufrRecSize )
42 _RX e2Bufr2_RX( e2BufrRecSize )
43 _RX array1(i1Lo:i1Hi,j1Lo:j1Hi,k1Lo:k1Hi)
44 _RX array2(i2Lo:i2Hi,j2Lo:j2Hi,k2Lo:k2Hi)
45 INTEGER e2_msgHandle1(1)
46 INTEGER e2_msgHandle2(1)
47 INTEGER myThid
48 CHARACTER commSetting
49 LOGICAL withSigns
50
51 C == Local variables ==
52 C itl, jtl, ktl :: Loop counters
53 C :: itl etc... target local
54 C :: itc etc... target canonical
55 C :: isl etc... source local
56 C :: isc etc... source canonical
57 INTEGER itl, jtl, ktl
58 INTEGER itc, jtc
59 INTEGER isc, jsc
60 INTEGER isl, jsl
61 C tt :: Target tile
62 C itb, jtb :: Target local to canonical offsets
63 C
64 INTEGER tt
65 INTEGER itb, jtb
66 INTEGER isb, jsb
67 INTEGER pi(2), pj(2)
68 _RX sa1, sa2, val1, val2
69 INTEGER iBufr1, iBufr2
70
71 C MPI setup
72 #ifdef ALLOW_USE_MPI
73 INTEGER theTag1, theTag2, theType, theHandle1, theHandle2
74 INTEGER sProc, tProc, mpiRc
75 #endif
76 CHARACTER*(MAX_LEN_MBUF) messageBuffer
77
78 IF ( commSetting .EQ. 'P' ) THEN
79 C Need to check that buffer synchronisation token is decremented
80 C before filling buffer. This is needed for parallel processing
81 C shared memory modes only.
82 ENDIF
83
84 tt=exch2_neighbourId(nN, thisTile )
85 itb=exch2_tBasex(tt)
86 jtb=exch2_tBasey(tt)
87 isb=exch2_tBasex(thisTile)
88 jsb=exch2_tBasey(thisTile)
89 pi(1)=exch2_pij(1,nN,thisTile)
90 pi(2)=exch2_pij(2,nN,thisTile)
91 pj(1)=exch2_pij(3,nN,thisTile)
92 pj(2)=exch2_pij(4,nN,thisTile)
93
94 C Extract into bufr1 (target i-index array)
95 C if pi(1) is 1 then +i in target <=> +i in source so bufr1 should get +array1
96 C if pi(1) is -1 then +i in target <=> -i in source so bufr1 should get -array1
97 C if pj(1) is 1 then +i in target <=> +j in source so bufr1 should get +array2
98 C if pj(1) is -1 then +i in target <=> -j in source so bufr1 should get -array2
99 sa1 = pi(1)
100 sa2 = pj(1)
101 IF ( .NOT. withSigns ) THEN
102 sa1 = ABS(sa1)
103 sa2 = ABS(sa2)
104 ENDIF
105 C if pi(1) is 1 then +i in source aligns with +i in target
106 C if pj(1) is 1 then +i in source aligns with +j in target
107 iBufr1=0
108 #ifdef W2_E2_DEBUG_ON
109 WRITE(messageBuffer,'(A,I4,A,I4)') 'EXCH2_SEND_RX2 sourceTile= ',
110 & thisTile,
111 & ' targetTile= ',tt
112 CALL PRINT_MESSAGE(messageBuffer,
113 I standardMessageUnit,SQUEEZE_BOTH,
114 I myThid)
115 #endif /* W2_E2_DEBUG_ON */
116 DO ktl=tKlo,tKhi,tkStride
117 DO jtl=tJlo1, tJhi1, tjStride
118 DO itl=tIlo1, tIhi1, tiStride
119 iBufr1=iBufr1+1
120 itc=itl+itb
121 jtc=jtl+jtb
122 isc=pi(1)*itc+pi(2)*jtc+oIs1
123 jsc=pj(1)*itc+pj(2)*jtc+oJs1
124 isl=isc-isb
125 jsl=jsc-jsb
126 val1=sa1*array1(isl,jsl,ktl)
127 & +sa2*array2(isl,jsl,ktl)
128 e2Bufr1_RX(iBufr1)=val1
129 #ifdef W2_E2_DEBUG_ON
130 WRITE(messageBuffer,'(A,2I4)')
131 & 'EXCH2_SEND_RX2 target u(itl, jtl) = ', itl, jtl
132 CALL PRINT_MESSAGE(messageBuffer,
133 I standardMessageUnit,SQUEEZE_RIGHT,
134 I myThid)
135 IF ( pi(1) .EQ. 1 ) THEN
136 C i index aligns
137 WRITE(messageBuffer,'(A,2I4)')
138 & ' source +u(isl, jsl) = ', isl, jsl
139 ELSEIF ( pi(1) .EQ. -1 ) THEN
140 C reversed i index aligns
141 WRITE(messageBuffer,'(A,2I4)')
142 & ' source -u(isl, jsl) = ', isl, jsl
143 ELSEIF ( pj(1) .EQ. 1 ) THEN
144 WRITE(messageBuffer,'(A,2I4)')
145 & ' source +v(isl, jsl) = ', isl, jsl
146 ELSEIF ( pj(1) .EQ. -1 ) THEN
147 WRITE(messageBuffer,'(A,2I4)')
148 & ' source -v(isl, jsl) = ', isl, jsl
149 ENDIF
150 CALL PRINT_MESSAGE(messageBuffer,
151 I standardMessageUnit,SQUEEZE_RIGHT,
152 I myThid)
153 IF ( isl .LT. i1Lo .OR. isl .GT. i1Hi ) THEN
154 WRITE(messageBuffer,'(A,2I4)')
155 & ' *** isl is out of bounds '
156 CALL PRINT_MESSAGE(messageBuffer,
157 I standardMessageUnit,SQUEEZE_RIGHT,
158 I myThid)
159 ENDIF
160 IF ( jsl .LT. j1Lo .OR. jsl .GT. j1Hi ) THEN
161 WRITE(messageBuffer,'(A,2I4)')
162 & ' *** jsl is out of bounds '
163 CALL PRINT_MESSAGE(messageBuffer,
164 I standardMessageUnit,SQUEEZE_RIGHT,
165 I myThid)
166 ENDIF
167 #endif /* W2_E2_DEBUG_ON */
168 #ifdef W2_USE_E2_SAFEMODE
169 IF ( iBufr1 .GT. e2BufrRecSize ) THEN
170 C Ran off end of buffer. This should not happen
171 STOP 'EXCH2_SEND_RX2:: E2BUFR LIMIT EXCEEDED'
172 ENDIF
173 IF ( isl .LT. i1Lo .OR. isl .GT. i1Hi ) THEN
174 C Forward mode send getting from points outside of the
175 C tiles exclusive domain bounds in X. This should not happen
176 WRITE(messageBuffer,'(A,I4,I4)')
177 & 'EXCH2_SEND_RX2 tIlo1,tIhi1=', tIlo1, tIhi1
178 CALL PRINT_MESSAGE(messageBuffer,
179 I standardMessageUnit,SQUEEZE_BOTH,
180 I myThid)
181 WRITE(messageBuffer,'(A,3I4)')
182 & 'EXCH2_SEND_RX2 itl, jtl, isl =', itl, jtl, isl
183 CALL PRINT_MESSAGE(messageBuffer,
184 I standardMessageUnit,SQUEEZE_BOTH,
185 I myThid)
186 STOP 'EXCH2_SEND_RX2:: ISL OUTSIDE TILE EXCLUSIVE DOMAIN'
187 ENDIF
188 IF ( jsl .LT. j1Lo .OR. jsl .GT. j1Hi ) THEN
189 C Forward mode send getting from points outside of the
190 C tiles exclusive domain bounds in Y. This should not happen
191 WRITE(messageBuffer,'(A,I4,I4)')
192 & 'EXCH2_SEND_RX2 tJlo1,tJhi1=', tJlo1, tJhi1
193 CALL PRINT_MESSAGE(messageBuffer,
194 I standardMessageUnit,SQUEEZE_BOTH,
195 I myThid)
196 WRITE(messageBuffer,'(A,2I4)')
197 & 'EXCH2_SEND_RX2 itl, jtl =', itl, jtl
198 CALL PRINT_MESSAGE(messageBuffer,
199 I standardMessageUnit,SQUEEZE_BOTH,
200 I myThid)
201 WRITE(messageBuffer,'(A,2I4)')
202 & 'EXCH2_SEND_RX2 isl, jsl =', isl, jsl
203 CALL PRINT_MESSAGE(messageBuffer,
204 I standardMessageUnit,SQUEEZE_BOTH,
205 I myThid)
206
207 STOP 'EXCH2_SEND_RX2:: JSL OUTSIDE TILE EXCLUSIVE DOMAIN'
208 ENDIF
209 #endif /* W2_USE_E2_SAFEMODE */
210 ENDDO
211 ENDDO
212 ENDDO
213
214 C Extract values into bufr2
215 C if pi(2) is 1 then +j in target <=> +i in source so bufr1 should get +array1
216 C if pi(2) is -1 then +j in target <=> -i in source so bufr1 should get -array1
217 C if pj(2) is 1 then +j in target <=> +j in source so bufr1 should get +array2
218 C if pj(2) is -1 then +j in target <=> -j in source so bufr1 should get -array2
219 sa1 = pi(2)
220 sa2 = pj(2)
221 IF ( .NOT. withSigns ) THEN
222 sa1 = ABS(sa1)
223 sa2 = ABS(sa2)
224 ENDIF
225 iBufr2=0
226 #ifdef W2_E2_DEBUG_ON
227 WRITE(messageBuffer,'(A,I4,A,I4)') 'EXCH2_SEND_RX2 sourceTile= ',
228 & thisTile,
229 & ' targetTile= ',tt
230 CALL PRINT_MESSAGE(messageBuffer,
231 I standardMessageUnit,SQUEEZE_BOTH,
232 I myThid)
233 #endif /* W2_E2_DEBUG_ON */
234 DO ktl=tKlo,tKhi,tkStride
235 DO jtl=tJlo2, tJhi2, tjStride
236 DO itl=tIlo2, tIhi2, tiStride
237 iBufr2=iBufr2+1
238 itc=itl+itb
239 jtc=jtl+jtb
240 isc=pi(1)*itc+pi(2)*jtc+oIs2
241 jsc=pj(1)*itc+pj(2)*jtc+oJs2
242 isl=isc-isb
243 jsl=jsc-jsb
244 val2=sa1*array1(isl,jsl,ktl)
245 & +sa2*array2(isl,jsl,ktl)
246 e2Bufr2_RX(iBufr2)=val2
247 #ifdef W2_E2_DEBUG_ON
248 WRITE(messageBuffer,'(A,2I4)')
249 & 'EXCH2_SEND_RX2 target v(itl, jtl) = ', itl, jtl
250 CALL PRINT_MESSAGE(messageBuffer,
251 I standardMessageUnit,SQUEEZE_RIGHT,
252 I myThid)
253 IF ( pi(2) .EQ. 1 ) THEN
254 C i index aligns
255 WRITE(messageBuffer,'(A,2I4)')
256 & ' source +u(isl, jsl) = ', isl, jsl
257 ELSEIF ( pi(2) .EQ. -1 ) THEN
258 C reversed i index aligns
259 WRITE(messageBuffer,'(A,2I4)')
260 & ' source -u(isl, jsl) = ', isl, jsl
261 ELSEIF ( pj(2) .EQ. 1 ) THEN
262 WRITE(messageBuffer,'(A,2I4)')
263 & ' source +v(isl, jsl) = ', isl, jsl
264 ELSEIF ( pj(2) .EQ. -1 ) THEN
265 WRITE(messageBuffer,'(A,2I4)')
266 & ' source -v(isl, jsl) = ', isl, jsl
267 ENDIF
268 CALL PRINT_MESSAGE(messageBuffer,
269 I standardMessageUnit,SQUEEZE_RIGHT,
270 I myThid)
271 IF ( isl .LT. i1Lo .OR. isl .GT. i1Hi ) THEN
272 WRITE(messageBuffer,'(A,2I4)')
273 & ' *** isl is out of bounds '
274 CALL PRINT_MESSAGE(messageBuffer,
275 I standardMessageUnit,SQUEEZE_RIGHT,
276 I myThid)
277 ENDIF
278 IF ( jsl .LT. j1Lo .OR. jsl .GT. j1Hi ) THEN
279 WRITE(messageBuffer,'(A,2I4)')
280 & ' *** jsl is out of bounds '
281 CALL PRINT_MESSAGE(messageBuffer,
282 I standardMessageUnit,SQUEEZE_RIGHT,
283 I myThid)
284 ENDIF
285
286 #endif /* W2_E2_DEBUG_ON */
287 #ifdef W2_USE_E2_SAFEMODE
288 IF ( iBufr2 .GT. e2BufrRecSize ) THEN
289 C Ran off end of buffer. This should not happen
290 STOP 'EXCH2_SEND_RX2:: E2BUFR LIMIT EXCEEDED'
291 ENDIF
292 IF ( isl .LT. i1Lo .OR. isl .GT. i1Hi ) THEN
293 C Forward mode send getting from points outside of the
294 C tiles exclusive domain bounds in X. This should not happen
295 WRITE(messageBuffer,'(A,I4,I4)')
296 & 'EXCH2_SEND_RX2 tIlo2,tIhi2=', tIlo2, tIhi2
297 CALL PRINT_MESSAGE(messageBuffer,
298 I standardMessageUnit,SQUEEZE_BOTH,
299 I myThid)
300 WRITE(messageBuffer,'(A,3I4)')
301 & 'EXCH2_SEND_RX2 itl, jtl, isl =', itl, jtl, isl
302 CALL PRINT_MESSAGE(messageBuffer,
303 I standardMessageUnit,SQUEEZE_BOTH,
304 I myThid)
305 STOP 'EXCH2_SEND_RX2:: ISL OUTSIDE TILE EXCLUSIVE DOMAIN'
306 ENDIF
307 IF ( jsl .LT. j1Lo .OR. jsl .GT. j1Hi ) THEN
308 C Forward mode send getting from points outside of the
309 C tiles exclusive domain bounds in Y. This should not happen
310 WRITE(messageBuffer,'(A,I4,I4)')
311 & 'EXCH2_SEND_RX2 tJlo2,tJhi2=', tJlo2, tJhi2
312 CALL PRINT_MESSAGE(messageBuffer,
313 I standardMessageUnit,SQUEEZE_BOTH,
314 I myThid)
315 WRITE(messageBuffer,'(A,2I4)')
316 & 'EXCH2_SEND_RX2 itl, jtl =', itl, jtl
317 CALL PRINT_MESSAGE(messageBuffer,
318 I standardMessageUnit,SQUEEZE_BOTH,
319 I myThid)
320 WRITE(messageBuffer,'(A,2I4)')
321 & 'EXCH2_SEND_RX2 isl, jsl =', isl, jsl
322 CALL PRINT_MESSAGE(messageBuffer,
323 I standardMessageUnit,SQUEEZE_BOTH,
324 I myThid)
325
326 STOP 'EXCH2_SEND_RX2:: JSL OUTSIDE TILE EXCLUSIVE DOMAIN'
327 ENDIF
328 #endif /* W2_USE_E2_SAFEMODE */
329 ENDDO
330 ENDDO
331 ENDDO
332
333 C Do data transport depending on communication mechanism between source and target tile
334 IF ( commSetting .EQ. 'P' ) THEN
335 C Need to set data ready assertion (increment buffer
336 C synchronisation token) for multithreaded mode, for now do
337 C nothing i.e. assume only one thread per process.
338 ELSEIF ( commSetting .EQ. 'M' ) THEN
339 #ifdef ALLOW_USE_MPI
340 C Setup MPI stuff here
341 theTag1 = (thisTile-1)*MAX_NEIGHBOURS*2 + nN-1
342 theTag2 = (thisTile-1)*MAX_NEIGHBOURS*2 + MAX_NEIGHBOURS + nN-1
343 tProc = exch2_tProc(tt)-1
344 sProc = exch2_tProc(thisTile)-1
345 theType = MPI_REAL8
346 #ifdef W2_E2_DEBUG_ON
347 WRITE(messageBuffer,'(A,I4,A,I4,A)') ' SEND FROM TILE=',thisTile,
348 & ' (proc = ',sProc,')'
349 CALL PRINT_MESSAGE(messageBuffer,
350 I standardMessageUnit,SQUEEZE_RIGHT,
351 I myThid)
352 WRITE(messageBuffer,'(A,I4,A,I4,A)') ' TO TILE=', tt,
353 & ' (proc = ',tProc,')'
354 CALL PRINT_MESSAGE(messageBuffer,
355 I standardMessageUnit,SQUEEZE_RIGHT,
356 I myThid)
357 WRITE(messageBuffer,'(A,I10)') ' TAG1=', theTag1
358 CALL PRINT_MESSAGE(messageBuffer,
359 I standardMessageUnit,SQUEEZE_RIGHT,
360 I myThid)
361 WRITE(messageBuffer,'(A,I4)') ' NEL1=', iBufr1
362 CALL PRINT_MESSAGE(messageBuffer,
363 I standardMessageUnit,SQUEEZE_RIGHT,
364 I myThid)
365 WRITE(messageBuffer,'(A,I10)') ' TAG2=', theTag2
366 CALL PRINT_MESSAGE(messageBuffer,
367 I standardMessageUnit,SQUEEZE_RIGHT,
368 I myThid)
369 WRITE(messageBuffer,'(A,I4)') ' NEL2=', iBufr2
370 CALL PRINT_MESSAGE(messageBuffer,
371 I standardMessageUnit,SQUEEZE_RIGHT,
372 I myThid)
373 #endif /* W2_E2_DEBUG_ON */
374 CALL MPI_Isend( e2Bufr1_RX, iBufr1, theType,
375 I tProc, theTag1, MPI_COMM_MODEL,
376 O theHandle1, mpiRc )
377 CALL MPI_Isend( e2Bufr2_RX, iBufr2, theType,
378 I tProc, theTag2, MPI_COMM_MODEL,
379 O theHandle2, mpiRc )
380 C Store MPI_Wait token in messageHandle.
381 e2_msgHandle1(1) = theHandle1
382 e2_msgHandle2(1) = theHandle2
383 #endif
384 ELSE
385 STOP 'EXCH2_SEND_RX2:: commSetting VALUE IS INVALID'
386 ENDIF
387
388 RETURN
389 END
390
391 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
392
393 CEH3 ;;; Local Variables: ***
394 CEH3 ;;; mode:fortran ***
395 CEH3 ;;; End: ***

  ViewVC Help
Powered by ViewVC 1.1.22