File: RELATIVE:/../../../mfix.git/model/dmp_modules/sendrecv3_mod.f
1 module sendrecv3
2 use parallel_mpi
3 use debug
4 use geometry
5 use compar
6 use indices
7 implicit none
8
9 integer, pointer, dimension(:) :: &
10 recvproc1, recvtag1, xrecv1, recvijk1, &
11 sendproc1, sendtag1, xsend1, sendijk1, &
12 recvproc2, recvtag2, xrecv2, recvijk2, &
13 sendproc2, sendtag2, xsend2, sendijk2
14
15
16 integer,pointer, dimension(:) :: &
17 send_persistent_request, recv_persistent_request, &
18 send_persistent_request1, send_persistent_request2, &
19 recv_persistent_request1, recv_persistent_request2
20
21 integer :: nrecv1,nsend1, nrecv2,nsend2
22
23
24
25
26 integer, pointer, dimension(:) :: &
27 recvproc3, recvtag3, xrecv3, recvijk3, &
28 sendproc3, sendtag3, xsend3, sendijk3, &
29 send_persistent_request3,recv_persistent_request3
30 integer :: nrecv3,nsend3
31 integer, parameter :: nlayers = 3
32
33 logical,parameter :: localfunc=.false.
34
35 logical,parameter :: use_persistent_message=.true.
36
37
38 double precision, dimension(:), pointer :: &
39 dsendbuffer, drecvbuffer
40 integer, dimension(:), pointer :: &
41 isendbuffer, irecvbuffer
42 character, dimension(:), pointer :: &
43 csendbuffer, crecvbuffer
44
45 integer :: nrecv,nsend
46 integer, pointer, dimension(:) :: &
47 recvrequest, sendrequest, &
48 xrecv,recvproc, recvijk, recvtag, &
49 xsend,sendproc, sendijk, sendtag
50
51 integer :: &
52 kstart_all_myPE, jstart_all_myPE, istart_all_myPE, &
53 kend_all_myPE, jend_all_myPE, iend_all_myPE
54
55 integer :: communicator
56
57
58
59
60 interface sendrecv3_begin
61 module procedure &
62 sendrecv3_begin_1d, &
63 sendrecv3_begin_1i, &
64 sendrecv3_begin_1c
65 end interface sendrecv3_begin
66
67 interface sendrecv3_end
68 module procedure &
69 sendrecv3_end_1d, &
70 sendrecv3_end_1i, &
71 sendrecv3_end_1c
72 end interface sendrecv3_end
73
74 interface send_recv3
75 module procedure &
76 send_recv3_1d, send_recv3_2d, send_recv3_3d, &
77 send_recv3_1i, &
78 send_recv3_1c
79 end interface send_recv3
80
81
82 contains
83
84 subroutine ijk_of( ijkp, i,j,k )
85 integer, intent(in) :: ijkp
86 integer, intent(out) :: i,j,k
87
88 integer :: k1,k2, j1,j2, i1,i2, &
89 ijk, isize,jsize,ksize, gijk
90
91 character(len=32), parameter :: name = "ijk_of"
92 logical :: isok_k, isok_j, isok_i, is_same, isok
93
94 ijk = ijkp
95
96
97
98
99
100 = istart4_all(myPE)
101 i2 = iend4_all(myPE)
102 j1 = jstart4_all(myPE)
103 j2 = jend4_all(myPE)
104 k1 = kstart4_all(myPE)
105 k2 = kend4_all(myPE)
106
107
108
109
110
111
112 ksize = (k2-k1+1)
113 jsize = (j2-j1+1)
114 isize = (i2-i1+1)
115
116
117 if (mod(ijk,isize*jsize).ne.0) then
118 k = int( ijk/(isize*jsize) ) + k1
119 else
120 k = int( ijk/(isize*jsize) ) + k1 -1
121 endif
122 ijk = ijk - (k-k1)*(isize*jsize)
123
124 if (mod(ijk,isize).ne.0) then
125 j = int( ijk/isize ) + j1
126 else
127 j = int( ijk/isize ) + j1 - 1
128 endif
129 ijk = ijk - (j-j1)*isize
130
131 i = (ijk-1) + i1
132
133
134
135 = (i1 <= i) .and. (i <= i2)
136 isok_j = (j1 <= j) .and. (j <= j2)
137 isok_k = (k1 <= k) .and. (k <= k2)
138 gijk = 1 + (i-i1) + (j-j1)*(i2-i1+1) + &
139 (k-k1)*(j2-j1+1)*(i2-i1+1)
140 is_same = (gijk .eq. ijkp)
141 isok = isok_i .and. isok_j .and. isok_k .and. is_same
142 if (.not.isok) then
143 call write_debug( name, 'i,j,k ', i,j,k )
144 call write_debug( name, 'ijkp, gijk ', ijkp, gijk )
145 endif
146
147
148 return
149 end subroutine ijk_of
150
151
152 subroutine ijk_of_gl( ijkp, i,j,k )
153 integer, intent(in) :: ijkp
154 integer, intent(out) :: i,j,k
155
156 integer :: k1,k2, j1,j2, i1,i2, &
157 ijk, isize,jsize,ksize, gijk
158
159 character(len=32), parameter :: name = "ijk_of_gl"
160 logical :: isok_k, isok_j, isok_i, is_same, isok
161
162 ijk = ijkp
163
164
165
166
167
168 = minval( kstart4_all(:) )
169 k2 = maxval( kend4_all(:) )
170
171 j1 = minval( jstart4_all(:) )
172 j2 = maxval( jend4_all(:) )
173
174 i1 = minval( istart4_all(:) )
175 i2 = maxval( iend4_all(:) )
176
177
178
179 ksize = (k2-k1+1)
180 jsize = (j2-j1+1)
181 isize = (i2-i1+1)
182
183
184 if (mod(ijk,isize*jsize).ne.0) then
185 k = int( ijk/(isize*jsize) ) + k1
186 else
187 k = int( ijk/(isize*jsize) ) + k1 -1
188 endif
189 ijk = ijk - (k-k1)*(isize*jsize)
190
191 if (mod(ijk,isize).ne.0) then
192 j = int( ijk/isize ) + j1
193 else
194 j = int( ijk/isize ) + j1 - 1
195 endif
196 ijk = ijk - (j-j1)*isize
197
198 i = (ijk-1) + i1
199
200
201
202 = (i1 <= i) .and. (i <= i2)
203 isok_j = (j1 <= j) .and. (j <= j2)
204 isok_k = (k1 <= k) .and. (k <= k2)
205 gijk = 1 + (i-i1) + (j-j1)*(i2-i1+1) + &
206 (k-k1)*(j2-j1+1)*(i2-i1+1)
207 is_same = (gijk .eq. ijkp)
208 isok = isok_i .and. isok_j .and. isok_k .and. is_same
209 if (.not.isok) then
210 call write_debug( name, 'i,j,k ', i,j,k )
211 call write_debug( name, 'ijkp, gijk ', ijkp, gijk )
212 endif
213
214
215 return
216 end subroutine ijk_of_gl
217
218 subroutine sendrecv3_init( &
219 comm, &
220 cyclic_i,cyclic_j,cyclic_k, idebug )
221
222 use functions
223
224 implicit none
225
226 integer, intent(in) :: comm
227 logical,intent(in) :: cyclic_i,cyclic_j,cyclic_k
228
229 integer, intent(in), optional :: idebug
230
231 #ifdef MPI
232
233
234
235
236
237
238
239
240
241 character(len=80), parameter :: name = 'sendrecv3_init'
242
243 character(len=80), pointer, dimension(:) :: line
244 integer :: ip, lmax
245
246 integer :: layer,request, source, tag, datatype
247
248 integer :: lidebug
249 integer :: isize,jsize,ksize, ijksize
250 integer :: recvsize1, recvsize2, &
251 sendsize1, sendsize2
252
253 integer :: iter, i,j,k, ii, jj,kk, &
254 ntotal, icount,ipos, &
255 ilayer, i1,i2, j1,j2, k1,k2, &
256 ijk, ijk2, iproc, jproc, src,dest, &
257 ierror
258
259 logical :: isok, isvalid, ismine, is_halobc
260
261 integer, dimension(:,:,:), pointer :: ijk2proc
262 integer, pointer, dimension(:) :: &
263 istartx,iendx, jstartx,jendx, kstartx,kendx, &
264 ncount, &
265 recvproc, recvtag, xrecv, recvijk, &
266 sendproc, sendtag, xsend, sendijk
267
268 logical, parameter :: jfastest = .true.
269
270
271 integer, parameter :: message_tag_offset = 1000
272
273
274
275
276
277 integer :: message_tag
278
279 message_tag(src,dest) = message_tag_offset + (1+src + dest*10*numPEs)
280
281 nullify( &
282 recvproc1, recvtag1, xrecv1, recvijk1, &
283 sendproc1, sendtag1, xsend1, sendijk1, &
284 recvproc2, recvtag2, xrecv2, recvijk2, &
285 sendproc2, sendtag2, xsend2, sendijk2)
286
287 nullify( &
288 send_persistent_request, recv_persistent_request, &
289 send_persistent_request1, send_persistent_request2, &
290 recv_persistent_request1, recv_persistent_request2 )
291
292 nullify( dsendbuffer, drecvbuffer )
293 nullify( isendbuffer, irecvbuffer )
294 nullify( csendbuffer, crecvbuffer )
295
296 nullify( &
297 recvrequest, sendrequest, &
298 xrecv,recvproc, recvijk, recvtag, &
299 xsend,sendproc, sendijk, sendtag )
300
301
302
303
304
305
306
307 lidebug = 0
308 if (present(idebug)) then
309 lidebug = idebug
310 endif
311
312 communicator = comm
313 call MPI_COMM_SIZE( comm, numPEs, ierror )
314 call MPI_Check( 'sendrecv3_init:MPI_COMM_SIZE ', ierror )
315
316 call MPI_COMM_RANK( comm, myPE, ierror )
317 call MPI_Check( 'sendrecv3_init:MPI_COMM_RANK ', ierror )
318
319
320
321
322
323
324
325
326
327 call assert( kmin1 .eq. minval( kstart1_all(:) ), &
328 '** sendrecv3_init: invalid kmin1, ' // &
329 ' kmin1, minval(kstart1_all(:)) ', &
330 kmin1, minval(kstart1_all(:)) )
331
332 call assert( kmin2 .eq. minval( kstart2_all(:) ), &
333 '** sendrecv3_init: invalid kmin2, ' // &
334 ' kmin2, minval(kstart2_all(:)) ', &
335 kmin2, minval(kstart2_all(:)) )
336
337 call assert( kmin3 .eq. minval( kstart3_all(:) ), &
338 '** sendrecv3_init: invalid kmin3, ' // &
339 ' kmin3, minval(kstart3_all(:)) ', &
340 kmin3, minval(kstart3_all(:)) )
341
342
343 call assert( kmax1 .eq. maxval( kend1_all(:) ), &
344 '** sendrecv3_init: invalid kmax1, ' // &
345 ' kmax1, maxval(kend1_all(:)) ', &
346 kmax1, maxval(kend1_all(:)) )
347
348 call assert( kmax2 .eq. maxval( kend2_all(:) ), &
349 '** sendrecv3_init: invalid kmax2, ' // &
350 ' kmax2, maxval(kend2_all(:)) ', &
351 kmax2, maxval(kend2_all(:)) )
352
353 call assert( kmax3 .eq. maxval( kend3_all(:) ), &
354 '** sendrecv3_init: invalid kmax3, ' // &
355 ' kmax3, maxval(kend3_all(:)) ', &
356 kmax3, maxval(kend3_all(:)) )
357
358
359
360
361 call assert( kmin4 .eq. minval( kstart4_all(:) ), &
362 '** sendrecv3_init: invalid kmin4, ' // &
363 ' kmin4, minval(kstart4_all(:)) ', &
364 kmin4, minval(kstart4_all(:)) )
365 call assert( kmax4 .eq. maxval( kend4_all(:) ), &
366 '** sendrecv3_init: invalid kmax4, ' // &
367 ' kmax4, maxval(kend4_all(:)) ', &
368 kmax4, maxval(kend4_all(:)) )
369
370
371
372
373 call assert( jmin1 .eq. minval( jstart1_all(:) ), &
374 '** sendrecv3_init: invalid jmin1, ' // &
375 ' jmin1, minval(jstart1_all(:)) ', &
376 jmin1, minval(jstart1_all(:)) )
377
378 call assert( jmin2 .eq. minval( jstart2_all(:) ), &
379 '** sendrecv3_init: invalid jmin2, ' // &
380 ' jmin2, minval(jstart2_all(:)) ', &
381 jmin2, minval(jstart2_all(:)) )
382
383 call assert( jmin3 .eq. minval( jstart3_all(:) ), &
384 '** sendrecv3_init: invalid jmin3, ' // &
385 ' jmin3, minval(jstart3_all(:)) ', &
386 jmin3, minval(jstart3_all(:)) )
387
388
389 call assert( jmax1 .eq. maxval( jend1_all(:) ), &
390 '** sendrecv3_init: invalid jmax1, ' // &
391 ' jmax1, maxval(jend1_all(:)) ', &
392 jmax1, maxval(jend1_all(:)) )
393
394 call assert( jmax2 .eq. maxval( jend2_all(:) ), &
395 '** sendrecv3_init: invalid jmax2, ' // &
396 ' jmax2, maxval(jend2_all(:)) ', &
397 jmax2, maxval(jend2_all(:)) )
398
399 call assert( jmax3 .eq. maxval( jend3_all(:) ), &
400 '** sendrecv3_init: invalid jmax3, ' // &
401 ' jmax3, maxval(jend3_all(:)) ', &
402 jmax3, maxval(jend3_all(:)) )
403
404
405
406 call assert( jmin4 .eq. minval( jstart4_all(:) ), &
407 '** sendrecv3_init: invalid jmin4, ' // &
408 ' jmin4, minval(jstart4_all(:)) ', &
409 jmin4, minval(jstart4_all(:)) )
410 call assert( jmax4 .eq. maxval( jend4_all(:) ), &
411 '** sendrecv3_init: invalid jmax4, ' // &
412 ' jmax4, maxval(jend4_all(:)) ', &
413 jmax4, maxval(jend4_all(:)) )
414
415
416
417
418 call assert( imin1 .eq. minval( istart1_all(:) ), &
419 '** sendrecv3_init: invalid imin1, ' // &
420 ' imin1, minval(istart1_all(:)) ', &
421 imin1, minval(istart1_all(:)) )
422
423 call assert( imin2 .eq. minval( istart2_all(:) ), &
424 '** sendrecv3_init: invalid imin2, ' // &
425 ' imin2, minval(istart2_all(:)) ', &
426 imin2, minval(istart2_all(:)) )
427
428 call assert( imin3 .eq. minval( istart3_all(:) ), &
429 '** sendrecv3_init: invalid imin3, ' // &
430 ' imin3, minval(istart3_all(:)) ', &
431 imin3, minval(istart3_all(:)) )
432
433
434 call assert( imax1 .eq. maxval( iend1_all(:) ), &
435 '** sendrecv3_init: invalid imax1, ' // &
436 ' imax1, maxval(iend1_all(:)) ', &
437 imax1, maxval(iend1_all(:)) )
438
439 call assert( imax2 .eq. maxval( iend2_all(:) ), &
440 '** sendrecv3_init: invalid imax2, ' // &
441 ' imax2, maxval(iend2_all(:)) ', &
442 imax2, maxval(iend2_all(:)) )
443
444 call assert( imax3 .eq. maxval( iend3_all(:) ), &
445 '** sendrecv3_init: invalid imax3, ' // &
446 ' imax3, maxval(iend3_all(:)) ', &
447 imax3, maxval(iend3_all(:)) )
448
449
450
451
452 call assert( imin4 .eq. minval( istart4_all(:) ), &
453 '** sendrecv3_init: invalid imin4, ' // &
454 ' imin4, minval(istart4_all(:)) ', &
455 imin4, minval(istart4_all(:)) )
456 call assert( imax4 .eq. maxval( iend4_all(:) ), &
457 '** sendrecv3_init: invalid imax4, ' // &
458 ' imax4, maxval(iend4_all(:)) ', &
459 imax4, maxval(iend4_all(:)) )
460
461
462
463 call assert( jmin1 .le. jmax1, &
464 '** sendrecv3_init: jmin1,jmax1 ', jmin1,jmax1 )
465 call assert( jmin2 .le. jmax2, &
466 '** sendrecv3_init: jmin2,jmax2 ', jmin2,jmax2 )
467 call assert( jmin3 .le. jmax3, &
468 '** sendrecv3_init: jmin3,jmax3 ', jmin3,jmax3 )
469
470 call assert( kmin1 .le. kmax1, &
471 '** sendrecv3_init: kmin1,kmax1 ', kmin1,kmax1 )
472 call assert( kmin2 .le. kmax2, &
473 '** sendrecv3_init: kmin2,kmax2 ', kmin2,kmax2 )
474 call assert( kmin3 .le. kmax3, &
475 '** sendrecv3_init: kmin3,kmax3 ', kmin3,kmax3 )
476
477 call assert( imin1 .le. imax1, &
478 '** sendrecv3_init: imin1,imax1 ', imin1,imax1 )
479 call assert( imin2 .le. imax2, &
480 '** sendrecv3_init: imin2,imax2 ', imin2,imax2 )
481 call assert( imin3 .le. imax3, &
482 '** sendrecv3_init: imin3,imax3 ', imin3,imax3 )
483
484
485
486
487
488 call assert( jmin4 .le. jmax4, &
489 '** sendrecv3_init: jmin4,jmax4 ', jmin4,jmax4 )
490 call assert( imin4 .le. imax4, &
491 '** sendrecv3_init: imin4,imax4 ', imin4,imax4 )
492 call assert( kmin4 .le. kmax4, &
493 '** sendrecv3_init: kmin4,kmax4 ', kmin4,kmax4 )
494
495
496
497
498
499
500 k1 = min( kmin1, min(kmin2, kmin3) )
501 k2 = max( kmax1, max(kmax2, kmax3) )
502 j1 = min( jmin1, min(jmin2, jmin3) )
503 j2 = max( jmax1, max(jmax2, jmax3) )
504 i1 = min( imin1, min(imin2, imin3) )
505 i2 = max( imax1, max(imax2, imax3) )
506
507
508
509
510 k1 = min(k1,kmin4)
511 k2 = max(k2,kmax4)
512 j1 = min(j1,jmin4)
513 j2 = max(j2,jmax4)
514 i1 = min(i1,imin4)
515 i2 = max(i2,imax4)
516
517
518 allocate( ijk2proc( i1:i2, j1:j2, k1:k2 ) )
519
520
521 if(localfunc) then
522
523
524
525
526
527
528
529
530 kstart_all_myPE = min( kstart3_all(myPE), kstart4_all(myPE))
531 kend_all_myPE = max( kend3_all(myPE), kend4_all(myPE))
532
533 jstart_all_myPE = min( jstart3_all(myPE), jstart4_all(myPE))
534 jend_all_myPE = max( jend3_all(myPE), jend4_all(myPE))
535
536 istart_all_myPE = min( istart3_all(myPE), istart4_all(myPE))
537 iend_all_myPE = max( iend3_all(myPE), iend4_all(myPE))
538
539
540 do k=kstart_all_myPE,kend_all_myPE
541 do j=jstart_all_myPE,jend_all_myPE
542 do i=istart_all_myPE,iend_all_myPE
543 ijk = funijk(i,j,k)
544 call ijk_of(ijk, ii,jj,kk)
545 ijk2 = funijk( ii,jj,kk)
546
547 isvalid = (ii.eq.i).and.(jj.eq.j).and.(kk.eq.k).and.(ijk.eq.ijk2)
548 if (.not.isvalid) then
549 call write_debug( name, 'error with ijk_of ')
550
551 call write_debug( name, 'istart3_all(myPE),iend3_all(myPE) ', &
552 istart3_all(myPE),iend3_all(myPE) )
553 call write_debug( name, 'jstart3_all(myPE),jend3_all(myPE) ', &
554 jstart3_all(myPE),jend3_all(myPE) )
555 call write_debug( name, 'kstart3_all(myPE),kend3_all(myPE) ', &
556 kstart3_all(myPE),kend3_all(myPE) )
557
558 call write_debug( name, 'i,j,k, ijk ', i,j,k, ijk )
559 call write_debug( name, 'ii,jj,kk, ijk2 ',ii,jj,kk,ijk2 )
560
561 endif
562 enddo
563 enddo
564 enddo
565 endif
566
567
568 if (lidebug.ge.1) then
569 call write_debug( name, 'imap ', imap )
570 call write_debug( name, 'jmap ', jmap )
571 call write_debug( name, 'kmap ', kmap )
572 endif
573
574
575
576
577
578
579
580
581
582
583
584 ijk2proc( :,:,: ) = 0
585
586
587
588
589
590 do iproc=0,numPEs-1
591
592
593
594
595 i1 = istart1_all(iproc)
596 i2 = iend1_all(iproc)
597 j1 = jstart1_all(iproc)
598 j2 = jend1_all(iproc)
599 k1 = kstart1_all(iproc)
600 k2 = kend1_all(iproc)
601
602 if(istart3_all(iproc).eq.imin3) i1 = istart3_all(iproc)
603 if(iend3_all(iproc).eq.imax3) i2 = iend3_all(iproc)
604 if(jstart3_all(iproc).eq.jmin3) j1 = jstart3_all(iproc)
605 if(jend3_all(iproc).eq.jmax3) j2 = jend3_all(iproc)
606 if(kstart3_all(iproc).eq.kmin3) k1 = kstart3_all(iproc)
607 if(kend3_all(iproc).eq.kmax3) k2 = kend3_all(iproc)
608
609
610
611
612 do k=k1,k2
613 do j=j1,j2
614 do i=i1,i2
615 ijk2proc(i,j,k) = ijk2proc(i,j,k) + 1
616 enddo
617 enddo
618 enddo
619
620 enddo
621
622 do k=lbound(ijk2proc,3),ubound(ijk2proc,3)
623 do j=lbound(ijk2proc,2),ubound(ijk2proc,2)
624 do i=lbound(ijk2proc,1),ubound(ijk2proc,1)
625 isvalid = (ijk2proc(i,j,k) .eq. 1)
626 if (.not.isvalid) then
627
628 call write_debug(name, ' invalid decomposition ')
629 call write_debug(name, 'i,j,k ',i,j,k )
630 call write_debug(name, 'ijk2proc(i,j,k) ', ijk2proc(i,j,k))
631
632 call mfix_exit( myPE )
633 endif
634 enddo
635 enddo
636 enddo
637
638 ijk2proc(:,:,:) = -1
639 do iproc=0,numPEs-1
640
641
642
643 i1 = istart1_all(iproc)
644 i2 = iend1_all(iproc)
645 j1 = jstart1_all(iproc)
646 j2 = jend1_all(iproc)
647 k1 = kstart1_all(iproc)
648 k2 = kend1_all(iproc)
649
650 if(istart3_all(iproc).eq.imin3) i1 = istart3_all(iproc)
651 if(iend3_all(iproc).eq.imax3) i2 = iend3_all(iproc)
652 if(jstart3_all(iproc).eq.jmin3) j1 = jstart3_all(iproc)
653 if(jend3_all(iproc).eq.jmax3) j2 = jend3_all(iproc)
654 if(kstart3_all(iproc).eq.kmin3) k1 = kstart3_all(iproc)
655 if(kend3_all(iproc).eq.kmax3) k2 = kend3_all(iproc)
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670 do k=k1,k2
671 do j=j1,j2
672 do i=i1,i2
673 ijk2proc(i,j,k) = iproc
674 enddo
675 enddo
676 enddo
677
678 enddo
679
680
681
682 allocate( ncount(0:numPEs-1) )
683
684 allocate( istartx(0:numPEs-1) )
685 allocate( jstartx(0:numPEs-1) )
686 allocate( kstartx(0:numPEs-1) )
687
688 allocate( iendx(0:numPEs-1) )
689 allocate( jendx(0:numPEs-1) )
690 allocate( kendx(0:numPEs-1) )
691
692
693
694
695 do ilayer=nlayers,nlayers
696
697 if (ilayer.eq.1) then
698 kstartx(:) = kstart2_all(:)
699 kendx(:) = kend2_all(:)
700 jstartx(:) = jstart2_all(:)
701 jendx(:) = jend2_all(:)
702 istartx(:) = istart2_all(:)
703 iendx(:) = iend2_all(:)
704 else if (ilayer.eq.2) then
705 kstartx(:) = kstart3_all(:)
706 kendx(:) = kend3_all(:)
707 jstartx(:) = jstart3_all(:)
708 jendx(:) = jend3_all(:)
709 istartx(:) = istart3_all(:)
710 iendx(:) = iend3_all(:)
711 else if (ilayer.eq.3) then
712
713
714
715
716 kstartx(:) = kstart4_all(:)
717 kendx(:) = kend4_all(:)
718 jstartx(:) = jstart4_all(:)
719 jendx(:) = jend4_all(:)
720 istartx(:) = istart4_all(:)
721 iendx(:) = iend4_all(:)
722
723 endif
724
725
726
727 if (lidebug.ge.1) then
728 call write_debug(name, 'determine send schedule ', myPE )
729 endif
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745 ncount(:) = 0
746
747 do iproc=0,numPEs-1
748 if (iproc.ne.myPE) then
749
750
751 k1 = lbound(ijk2proc,3)
752 k2 = ubound(ijk2proc,3)
753 j1 = lbound(ijk2proc,2)
754 j2 = ubound(ijk2proc,2)
755 i1 = lbound(ijk2proc,1)
756 i2 = ubound(ijk2proc,1)
757
758
759 do k=kstartx(iproc),kendx(iproc)
760 do j=jstartx(iproc),jendx(iproc)
761 do i=istartx(iproc),iendx(iproc)
762
763 ii = imap(i)
764 jj = jmap(j)
765 kk = kmap(k)
766
767 isvalid = (k1.le.kk).and.(kk.le.k2)
768 call assert( isvalid, '** sendrecv3_init: invalid kk ', kk )
769
770 isvalid = (j1.le.jj).and.(jj.le.j2)
771 call assert( isvalid, '** sendrecv3_init: invalid jj ', jj )
772
773 isvalid = (i1.le.ii).and.(ii.le.i2)
774 call assert( isvalid, '** sendrecv3_init: invalid ii ', ii )
775
776 jproc = ijk2proc( ii,jj,kk )
777
778 ismine = (jproc .eq. myPE)
779 if (ismine) then
780 ncount(iproc) = ncount(iproc) + 1
781 endif
782
783 enddo
784 enddo
785 enddo
786
787 endif
788 enddo
789
790
791
792
793
794 ntotal = 0
795 nsend = 0
796 do iproc=0,numPEs-1
797 ntotal = ntotal + ncount(iproc)
798 if (ncount(iproc).ge.1) then
799 nsend = nsend + 1
800 endif
801 enddo
802
803 if (lidebug.ge.1) then
804 call write_debug( name, 'ncount = ', ncount )
805 call write_debug( name, 'nsend, ntotal ', nsend, ntotal )
806 endif
807
808
809 allocate( xsend(nsend+1) )
810
811 allocate( sendijk( max(1,ntotal) ) )
812 allocate( sendproc(max(1,nsend)) )
813
814 nsend = 0
815 do iproc=0,numPEs-1
816 if (ncount(iproc).ne.0) then
817 nsend = nsend + 1
818 sendproc(nsend) = iproc
819 endif
820 enddo
821
822 xsend(1) = 1
823 do i=1,nsend
824 iproc = sendproc(i)
825 xsend(i+1) = xsend(i) + ncount(iproc)
826 enddo
827
828 allocate( sendtag( max(1,nsend) ) )
829 do ii=1,nsend
830 iproc = sendproc(ii)
831 src = myPE
832 dest = iproc
833 sendtag(ii) = message_tag( src, dest )
834 enddo
835
836
837
838
839
840
841 ipos = 1
842 do iter=1,nsend
843 iproc = sendproc(iter)
844 icount = 0
845
846 do k=kstartx(iproc),kendx(iproc)
847
848 if (jfastest) then
849
850 do i=istartx(iproc),iendx(iproc)
851 do j=jstartx(iproc),jendx(iproc)
852
853
854 ii = imap(i)
855 jj = jmap(j)
856 kk = kmap(k)
857 jproc = ijk2proc(ii,jj,kk)
858 ismine = (jproc.eq.myPE)
859 if (ismine) then
860 icount = icount + 1
861 ijk = funijk(ii,jj,kk)
862
863 ipos = xsend(iter)-1 + icount
864 sendijk( ipos ) = ijk
865 endif
866
867 enddo
868 enddo
869
870
871 else
872
873 do j=jstartx(iproc),jendx(iproc)
874 do i=istartx(iproc),iendx(iproc)
875
876
877 ii = imap(i)
878 jj = jmap(j)
879 kk = kmap(k)
880 jproc = ijk2proc(ii,jj,kk)
881 ismine = (jproc.eq.myPE)
882 if (ismine) then
883 icount = icount + 1
884 ijk = funijk(ii,jj,kk)
885
886 ipos = xsend(iter)-1 + icount
887 sendijk( ipos ) = ijk
888 endif
889
890 enddo
891 enddo
892
893 endif
894 enddo
895
896 isvalid = (icount .eq. ncount(iproc))
897 call assert( isvalid, &
898 '** sendrecv3_init: icount != ncount(iproc) ', iproc)
899
900 enddo
901
902
903
904 if (lidebug.ge.1) then
905 call write_debug(name, 'determine recv schedule ', myPE )
906 endif
907
908
909
910
911
912
913
914
915
916
917
918
919 ncount(:) = 0
920
921 k1 = lbound(ijk2proc,3)
922 k2 = ubound(ijk2proc,3)
923 j1 = lbound(ijk2proc,2)
924 j2 = ubound(ijk2proc,2)
925 i1 = lbound(ijk2proc,1)
926 i2 = ubound(ijk2proc,1)
927
928
929 do k=kstartx(myPE),kendx(myPE)
930 do j=jstartx(myPE),jendx(myPE)
931 do i=istartx(myPE),iendx(myPE)
932
933 ii = imap(i)
934 jj = jmap(j)
935 kk = kmap(k)
936
937 isvalid = (k1.le.kk).and.(kk.le.k2)
938 call assert( isvalid, '** sendrecv3_init: invalid kk ', kk )
939
940 isvalid = (j1.le.jj).and.(jj.le.j2)
941 call assert( isvalid, '** sendrecv3_init: invalid jj ', jj )
942
943 isvalid = (i1.le.ii).and.(ii.le.i2)
944 call assert( isvalid, '** sendrecv3_init: invalid ii ', ii )
945
946
947
948
949
950 iproc = ijk2proc(ii,jj,kk)
951 is_halobc = (iproc.eq.-1)
952 ismine = (iproc.eq.myPE)
953 if (.not.ismine) then
954
955 isvalid = (0 .le. iproc) .and. &
956 (iproc.le.numPEs-1) .and. &
957 (iproc.ne.myPE)
958
959 call assert( isvalid, &
960 '** sendrecv3_init: invalid iproc ',iproc)
961
962 ncount(iproc) = ncount(iproc) + 1
963 endif
964 enddo
965 enddo
966 enddo
967
968 ncount(myPE) = 0
969
970 ntotal = 0
971 do iproc=0,numPEs-1
972 ntotal = ntotal + ncount(iproc)
973 enddo
974
975 nrecv = count( ncount(:) .ne. 0)
976
977 allocate( recvproc( max(1,nrecv) ) )
978
979 nrecv = 0
980 do iproc=0,numPEs-1
981 if (ncount(iproc).ne.0) then
982 nrecv = nrecv + 1
983 recvproc(nrecv) = iproc
984 endif
985 enddo
986
987 allocate( xrecv(nrecv+1) )
988 allocate( recvijk(max(1,ntotal)) )
989
990 xrecv(1) = 1
991 do iter=1,nrecv
992 iproc = recvproc(iter)
993 xrecv(iter+1) = xrecv(iter) + ncount(iproc)
994 enddo
995
996 allocate( recvtag( max(1,nrecv) ) )
997
998 do iter=1,nrecv
999 iproc = recvproc(iter)
1000 src = iproc
1001 dest = myPE
1002 recvtag(iter) = message_tag( src, dest )
1003 enddo
1004
1005
1006
1007
1008
1009 if (lidebug.ge.1) then
1010 call write_debug( name, 'recv second pass ', myPE )
1011 endif
1012
1013 ipos = 1
1014
1015 do iter=1,nrecv
1016 jproc = recvproc(iter)
1017
1018 do k=kstartx(myPE),kendx(myPE)
1019
1020 if (jfastest) then
1021
1022 do i=istartx(myPE),iendx(myPE)
1023 do j=jstartx(myPE),jendx(myPE)
1024
1025 ii = imap(i)
1026 jj = jmap(j)
1027 kk = kmap(k)
1028
1029 iproc = ijk2proc(ii,jj,kk)
1030 is_halobc = (iproc.eq.-1)
1031
1032 ismine = (iproc.eq.myPE)
1033 if ((.not.ismine) .and. (iproc.eq.jproc)) then
1034
1035
1036 ijk = funijk( i,j,k)
1037 recvijk( ipos ) = ijk
1038 ipos = ipos + 1
1039 endif
1040 enddo
1041 enddo
1042
1043
1044
1045 else
1046
1047 do j=jstartx(myPE),jendx(myPE)
1048 do i=istartx(myPE),iendx(myPE)
1049
1050 ii = imap(i)
1051 jj = jmap(j)
1052 kk = kmap(k)
1053
1054 iproc = ijk2proc(ii,jj,kk)
1055 is_halobc = (iproc.eq.-1)
1056
1057 ismine = (iproc.eq.myPE)
1058 if ((.not.ismine) .and. (iproc.eq.jproc)) then
1059
1060
1061 ijk = funijk( i,j,k)
1062 recvijk( ipos ) = ijk
1063 ipos = ipos + 1
1064 endif
1065 enddo
1066 enddo
1067
1068 endif
1069 enddo
1070
1071 enddo
1072
1073 if (ilayer.eq.1) then
1074
1075 nsend1 = nsend
1076 xsend1 => xsend
1077 sendijk1 => sendijk
1078 sendproc1 => sendproc
1079 sendtag1 => sendtag
1080
1081 nrecv1 = nrecv
1082 xrecv1 => xrecv
1083 recvijk1 => recvijk
1084 recvproc1 => recvproc
1085 recvtag1 => recvtag
1086
1087 else if (ilayer.eq.2) then
1088
1089 nsend2 = nsend
1090 xsend2 => xsend
1091 sendijk2 => sendijk
1092 sendproc2 => sendproc
1093 sendtag2 => sendtag
1094
1095 nrecv2 = nrecv
1096 xrecv2 => xrecv
1097 recvijk2 => recvijk
1098 recvproc2 => recvproc
1099 recvtag2 => recvtag
1100
1101 else if (ilayer.eq.3) then
1102
1103
1104
1105 nsend3 = nsend
1106 xsend3 => xsend
1107 sendijk3 => sendijk
1108 sendproc3 => sendproc
1109 sendtag3 => sendtag
1110
1111 nrecv3 = nrecv
1112 xrecv3 => xrecv
1113 recvijk3 => recvijk
1114 recvproc3 => recvproc
1115 recvtag3 => recvtag
1116
1117
1118 endif
1119
1120
1121 nullify( xsend )
1122 nullify( sendijk )
1123 nullify( sendproc )
1124 nullify( sendtag )
1125
1126 nullify( xrecv )
1127 nullify( recvijk )
1128 nullify( recvproc )
1129 nullify( recvtag )
1130
1131 enddo
1132
1133
1134 deallocate( ncount )
1135 deallocate( ijk2proc )
1136
1137 deallocate( istartx )
1138 deallocate( jstartx )
1139 deallocate( kstartx )
1140 deallocate( iendx )
1141 deallocate( jendx )
1142 deallocate( kendx )
1143
1144 nullify( ncount )
1145 nullify( ijk2proc )
1146
1147 nullify( istartx )
1148 nullify( jstartx )
1149 nullify( kstartx )
1150 nullify( iendx )
1151 nullify( jendx )
1152 nullify( kendx )
1153
1154
1155
1156 if (lidebug.ge.1) then
1157
1158 call write_debug( name, ' allocate message buffers ' )
1159 call write_debug( name, 'nrecv1 ', nrecv1 )
1160 call write_debug( name, 'recvproc1 ', recvproc1 )
1161 call write_debug( name, 'recvtag1 ', recvtag1 )
1162 call write_debug( name, 'xrecv1 ', xrecv1 )
1163
1164
1165 lmax = size(recvijk1)
1166 allocate( line(lmax) )
1167 line(:) = " "
1168
1169 ip = 1
1170 do ii=lbound(recvijk1,1),ubound(recvijk1,1)
1171 ijk = recvijk1(ii)
1172 if(localfunc) then
1173 call ijk_of(ijk,i,j,k)
1174 else
1175 i = i_of(ijk)
1176 j = j_of(ijk)
1177 k = k_of(ijk)
1178 endif
1179 write(line(ip),9001) ii,ijk, i,j,k
1180 9001 format('recvijk1( ', i6,') = ', &
1181 i6, '( ', i6,',',i6,',',i6,') ')
1182 ip = ip + 1
1183 enddo
1184 call write_error( name, line, lmax )
1185 deallocate( line )
1186 nullify( line )
1187
1188 lmax = size(recvijk2)
1189 allocate( line(lmax) )
1190 line(:) = " "
1191
1192 ip = 1
1193 do ii=lbound(recvijk2,1),ubound(recvijk2,1)
1194 ijk = recvijk2(ii)
1195 if(localfunc) then
1196 call ijk_of(ijk,i,j,k)
1197 else
1198 i = i_of(ijk)
1199 j = j_of(ijk)
1200 k = k_of(ijk)
1201 endif
1202
1203 write(line(ip),9101) ii,ijk, i,j,k
1204 9101 format('recvijk2( ', i6,') = ', &
1205 i6, '( ', i6,',',i6,',',i6,') ')
1206 ip = ip + 1
1207 enddo
1208 call write_error( name, line, lmax )
1209 deallocate( line )
1210 nullify( line )
1211
1212
1213 call write_debug( name, ' allocate message buffers ' )
1214 call write_debug( name, 'nsend1 ', nsend1 )
1215 call write_debug( name, 'sendproc1 ', sendproc1 )
1216 call write_debug( name, 'sendtag1 ', sendtag1 )
1217 call write_debug( name, 'xsend1 ', xsend1 )
1218
1219
1220
1221 lmax = size(sendijk1)
1222 allocate(line(lmax))
1223 line(:) = " "
1224
1225 ip = 1
1226 do ii=lbound(sendijk1,1),ubound(sendijk1,1)
1227 ijk = sendijk1(ii)
1228 if(localfunc) then
1229 call ijk_of(ijk,i,j,k)
1230 else
1231 i = i_of(ijk)
1232 j = j_of(ijk)
1233 k = k_of(ijk)
1234 endif
1235
1236 write(line(ip),9002) ii,ijk, i,j,k
1237 9002 format('sendijk1( ', i6,') = ', &
1238 i6, '( ', i6,',',i6,',',i6,') ')
1239 ip = ip + 1
1240 enddo
1241
1242 call write_error( name, line, lmax )
1243 deallocate( line )
1244 nullify( line )
1245
1246
1247 lmax = size(sendijk2)
1248 allocate(line(lmax))
1249 line(:) = " "
1250
1251 ip = 1
1252 do ii=lbound(sendijk2,1),ubound(sendijk2,1)
1253 ijk = sendijk2(ii)
1254 if(localfunc) then
1255 call ijk_of(ijk,i,j,k)
1256 else
1257 i = i_of(ijk)
1258 j = j_of(ijk)
1259 k = k_of(ijk)
1260 endif
1261
1262 write(line(ip),9102) ii,ijk, i,j,k
1263 9102 format('sendijk2( ', i6,') = ', &
1264 i6, '( ', i6,',',i6,',',i6,') ')
1265 ip = ip + 1
1266 enddo
1267
1268 call write_error( name, line, lmax )
1269 deallocate( line )
1270 nullify( line )
1271
1272
1273
1274 endif
1275
1276
1277
1278
1279
1280
1281
1282
1283 isize = max(1,max(nsend1,nsend2))
1284 allocate( sendrequest( isize ) )
1285 allocate( send_persistent_request1( isize ) )
1286 allocate( send_persistent_request2( isize ) )
1287
1288 isize = max(1,max(nrecv1,nrecv2))
1289 allocate( recvrequest( isize ) )
1290 allocate( recv_persistent_request1( isize ) )
1291 allocate( recv_persistent_request2( isize ) )
1292
1293
1294
1295
1296 recvsize1 = xrecv1( nrecv1+1)-1
1297 recvsize2 = xrecv2( nrecv2+1)-1
1298
1299 isize = max(1,max(recvsize1,recvsize2))
1300 allocate( drecvbuffer( isize ) )
1301
1302 sendsize1 = xsend1( nsend1+1)-1
1303 sendsize2 = xsend2( nsend2+1)-1
1304
1305 isize = max(1,max(sendsize1,sendsize2))
1306 allocate( dsendbuffer( isize ) )
1307
1308
1309 if (use_persistent_message) then
1310
1311 datatype = MPI_DOUBLE_PRECISION
1312
1313 do layer=nlayers,nlayers
1314
1315
1316 if (layer.eq.1) then
1317 nrecv = nrecv1
1318 recvtag =>recvtag1
1319 recvproc => recvproc1
1320 recvijk => recvijk1
1321 xrecv => xrecv1
1322
1323 nsend = nsend1
1324 sendtag => sendtag1
1325 sendproc => sendproc1
1326 sendijk => sendijk1
1327 xsend => xsend1
1328
1329 send_persistent_request => send_persistent_request1
1330 recv_persistent_request => recv_persistent_request1
1331
1332 else if (layer.eq.2) then
1333 nrecv = nrecv2
1334 recvtag =>recvtag2
1335 recvproc => recvproc2
1336 recvijk => recvijk2
1337 xrecv => xrecv2
1338
1339 nsend = nsend2
1340 sendtag => sendtag2
1341 sendproc => sendproc2
1342 sendijk => sendijk2
1343 xsend => xsend2
1344
1345 send_persistent_request => send_persistent_request2
1346 recv_persistent_request => recv_persistent_request2
1347
1348 else if (layer.eq.3) then
1349
1350
1351
1352
1353 nrecv = nrecv3
1354 recvtag =>recvtag3
1355 recvproc => recvproc3
1356 recvijk => recvijk3
1357 xrecv => xrecv3
1358
1359 nsend = nsend3
1360 sendtag => sendtag3
1361 sendproc => sendproc3
1362 sendijk => sendijk3
1363 xsend => xsend3
1364
1365 send_persistent_request => send_persistent_request3
1366 recv_persistent_request => recv_persistent_request3
1367
1368 endif
1369
1370
1371
1372 do ii=1,nrecv
1373 j1 = xrecv(ii)
1374 j2 = xrecv(ii+1)-1
1375 icount = j2-j1+1
1376 source = recvproc( ii )
1377 tag = recvtag( ii )
1378
1379
1380 if (lidebug.ge.2) then
1381
1382 call write_debug(name, 'mpi_recv_init: ii,j1,j2 ', &
1383 ii,j1,j2 )
1384 call write_debug(name, 'icount, source, tag ', &
1385 icount,source,tag )
1386 endif
1387
1388
1389 call MPI_RECV_INIT( drecvbuffer(j1), icount, datatype, &
1390 source, tag, comm, request, ierror )
1391 call MPI_Check( 'sendrecv3_begin_1d:MPI_IRECV ', ierror )
1392
1393 recv_persistent_request(ii) = request
1394 enddo
1395
1396
1397 do ii=1,nsend
1398 j1 = xsend(ii)
1399 j2 = xsend(ii+1)-1
1400 dest = sendproc( ii )
1401 tag = sendtag( ii )
1402 icount = j2-j1+1
1403
1404 if (lidebug.ge.2) then
1405
1406 call write_debug(name, 'mpi_send_init: ii,j1,j2 ', &
1407 ii,j1,j2)
1408 call write_debug(name, 'icount, dest, tag ', &
1409 icount,dest,tag )
1410 endif
1411
1412
1413 call MPI_SEND_INIT( dsendbuffer(j1), icount, datatype, &
1414 dest, tag, &
1415 comm, request, ierror )
1416 call MPI_Check( 'sendrecv3_begin_1d:MPI_SEND_INIT ', ierror )
1417
1418 send_persistent_request( ii ) = request
1419 enddo
1420 enddo
1421
1422 endif
1423
1424 if (lidebug.ge.1) then
1425 call write_debug(name, ' end of sendrecv3_init ', myPE )
1426 endif
1427
1428 #endif
1429 return
1430
1431 end subroutine sendrecv3_init
1432
1433
1434
1435 subroutine sendrecv3_begin_1d( XX, ilayer, idebug )
1436
1437 use functions
1438
1439 implicit none
1440
1441 integer, intent(in),optional :: ilayer
1442 double precision, intent(inout), dimension(:) :: XX
1443 integer, intent(in), optional :: idebug
1444
1445 #ifdef MPI
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466 character(len=80), parameter :: name = 'sendrecv3_begin_1d'
1467
1468 integer :: lidebug
1469
1470 integer :: layer, datatype, comm, recvsize, sendsize, &
1471 ijk,jj,j1,j2, request, ii,count,source,dest, tag, ierror
1472
1473 lidebug = 0
1474
1475 if (present(idebug)) then
1476 lidebug = idebug
1477 endif
1478
1479 layer = 1
1480 if (present(ilayer)) then
1481 layer = ilayer
1482 endif
1483
1484 if (layer.eq.1) then
1485 nrecv = nrecv1
1486 recvtag =>recvtag1
1487 recvproc => recvproc1
1488 recvijk => recvijk1
1489 xrecv => xrecv1
1490
1491 nsend = nsend1
1492 sendtag => sendtag1
1493 sendproc => sendproc1
1494 sendijk => sendijk1
1495 xsend => xsend1
1496
1497 send_persistent_request => send_persistent_request1
1498 recv_persistent_request => recv_persistent_request1
1499
1500 else if (layer.eq.2) then
1501 nrecv = nrecv2
1502 recvtag =>recvtag2
1503 recvproc => recvproc2
1504 recvijk => recvijk2
1505 xrecv => xrecv2
1506
1507 nsend = nsend2
1508 sendtag => sendtag2
1509 sendproc => sendproc2
1510 sendijk => sendijk2
1511 xsend => xsend2
1512
1513 send_persistent_request => send_persistent_request2
1514 recv_persistent_request => recv_persistent_request2
1515
1516 else if (layer.eq.3) then
1517
1518
1519
1520
1521 nrecv = nrecv3
1522 recvtag =>recvtag3
1523 recvproc => recvproc3
1524 recvijk => recvijk3
1525 xrecv => xrecv3
1526
1527 nsend = nsend3
1528 sendtag => sendtag3
1529 sendproc => sendproc3
1530 sendijk => sendijk3
1531 xsend => xsend3
1532
1533 send_persistent_request => send_persistent_request3
1534 recv_persistent_request => recv_persistent_request3
1535
1536 endif
1537
1538
1539
1540
1541
1542
1543 if (lidebug.ge.1) then
1544 call write_debug(name, 'post asynchronous receives, nrecv = ', nrecv )
1545 endif
1546
1547 if (nrecv.ge.1) then
1548 recvsize = xrecv( nrecv+1)-1
1549
1550
1551 if (lidebug.ge.1) then
1552 call write_debug( name, 'recvsize, ubound(drecvbuffer,1) ', &
1553 recvsize, ubound(drecvbuffer,1) )
1554
1555 call write_debug( name, 'ubound(xrecv,1) ', &
1556 ubound(xrecv,1) )
1557 call write_debug( name, 'ubound(recvproc,1) ', &
1558 ubound(recvproc,1) )
1559 call write_debug( name, 'ubound(recvtag,1) ', &
1560 ubound(recvtag,1) )
1561
1562 endif
1563
1564
1565
1566
1567 datatype = MPI_DOUBLE_PRECISION
1568 comm = communicator
1569
1570 if (use_persistent_message) then
1571
1572
1573
1574
1575 if (lidebug.ge.2) then
1576 call write_debug( name,'before startall for recv ',&
1577 recv_persistent_request)
1578 endif
1579
1580 call MPI_STARTALL( nrecv, recv_persistent_request, ierror )
1581
1582 if (lidebug.ge.2) then
1583 call write_debug( name,'after startall for recv, ierror',&
1584 ierror)
1585 endif
1586
1587 call MPI_Check( 'sendrecv3_begin: MPI_STARTALL ', ierror )
1588
1589
1590 else
1591
1592
1593
1594
1595 do ii=1,nrecv
1596 j1 = xrecv(ii)
1597 j2 = xrecv(ii+1)-1
1598 count = j2-j1+1
1599 source = recvproc( ii )
1600 tag = recvtag( ii )
1601
1602
1603 if (lidebug.ge.2) then
1604
1605 call write_debug(name, 'mpi_irecv: ii,j1,j2 ', ii,j1,j2 )
1606 call write_debug(name, 'count, source, tag ', &
1607 count,source,tag )
1608 endif
1609
1610 call MPI_IRECV( drecvbuffer(j1), count, datatype, source, tag, &
1611 comm, request, ierror )
1612
1613 call MPI_Check( 'sendrecv3_begin_1d:MPI_IRECV ', ierror )
1614
1615 recvrequest( ii ) = request
1616 enddo
1617 endif
1618
1619 endif
1620
1621
1622
1623
1624
1625 if (lidebug.ge.1) then
1626
1627 call write_debug(name, 'post asynchronous sends ')
1628 endif
1629
1630 if (nsend.ge.1) then
1631 sendsize = xsend( nsend+1)-1
1632
1633
1634 if (lidebug.ge.1) then
1635
1636 call write_debug( name, &
1637 'sendsize, ubound(dsendbuffer,1) ', &
1638 sendsize, ubound(dsendbuffer,1) )
1639
1640 call write_debug( name, 'ubound(xsend,1) ', &
1641 ubound(xsend,1) )
1642 call write_debug( name, 'ubound(sendproc,1) ', &
1643 ubound(sendproc,1) )
1644 call write_debug( name, 'ubound(sendtag,1) ', &
1645 ubound(sendtag,1) )
1646
1647 endif
1648
1649
1650
1651
1652
1653
1654
1655 datatype = MPI_DOUBLE_PRECISION
1656 comm = communicator
1657
1658 if (use_persistent_message) then
1659
1660
1661
1662
1663 j1 = xsend(1)
1664 j2 = xsend(nsend+1)-1
1665
1666 do jj=j1,j2
1667 ijk = sendijk( jj )
1668 dsendbuffer( jj ) = XX(ijk)
1669 enddo
1670
1671
1672
1673 if (lidebug.ge.2) then
1674 call write_debug(name,'before mpi_startall send ',&
1675 send_persistent_request )
1676 endif
1677
1678 call MPI_STARTALL( nsend, send_persistent_request, ierror )
1679
1680 if (lidebug .ge.2) then
1681 call write_debug(name,'after mpi_startall send ',&
1682 send_persistent_request )
1683 endif
1684
1685 call MPI_Check( 'sendrecv3_begin_1d:MPI_STARTALL ', ierror )
1686
1687
1688 else
1689
1690 do ii=1,nsend
1691
1692
1693
1694
1695
1696 j1 = xsend(ii)
1697 j2 = xsend(ii+1)-1
1698 count = j2-j1+1
1699
1700 do jj=j1,j2
1701 ijk = sendijk( jj )
1702 dsendbuffer(jj) = XX(ijk)
1703 enddo
1704
1705 dest = sendproc( ii )
1706 tag = sendtag( ii )
1707
1708 if (lidebug.ge.2) then
1709
1710 call write_debug(name, 'mpi_isend: ii,j1,j2 ', ii,j1,j2)
1711 call write_debug(name, 'count, dest, tag ', count,dest,tag )
1712 endif
1713
1714
1715 call MPI_ISEND( dsendbuffer(j1), count, datatype, dest, tag, &
1716 comm, request, ierror )
1717 call MPI_Check( 'sendrecv3_begin_1d:MPI_ISEND ', ierror )
1718
1719 sendrequest( ii ) = request
1720 enddo
1721
1722 endif
1723
1724 endif
1725
1726 #endif
1727
1728 return
1729 end subroutine sendrecv3_begin_1d
1730
1731
1732 subroutine sendrecv3_begin_1i( XX, ilayer, idebug )
1733
1734 use functions
1735
1736 implicit none
1737
1738 integer, intent(in),optional :: ilayer
1739 integer, intent(inout), dimension(:) :: XX
1740 integer, intent(in), optional :: idebug
1741
1742 #ifdef MPI
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763 character(len=80), parameter :: name = 'sendrecv3_begin_1i'
1764
1765 integer :: lidebug
1766
1767 integer :: layer, datatype, comm, recvsize, sendsize, &
1768 ijk,jj,j1,j2, request, ii,count,source,dest, tag, ierror
1769
1770 lidebug = 0
1771 if (present(idebug)) then
1772 lidebug = idebug
1773 endif
1774
1775 layer = 1
1776 if (present(ilayer)) then
1777 layer = ilayer
1778 endif
1779
1780 if (layer.eq.1) then
1781 nrecv = nrecv1
1782 recvtag =>recvtag1
1783 recvproc => recvproc1
1784 recvijk => recvijk1
1785 xrecv => xrecv1
1786
1787 nsend = nsend1
1788 sendtag => sendtag1
1789 sendproc => sendproc1
1790 sendijk => sendijk1
1791 xsend => xsend1
1792 else if (layer.eq.2) then
1793 nrecv = nrecv2
1794 recvtag =>recvtag2
1795 recvproc => recvproc2
1796 recvijk => recvijk2
1797 xrecv => xrecv2
1798
1799 nsend = nsend2
1800 sendtag => sendtag2
1801 sendproc => sendproc2
1802 sendijk => sendijk2
1803 xsend => xsend2
1804 else if (layer.eq.3) then
1805
1806
1807
1808 nrecv = nrecv3
1809 recvtag =>recvtag3
1810 recvproc => recvproc3
1811 recvijk => recvijk3
1812 xrecv => xrecv3
1813
1814 nsend = nsend3
1815 sendtag => sendtag3
1816 sendproc => sendproc3
1817 sendijk => sendijk3
1818 xsend => xsend3
1819 endif
1820
1821
1822
1823
1824
1825
1826 if (lidebug.ge.1) then
1827 call write_debug(name, &
1828 'post asynchronous receives, nrecv = ', nrecv )
1829 endif
1830
1831 if (nrecv.ge.1) then
1832 recvsize = xrecv( nrecv+1)-1
1833 allocate( irecvbuffer( recvsize ) )
1834
1835 if (lidebug.ge.1) then
1836 call write_debug( name, &
1837 'recvsize, ubound(irecvbuffer,1) ', &
1838 recvsize, ubound(irecvbuffer,1) )
1839
1840 call write_debug( name, 'ubound(xrecv,1) ', &
1841 ubound(xrecv,1) )
1842 call write_debug( name, 'ubound(recvproc,1) ', &
1843 ubound(recvproc,1) )
1844 call write_debug( name, 'ubound(recvtag,1) ', &
1845 ubound(recvtag,1) )
1846
1847 endif
1848
1849
1850
1851
1852 datatype = MPI_INTEGER
1853 comm = communicator
1854
1855 do ii=1,nrecv
1856 j1 = xrecv(ii)
1857 j2 = xrecv(ii+1)-1
1858 count = j2-j1+1
1859 source = recvproc( ii )
1860 tag = recvtag( ii )
1861
1862
1863 if (lidebug.ge.2) then
1864
1865 call write_debug(name, 'mpi_irecv: ii,j1,j2 ', ii,j1,j2 )
1866 call write_debug(name, 'count, source, tag ', &
1867 count,source,tag )
1868 endif
1869
1870 call MPI_IRECV( irecvbuffer(j1), count, datatype, source, tag, &
1871 comm, request, ierror )
1872
1873 call MPI_Check( 'sendrecv3_begin_1i:MPI_IRECV ', ierror )
1874
1875 recvrequest( ii ) = request
1876 enddo
1877
1878 endif
1879
1880
1881
1882
1883
1884 if (lidebug.ge.1) then
1885
1886 call write_debug(name, 'post asynchronous sends ')
1887 endif
1888
1889 if (nsend.ge.1) then
1890 sendsize = xsend( nsend+1)-1
1891 allocate( isendbuffer( sendsize ) )
1892
1893 if (lidebug.ge.1) then
1894
1895 call write_debug( name, 'sendsize, ubound(isendbuffer,1) ', &
1896 sendsize, ubound(isendbuffer,1) )
1897
1898 call write_debug( name, 'ubound(xsend,1) ', &
1899 ubound(xsend,1) )
1900 call write_debug( name, 'ubound(sendproc,1) ', &
1901 ubound(sendproc,1) )
1902 call write_debug( name, 'ubound(sendtag,1) ', &
1903 ubound(sendtag,1) )
1904
1905 endif
1906
1907
1908
1909
1910
1911
1912
1913 datatype = MPI_INTEGER
1914 comm = communicator
1915
1916 do ii=1,nsend
1917
1918
1919
1920
1921
1922 j1 = xsend(ii)
1923 j2 = xsend(ii+1)-1
1924 count = j2-j1+1
1925
1926 do jj=j1,j2
1927 ijk = sendijk( jj )
1928 isendbuffer(jj) = XX(ijk)
1929 enddo
1930
1931 dest = sendproc( ii )
1932 tag = sendtag( ii )
1933
1934 if (lidebug.ge.2) then
1935
1936 call write_debug(name, 'mpi_isend: ii,j1,j2 ', ii,j1,j2)
1937 call write_debug(name, 'count, dest, tag ', count,dest,tag )
1938 endif
1939
1940
1941 call MPI_ISEND( isendbuffer(j1), count, datatype, dest, tag, &
1942 comm, request, ierror )
1943 call MPI_Check( 'sendrecv3_begin_1i:MPI_ISEND ', ierror )
1944
1945 sendrequest( ii ) = request
1946 enddo
1947
1948 endif
1949
1950 #endif
1951
1952 return
1953 end subroutine sendrecv3_begin_1i
1954
1955
1956 subroutine sendrecv3_begin_1c( XX, ilayer, idebug )
1957
1958 use functions
1959
1960 implicit none
1961
1962 integer, intent(in),optional :: ilayer
1963 character(len=*), intent(inout), dimension(:) :: XX
1964 integer, intent(in), optional :: idebug
1965
1966 #ifdef MPI
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990 character(len=80), parameter :: name = 'sendrecv3_begin_1c'
1991
1992 integer :: lidebug
1993
1994 integer :: layer, datatype, comm, recvsize, sendsize, &
1995 ijk,jj,j1,j2, request, ii,count,source,dest, tag, ierror
1996
1997 integer :: ic, clen, jpos
1998
1999 lidebug = 0
2000 if (present(idebug)) then
2001 lidebug = idebug
2002 endif
2003
2004 layer = 1
2005 if (present(ilayer)) then
2006 layer = ilayer
2007 endif
2008
2009 jpos = lbound(XX,1)
2010 clen = len( XX( jpos ) )
2011
2012 if (layer.eq.1) then
2013 nrecv = nrecv1
2014 recvtag =>recvtag1
2015 recvproc => recvproc1
2016 recvijk => recvijk1
2017 xrecv => xrecv1
2018
2019 nsend = nsend1
2020 sendtag => sendtag1
2021 sendproc => sendproc1
2022 sendijk => sendijk1
2023 xsend => xsend1
2024 else if (layer.eq.2) then
2025 nrecv = nrecv2
2026 recvtag =>recvtag2
2027 recvproc => recvproc2
2028 recvijk => recvijk2
2029 xrecv => xrecv2
2030
2031 nsend = nsend2
2032 sendtag => sendtag2
2033 sendproc => sendproc2
2034 sendijk => sendijk2
2035 xsend => xsend2
2036 else if (layer.eq.3) then
2037
2038
2039
2040
2041 nrecv = nrecv3
2042 recvtag =>recvtag3
2043 recvproc => recvproc3
2044 recvijk => recvijk3
2045 xrecv => xrecv3
2046
2047 nsend = nsend3
2048 sendtag => sendtag3
2049 sendproc => sendproc3
2050 sendijk => sendijk3
2051 xsend => xsend3
2052 endif
2053
2054
2055
2056
2057
2058
2059 if (lidebug.ge.1) then
2060 call write_debug(name, 'post asynchronous receives, nrecv = ', nrecv )
2061 endif
2062
2063 if (nrecv.ge.1) then
2064 recvsize = xrecv( nrecv+1)-1
2065
2066 allocate( crecvbuffer( recvsize*clen ) )
2067
2068 if (lidebug.ge.1) then
2069 call write_debug( name, 'recvsize, ubound(crecvbuffer,1) ', &
2070 recvsize, ubound(crecvbuffer,1) )
2071
2072 call write_debug( name, 'ubound(xrecv,1) ', &
2073 ubound(xrecv,1) )
2074 call write_debug( name, 'ubound(recvproc,1) ', &
2075 ubound(recvproc,1) )
2076 call write_debug( name, 'ubound(recvtag,1) ', &
2077 ubound(recvtag,1) )
2078
2079 endif
2080
2081
2082
2083
2084 datatype = MPI_CHARACTER
2085 comm = communicator
2086
2087 do ii=1,nrecv
2088 j1 = xrecv(ii)
2089 j2 = xrecv(ii+1)-1
2090
2091 count = j2-j1+1
2092 count = count*clen
2093
2094 source = recvproc( ii )
2095 tag = recvtag( ii )
2096
2097
2098 if (lidebug.ge.2) then
2099
2100 call write_debug(name, 'mpi_irecv: ii,j1,j2 ', ii,j1,j2 )
2101 call write_debug(name, 'count, source, tag ', &
2102 count,source,tag )
2103 endif
2104
2105 jpos = 1 + (j1-1)*clen
2106 call MPI_IRECV( crecvbuffer(jpos), count, datatype, source, tag, &
2107 comm, request, ierror )
2108
2109 call MPI_Check( 'sendrecv3_begin_1c:MPI_IRECV ', ierror )
2110
2111 recvrequest( ii ) = request
2112 enddo
2113
2114 endif
2115
2116
2117
2118
2119
2120 if (lidebug.ge.1) then
2121
2122 call write_debug(name, 'post asynchronous sends ')
2123 endif
2124
2125 if (nsend.ge.1) then
2126 sendsize = xsend( nsend+1)-1
2127
2128 allocate( csendbuffer( sendsize*clen ) )
2129
2130 if (lidebug.ge.1) then
2131
2132 call write_debug( name, 'sendsize, ubound(csendbuffer,1) ', &
2133 sendsize, ubound(csendbuffer,1) )
2134
2135 call write_debug( name, 'ubound(xsend,1) ', &
2136 ubound(xsend,1) )
2137 call write_debug( name, 'ubound(sendproc,1) ', &
2138 ubound(sendproc,1) )
2139 call write_debug( name, 'ubound(sendtag,1) ', &
2140 ubound(sendtag,1) )
2141
2142 endif
2143
2144
2145
2146
2147
2148
2149
2150 datatype = MPI_CHARACTER
2151 comm = communicator
2152
2153 do ii=1,nsend
2154
2155
2156
2157
2158
2159 j1 = xsend(ii)
2160 j2 = xsend(ii+1)-1
2161
2162
2163 count = j2-j1+1
2164 count = count*clen
2165
2166 do jj=j1,j2
2167 ijk = sendijk( jj )
2168 do ic=1,clen
2169 jpos = (jj-1)*clen + ic
2170 csendbuffer(jpos) = XX(ijk)(ic:ic)
2171 enddo
2172 enddo
2173
2174 dest = sendproc( ii )
2175 tag = sendtag( ii )
2176
2177 if (lidebug.ge.2) then
2178
2179 call write_debug(name, 'mpi_isend: ii,j1,j2 ', ii,j1,j2)
2180 call write_debug(name, 'count, dest, tag ', count,dest,tag )
2181 endif
2182
2183
2184 jpos = (j1-1)*clen + 1
2185 call MPI_ISEND( csendbuffer(jpos), count, datatype, dest, tag, &
2186 comm, request, ierror )
2187 call MPI_Check( 'sendrecv3_begin_1c:MPI_ISEND ', ierror )
2188
2189 sendrequest( ii ) = request
2190 enddo
2191
2192 endif
2193 #endif
2194
2195 return
2196 end subroutine sendrecv3_begin_1c
2197
2198
2199 subroutine sendrecv3_end_1d( XX, idebug )
2200
2201 use functions
2202
2203 implicit none
2204
2205 double precision, intent(inout), dimension(:) :: XX
2206 integer, intent(in), optional :: idebug
2207
2208 #ifdef MPI
2209 interface
2210
2211 subroutine MPI_WAITANY(count, array_of_requests, jindex, &
2212 status, ierror)
2213 use mpi, only: MPI_STATUS_SIZE
2214
2215 integer count
2216 integer array_of_requests(*)
2217 integer jindex
2218 integer status(MPI_STATUS_SIZE)
2219 integer ierror
2220 end subroutine MPI_WAITANY
2221
2222 subroutine MPI_WAITALL( count, array_of_requests, &
2223 array_of_status, ierror )
2224 use mpi, only: MPI_STATUS_SIZE
2225
2226 integer count
2227 integer array_of_requests(*)
2228 integer array_of_status( MPI_STATUS_SIZE,*)
2229 integer ierror
2230 end subroutine MPI_WAITALL
2231
2232 end interface
2233
2234
2235
2236
2237 character(len=80), parameter :: name = 'sendrecv3_end_1d'
2238
2239 logical, parameter :: use_waitany = .false.
2240
2241 integer :: lidebug
2242 integer :: jj,ijk, jindex, ii,j1,j2, ierror
2243
2244 integer, dimension(MPI_STATUS_SIZE) :: recv_status
2245 integer, dimension(:,:), pointer :: send_status
2246
2247
2248
2249
2250
2251 lidebug = 0
2252 if (present(idebug)) then
2253 lidebug = idebug
2254 endif
2255
2256 if (nsend .ge.1) then
2257
2258 if (lidebug.ge.1) then
2259
2260 call write_debug(name, &
2261 'waiting for sends to complete, nsend = ', nsend )
2262 endif
2263
2264 allocate( send_status(MPI_STATUS_SIZE,nsend))
2265
2266 if (use_persistent_message) then
2267 call MPI_WAITALL( nsend, send_persistent_request, &
2268 send_status, ierror )
2269 else
2270 call MPI_WAITALL( nsend, sendrequest, send_status, ierror )
2271 endif
2272
2273 call MPI_Check( 'sendrecv3_end_1d:MPI_WAITALL ', ierror )
2274
2275 deallocate( send_status )
2276 nullify( send_status )
2277
2278
2279 endif
2280
2281
2282
2283
2284
2285 if (nrecv.ge.1) then
2286
2287 if (lidebug.ge.1) then
2288
2289 call write_debug( name, &
2290 'waiting for receives to complete, nrecv = ', nrecv )
2291 endif
2292
2293 if (use_waitany) then
2294 do ii=1,nrecv
2295
2296 if (use_persistent_message) then
2297 call MPI_WAITANY( nrecv, recv_persistent_request, &
2298 jindex, recv_status, ierror )
2299 else
2300 call MPI_WAITANY( nrecv, recvrequest, &
2301 jindex, recv_status, ierror )
2302 endif
2303
2304 call MPI_Check( 'sendrecv3_end_1d:MPI_WAITANY ', ierror )
2305
2306 j1 = xrecv( jindex )
2307 j2 = xrecv( jindex + 1)-1
2308
2309 if (lidebug.ge.2) then
2310 call write_debug(name, 'jindex, j1,j2 ', jindex,j1,j2 )
2311 endif
2312
2313 do jj=j1,j2
2314 ijk = recvijk( jj )
2315 XX(ijk) = drecvbuffer(jj)
2316 enddo
2317 enddo
2318 else
2319 if (use_persistent_message) then
2320 call MPI_WAITALL( nrecv, recv_persistent_request, recv_status, ierror )
2321 else
2322 call MPI_WAITALL( nrecv, recvrequest, recv_status, ierror )
2323 endif
2324 call MPI_Check( 'sendrecv3_end_1d:MPI_WAITALL recv ', ierror )
2325
2326 j1 = xrecv(1)
2327 j2 = xrecv( nrecv +1)-1
2328 do jj=j1,j2
2329 ijk = recvijk( jj )
2330 XX(ijk) = drecvbuffer(jj)
2331 enddo
2332 endif
2333 endif
2334 #endif
2335
2336 return
2337 end subroutine sendrecv3_end_1d
2338
2339
2340 subroutine sendrecv3_end_1c( XX, idebug )
2341
2342 use functions
2343
2344 implicit none
2345
2346 character(len=*), intent(inout), dimension(:) :: XX
2347 integer, intent(in), optional :: idebug
2348
2349 #ifdef MPI
2350 interface
2351
2352 subroutine MPI_WAITANY(count, array_of_requests, jindex, &
2353 status, ierror)
2354 use mpi, only: MPI_STATUS_SIZE
2355
2356 integer count
2357 integer array_of_requests(*)
2358 integer jindex
2359 integer status(MPI_STATUS_SIZE)
2360 integer ierror
2361 end subroutine MPI_WAITANY
2362
2363 subroutine MPI_WAITALL( count, array_of_requests, &
2364 array_of_status, ierror )
2365 use mpi, only: MPI_STATUS_SIZE
2366
2367 integer count
2368 integer array_of_requests(*)
2369 integer array_of_status( MPI_STATUS_SIZE,*)
2370 integer ierror
2371 end subroutine MPI_WAITALL
2372
2373 end interface
2374
2375
2376
2377
2378 character(len=80), parameter :: name = 'sendrecv3_end_1c'
2379
2380 integer :: ic, clen, jpos
2381
2382 logical, parameter :: use_waitany = .false.
2383
2384 integer :: lidebug
2385 integer :: jj,ijk, jindex, ii,j1,j2, ierror
2386
2387 integer, dimension(MPI_STATUS_SIZE) :: recv_status
2388 integer, dimension(:,:), pointer :: send_status
2389
2390
2391
2392
2393
2394 lidebug = 0
2395 if (present(idebug)) then
2396 lidebug = idebug
2397 endif
2398
2399 jpos = lbound(XX,1)
2400 clen = len(XX(jpos))
2401
2402 if (nsend .ge.1) then
2403
2404 if (lidebug.ge.1) then
2405
2406 call write_debug(name, &
2407 'waiting for sends to complete, nsend = ', nsend )
2408 endif
2409
2410
2411 allocate( send_status(MPI_STATUS_SIZE,nsend))
2412
2413 call MPI_WAITALL( nsend, sendrequest, send_status, ierror )
2414 call MPI_Check( 'sendrecv3_end_1c:MPI_WAITALL ', ierror )
2415
2416 deallocate( send_status )
2417 nullify( send_status )
2418
2419 deallocate( csendbuffer )
2420 nullify( csendbuffer )
2421
2422 endif
2423
2424
2425
2426
2427
2428 if (nrecv.ge.1) then
2429
2430 if (lidebug.ge.1) then
2431
2432 call write_debug( name, &
2433 'waiting for receives to complete, nrecv = ', nrecv )
2434 endif
2435
2436 if (use_waitany) then
2437 do ii=1,nrecv
2438 call MPI_WAITANY( nrecv, recvrequest, jindex, recv_status, ierror )
2439 call MPI_Check( 'sendrecv3_end_1c:MPI_WAITANY ', ierror )
2440
2441 j1 = xrecv( jindex )
2442 j2 = xrecv( jindex + 1)-1
2443
2444 if (lidebug.ge.2) then
2445 call write_debug(name, 'jindex, j1,j2 ', jindex,j1,j2 )
2446 endif
2447
2448 do jj=j1,j2
2449 ijk = recvijk( jj )
2450
2451 do ic=1,clen
2452 jpos = (jj-1)*clen + ic
2453 XX(ijk)(ic:ic) = crecvbuffer(jpos)
2454 enddo
2455
2456
2457 enddo
2458 enddo
2459 else
2460 call MPI_WAITALL( nrecv, recvrequest, recv_status, ierror )
2461 call MPI_Check( 'sendrecv3_end_1c:MPI_WAITALL recv ', ierror )
2462
2463 j1 = xrecv(1)
2464 j2 = xrecv( nrecv +1)-1
2465 do jj=j1,j2
2466 ijk = recvijk( jj )
2467
2468 do ic=1,clen
2469 jpos = (jj-1)*clen + ic
2470 XX(ijk)(ic:ic) = crecvbuffer(jpos)
2471 enddo
2472
2473
2474
2475 enddo
2476 endif
2477
2478 deallocate( crecvbuffer )
2479 nullify( crecvbuffer )
2480
2481 endif
2482 #endif
2483
2484 return
2485 end subroutine sendrecv3_end_1c
2486
2487
2488 subroutine sendrecv3_end_1i( XX, idebug )
2489
2490 use functions
2491
2492 implicit none
2493
2494 integer, intent(inout), dimension(:) :: XX
2495 integer, intent(in), optional :: idebug
2496
2497 #ifdef MPI
2498 interface
2499
2500 subroutine MPI_WAITANY(count, array_of_requests, jindex, &
2501 status, ierror)
2502 use mpi, only: MPI_STATUS_SIZE
2503
2504 integer count
2505 integer array_of_requests(*)
2506 integer jindex
2507 integer status(MPI_STATUS_SIZE)
2508 integer ierror
2509 end subroutine MPI_WAITANY
2510
2511 subroutine MPI_WAITALL( count, array_of_requests, &
2512 array_of_status, ierror )
2513 use mpi, only: MPI_STATUS_SIZE
2514
2515 integer count
2516 integer array_of_requests(*)
2517 integer array_of_status( MPI_STATUS_SIZE,*)
2518 integer ierror
2519 end subroutine MPI_WAITALL
2520
2521 end interface
2522
2523
2524
2525
2526 character(len=80), parameter :: name = 'sendrecv3_end_1i'
2527
2528 logical, parameter :: use_waitany = .false.
2529
2530 integer :: lidebug
2531 integer :: jj,ijk, jindex, ii,j1,j2, ierror
2532
2533 integer, dimension(MPI_STATUS_SIZE) :: recv_status
2534 integer, dimension(:,:), pointer :: send_status
2535
2536
2537
2538
2539
2540 lidebug = 0
2541 if (present(idebug)) then
2542 lidebug = idebug
2543 endif
2544
2545 if (nsend .ge.1) then
2546
2547 if (lidebug.ge.1) then
2548
2549 call write_debug(name, &
2550 'waiting for sends to complete, nsend = ', nsend )
2551 endif
2552
2553 allocate( send_status(MPI_STATUS_SIZE,nsend))
2554
2555 call MPI_WAITALL( nsend, sendrequest, send_status, ierror )
2556 call MPI_Check( 'sendrecv3_end_1i:MPI_WAITALL ', ierror )
2557
2558 deallocate( send_status )
2559 nullify( send_status )
2560
2561 deallocate( isendbuffer )
2562 nullify( isendbuffer )
2563
2564 endif
2565
2566
2567
2568
2569
2570 if (nrecv.ge.1) then
2571
2572 if (lidebug.ge.1) then
2573
2574 call write_debug( name, &
2575 'waiting for receives to complete, nrecv = ', nrecv )
2576 endif
2577
2578 if (use_waitany) then
2579 do ii=1,nrecv
2580 call MPI_WAITANY( nrecv, recvrequest, jindex, recv_status, ierror )
2581 call MPI_Check( 'sendrecv3_end_1i:MPI_WAITANY ', ierror )
2582
2583 j1 = xrecv( jindex )
2584 j2 = xrecv( jindex + 1)-1
2585
2586 if (lidebug.ge.2) then
2587 call write_debug(name, 'jindex, j1,j2 ', jindex,j1,j2 )
2588 endif
2589
2590 do jj=j1,j2
2591 ijk = recvijk( jj )
2592 XX(ijk) = irecvbuffer(jj)
2593 enddo
2594 enddo
2595 else
2596 call MPI_WAITALL( nrecv, recvrequest, recv_status, ierror )
2597 call MPI_Check( 'sendrecv3_end_1i:MPI_WAITALL recv ', ierror )
2598
2599 j1 = xrecv(1)
2600 j2 = xrecv( nrecv +1)-1
2601 do jj=j1,j2
2602 ijk = recvijk( jj )
2603 XX(ijk) = irecvbuffer(jj)
2604 enddo
2605 endif
2606
2607 deallocate( irecvbuffer )
2608 nullify( irecvbuffer )
2609
2610 endif
2611 #endif
2612
2613 return
2614 end subroutine sendrecv3_end_1i
2615
2616
2617 subroutine send_recv3_1c( XX, ilayer, idebug )
2618 implicit none
2619
2620 character(len=*), dimension(:), intent(inout) :: XX
2621 integer, intent(in), optional :: ilayer,idebug
2622
2623 integer :: lidebug, layer
2624
2625 #ifdef MPI
2626 lidebug = 0
2627 if (present(idebug)) then
2628 lidebug = idebug
2629 endif
2630
2631 layer = 1
2632 if (present(ilayer)) then
2633 layer = ilayer
2634 endif
2635
2636 call sendrecv3_begin(XX,layer,lidebug)
2637 call sendrecv3_end( XX, lidebug )
2638 #endif
2639
2640 return
2641 end subroutine send_recv3_1c
2642
2643 subroutine send_recv3_1d( XX, ilayer, idebug )
2644 implicit none
2645
2646 double precision, dimension(:), intent(inout) :: XX
2647 integer, intent(in), optional :: ilayer,idebug
2648
2649 integer :: lidebug, layer
2650
2651 #ifdef MPI
2652 lidebug = 0
2653 if (present(idebug)) then
2654 lidebug = idebug
2655 endif
2656
2657 layer = 1
2658 if (present(ilayer)) then
2659 layer = ilayer
2660 endif
2661
2662 call sendrecv3_begin(XX,layer,lidebug)
2663 call sendrecv3_end( XX, lidebug )
2664 #endif
2665
2666 return
2667 end subroutine send_recv3_1d
2668
2669 subroutine send_recv3_2d( XX, ilayer, idebug )
2670 implicit none
2671
2672 double precision, dimension(:,:), intent(inout) :: XX
2673 integer, intent(in), optional :: ilayer,idebug
2674
2675 integer :: lidebug, layer
2676 #ifdef MPI
2677 integer :: j
2678
2679 lidebug = 0
2680 if (present(idebug)) then
2681 lidebug = idebug
2682 endif
2683
2684 layer = 1
2685 if (present(ilayer)) then
2686 layer = ilayer
2687 endif
2688
2689 do j=lbound(XX,2),ubound(XX,2)
2690 call sendrecv3_begin(XX(:,j),layer,lidebug)
2691 call sendrecv3_end( XX(:,j), lidebug )
2692 enddo
2693 #endif
2694
2695 return
2696 end subroutine send_recv3_2d
2697
2698 subroutine send_recv3_3d( XX, ilayer, idebug )
2699 implicit none
2700
2701 double precision, dimension(:,:,:), intent(inout) :: XX
2702 integer, intent(in), optional :: ilayer,idebug
2703
2704 integer :: lidebug, layer
2705
2706 #ifdef MPI
2707 integer :: j,k
2708
2709 lidebug = 0
2710 if (present(idebug)) then
2711 lidebug = idebug
2712 endif
2713
2714 layer = 1
2715 if (present(ilayer)) then
2716 layer = ilayer
2717 endif
2718
2719 do k=lbound(XX,3),ubound(XX,3)
2720 do j=lbound(XX,2),ubound(XX,2)
2721 call sendrecv3_begin(XX(:,j,k),layer,lidebug)
2722 call sendrecv3_end( XX(:,j,k), lidebug )
2723 enddo
2724 enddo
2725 #endif
2726
2727 return
2728 end subroutine send_recv3_3d
2729
2730 subroutine send_recv3_1i( XX, ilayer, idebug )
2731 implicit none
2732
2733 integer, dimension(:), intent(inout) :: XX
2734 integer, intent(in), optional :: ilayer,idebug
2735
2736 integer :: lidebug, layer
2737
2738 #ifdef MPI
2739 lidebug = 0
2740 if (present(idebug)) then
2741 lidebug = idebug
2742 endif
2743
2744 layer = 1
2745 if (present(ilayer)) then
2746 layer = ilayer
2747 endif
2748
2749 call sendrecv3_begin(XX,layer,lidebug)
2750 call sendrecv3_end( XX, lidebug )
2751 #endif
2752
2753 return
2754 end subroutine send_recv3_1i
2755
2756
2757 end module sendrecv3
2758