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