1C
2C Copyright (C) by Argonne National Laboratory
3C     See COPYRIGHT in top-level directory
4C
5
6C This program is based on the allpair.f test from the MPICH-1 test
7C (test/pt2pt/allpair.f), which in turn was inspired by a bug report from
8C fsset@corelli.lerc.nasa.gov (Scott Townsend)
9
10      program sendrecvrepl
11      implicit none
12      include 'mpif.h'
13      integer ierr, errs, comm
14      logical mtestGetIntraComm
15      logical verbose
16      common /flags/ verbose
17
18      errs = 0
19      verbose = .false.
20C      verbose = .true.
21      call MTest_Init( ierr )
22
23      do while ( mtestGetIntraComm( comm, 2, .false. ) )
24         call test_pair_sendrecvrepl( comm, errs )
25         call mtestFreeComm( comm )
26      enddo
27C
28      call MTest_Finalize( errs )
29C
30      end
31C
32      subroutine test_pair_sendrecvrepl( comm, errs )
33      implicit none
34      include 'mpif.h'
35      integer comm, errs
36      integer rank, size, ierr, next, prev, tag, count, i
37      integer TEST_SIZE
38      parameter (TEST_SIZE=2000)
39      integer status(MPI_STATUS_SIZE)
40      real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
41      logical verbose
42      common /flags/ verbose
43C
44      if (verbose) then
45         print *, ' Sendrecv replace'
46      endif
47C
48      call mpi_comm_rank( comm, rank, ierr )
49      call mpi_comm_size( comm, size, ierr )
50      next = rank + 1
51      if (next .ge. size) next = 0
52C
53      prev = rank - 1
54      if (prev .lt. 0) prev = size - 1
55C
56      tag = 4456
57      count = TEST_SIZE / 3
58
59      if (rank .eq. 0) then
60C
61         call init_test_data(recv_buf, TEST_SIZE)
62C
63         do 11 i = count+1,TEST_SIZE
64            recv_buf(i) = 0.0
65 11      continue
66C
67         call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL,
68     .                             next, tag, next, tag,
69     .                             comm, status, ierr)
70
71         call msg_check( recv_buf, next, tag, count, status, TEST_SIZE,
72     .                   'sendrecvreplace', errs )
73
74      else if (prev .eq. 0) then
75
76         call clear_test_data(recv_buf,TEST_SIZE)
77
78         call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
79     .                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
80     .                 status, ierr)
81
82         call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
83     .                   'recv/send for replace', errs )
84
85         call MPI_Send(recv_buf, count, MPI_REAL, prev, tag,
86     .                 comm, ierr)
87      end if
88C
89      end
90