2 ! (C) 2004 by Argonne National Laboratory.
3 ! See COPYRIGHT in top-level directory.
9 ! It has been modifiedly slightly to work with the automated MPI
13 ! It was further modified to use MPI_Get_address instead of MPI_Address
14 ! for MPICH, and to fit in the MPICH test harness - WDG
26 integer (kind=MPI_ADDRESS_KIND) disp(5)
29 parameter (bufsize=100)
30 character buf(bufsize)
32 integer status(MPI_STATUS_SIZE)
43 call mpi_comm_rank(MPI_COMM_WORLD, me, ierr)
44 call mpi_comm_size(MPI_COMM_WORLD, size, ierr )
46 print *, "Must have at least 2 processes"
47 call MPI_Abort( 1, MPI_COMM_WORLD, ierr )
61 call mpi_get_address(name,disp(1),ierr)
63 type(2)=MPI_DOUBLE_PRECISION
65 call mpi_get_address(x,disp(2),ierr)
67 call mpi_type_create_struct(2,length,disp,type,newtype,ierr)
68 call mpi_type_commit(newtype,ierr)
69 call mpi_barrier( MPI_COMM_WORLD, ierr )
70 call mpi_send(MPI_BOTTOM,1,newtype,dest,1,comm,ierr)
71 call mpi_type_free(newtype,ierr)
72 ! write(*,*) "Sent ",name(1:5),x
74 ! Everyone calls barrier incase size > 2
75 call mpi_barrier( MPI_COMM_WORLD, ierr )
81 call mpi_recv(buf,bufsize,MPI_PACKED, src, &
82 & 1, comm, status, ierr)
84 call mpi_unpack(buf,bufsize,position, &
85 & name,5,MPI_CHARACTER, comm,ierr)
86 call mpi_unpack(buf,bufsize,position, &
87 & x,1,MPI_DOUBLE_PRECISION, comm,ierr)
88 ! Check the return values (/= is not-equal in F90)
89 if (name /= "Hello") then
91 print *, "Received ", name, " but expected Hello"
93 if (abs(x-5.1234) .gt. 1.0e-6) then
95 print *, "Received ", x, " but expected 5.1234"
100 ! Sum up errs and report the result
101 call mpi_reduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, 0, &
102 & MPI_COMM_WORLD, ierr )
104 if (toterrs .eq. 0) then
105 print *, " No Errors"
107 print *, " Found ", toterrs, " errors"
111 call mpi_finalize(ierr)