1 ! -*- Mode: Fortran; -*-
3 ! (C) 2003 by Argonne National Laboratory.
4 ! See COPYRIGHT in top-level directory.
6 ! This test contributed by Kim McMahon, Cray
12 integer ierr, i, j, type, count,errs
14 integer rank, size, xfersize
15 integer status(MPI_STATUS_SIZE)
16 integer blocklens(count), displs(count)
17 double precision,dimension(:,:),allocatable :: sndbuf, rcvbuf
21 call mtest_init ( ierr )
22 call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
23 call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
25 print *, "Must have at least 2 processes"
26 call MPI_Abort( MPI_COMM_WORLD, 1, ierr )
31 allocate(sndbuf(7,100))
32 allocate(rcvbuf(7,100))
36 sndbuf(i,j) = (i+j) * 1.0
44 ! bug occurs when first two displacements are 0
50 call mpi_type_indexed( count, blocklens, displs*blocklens(1), &
51 & MPI_DOUBLE_PRECISION, type, ierr )
53 call mpi_type_commit( type, ierr )
55 ! send using this new type
59 call mpi_send( sndbuf(1,1), 1, type, 1, 0, MPI_COMM_WORLD,ierr )
61 else if (rank .eq. 1) then
63 xfersize=count * blocklens(1)
64 call mpi_recv( rcvbuf(1,1), xfersize, MPI_DOUBLE_PRECISION, 0, 0, &
65 & MPI_COMM_WORLD,status, ierr )
68 ! Values that should be sent
74 print*,'sndbuf(',i,j,') = ',sndbuf(i,j)
80 print*,'sndbuf(',i,j,') = ',sndbuf(i,j)
87 print*,'rcvbuf(',i,j,') = ',rcvbuf(i,j)
95 if (rcvbuf(i,j) .ne. sndbuf(i,1)) then
96 print*,'ERROR in rcvbuf(',i,j,')'
97 print*,'Received ', rcvbuf(i,j),' expected ',sndbuf(i,11)
105 if (rcvbuf(i,j) .ne. sndbuf(i,11)) then
106 print*,'ERROR in rcvbuf(',i,j,')'
107 print*,'Received ', rcvbuf(i,j),' expected ',sndbuf(i,11)
114 call mpi_type_free( type, ierr )
115 call mtest_finalize( errs )
116 call mpi_finalize( ierr )