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( MPI_COMM_WORLD, 1, ierr )
62 call mpi_get_address(name,disp(1),ierr)
64 type(2)=MPI_DOUBLE_PRECISION
66 call mpi_get_address(x,disp(2),ierr)
68 call mpi_type_create_struct(2,length,disp,type,newtype,ierr)
69 call mpi_type_commit(newtype,ierr)
70 call mpi_barrier( MPI_COMM_WORLD, ierr )
71 call mpi_send(MPI_BOTTOM,1,newtype,dest,1,comm,ierr)
72 call mpi_type_free(newtype,ierr)
73 ! write(*,*) "Sent ",name(1:5),x
75 ! Everyone calls barrier incase size > 2
76 call mpi_barrier( MPI_COMM_WORLD, ierr )
82 call mpi_recv(buf,bufsize,MPI_PACKED, src, &
83 & 1, comm, status, ierr)
85 call mpi_unpack(buf,bufsize,position, &
86 & name,5,MPI_CHARACTER, comm,ierr)
87 call mpi_unpack(buf,bufsize,position, &
88 & x,1,MPI_DOUBLE_PRECISION, comm,ierr)
89 ! Check the return values (/= is not-equal in F90)
90 if (name /= "Hello") then
92 print *, "Received ", name, " but expected Hello"
94 if (abs(x-5.1234) .gt. 1.0e-6) then
96 print *, "Received ", x, " but expected 5.1234"
101 ! Sum up errs and report the result
102 call mpi_reduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, 0, &
103 & MPI_COMM_WORLD, ierr )
105 if (toterrs .eq. 0) then
106 print *, " No Errors"
108 print *, " Found ", toterrs, " errors"
112 call mpi_finalize(ierr)