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( 1, MPI_COMM_WORLD, ierr )
30 allocate(sndbuf(7,100))
31 allocate(rcvbuf(7,100))
35 sndbuf(i,j) = (i+j) * 1.0
43 ! bug occurs when first two displacements are 0
49 call mpi_type_indexed( count, blocklens, displs*blocklens(1), &
50 & MPI_DOUBLE_PRECISION, type, ierr )
52 call mpi_type_commit( type, ierr )
54 ! send using this new type
58 call mpi_send( sndbuf(1,1), 1, type, 1, 0, MPI_COMM_WORLD,ierr )
60 else if (rank .eq. 1) then
62 xfersize=count * blocklens(1)
63 call mpi_recv( rcvbuf(1,1), xfersize, MPI_DOUBLE_PRECISION, 0, 0, &
64 & MPI_COMM_WORLD,status, ierr )
67 ! Values that should be sent
73 print*,'sndbuf(',i,j,') = ',sndbuf(i,j)
79 print*,'sndbuf(',i,j,') = ',sndbuf(i,j)
86 print*,'rcvbuf(',i,j,') = ',rcvbuf(i,j)
94 if (rcvbuf(i,j) .ne. sndbuf(i,1)) then
95 print*,'ERROR in rcvbuf(',i,j,')'
96 print*,'Received ', rcvbuf(i,j),' expected ',sndbuf(i,11)
104 if (rcvbuf(i,j) .ne. sndbuf(i,11)) then
105 print*,'ERROR in rcvbuf(',i,j,')'
106 print*,'Received ', rcvbuf(i,j),' expected ',sndbuf(i,11)
113 call mpi_type_free( type, ierr )
114 call mtest_finalize( errs )
115 call mpi_finalize( ierr )