/[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.10 - (show annotations) (download)
Wed May 20 21:01:45 2009 UTC (15 years ago) by jmc
Branch: MAIN
CVS Tags: checkpoint61o
Changes since 1.9: +2 -2 lines
use the right MPI type in MPI_SEND/RECV call. (replace MPI_REAL8
 by _MPI_TYPE_RX in template)

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

  ViewVC Help
Powered by ViewVC 1.1.22