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
27 integer (kind=MPI_ADDRESS_KIND) disp(5)
30 parameter (bufsize=100)
31 character buf(bufsize)
33 integer status(MPI_STATUS_SIZE)
44 call mpi_comm_rank(MPI_COMM_WORLD, me, ierr)
45 call mpi_comm_size(MPI_COMM_WORLD, size, ierr )
47 print *, "Must have at least 2 processes"
48 call MPI_Abort( MPI_COMM_WORLD, 1, ierr )
63 call mpi_get_address(name,disp(1),ierr)
65 type(2)=MPI_DOUBLE_PRECISION
67 call mpi_get_address(x,disp(2),ierr)
69 call mpi_type_create_struct(2,length,disp,type,newtype,ierr)
70 call mpi_type_commit(newtype,ierr)
71 call mpi_barrier( MPI_COMM_WORLD, ierr )
72 call mpi_send(MPI_BOTTOM,1,newtype,dest,1,comm,ierr)
73 call mpi_type_free(newtype,ierr)
74 ! write(*,*) "Sent ",name(1:5),x
76 ! Everyone calls barrier in case size > 2
77 call mpi_barrier( MPI_COMM_WORLD, ierr )
83 call mpi_recv(buf,bufsize,MPI_PACKED, src, &
84 & 1, comm, status, ierr)
86 call mpi_unpack(buf,bufsize,position, &
87 & name,5,MPI_CHARACTER, comm,ierr)
88 call mpi_unpack(buf,bufsize,position, &
89 & x,1,MPI_DOUBLE_PRECISION, comm,ierr)
90 ! Check the return values (/= is not-equal in F90)
91 if (name /= "Hello") then
93 print *, "Received ", name, " but expected Hello"
95 if (abs(x-5.1234) .gt. 1.0e-6) then
97 print *, "Received ", x, " but expected 5.1234"
102 ! Sum up errs and report the result
103 call mpi_reduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, 0, &
104 & MPI_COMM_WORLD, ierr )
106 if (toterrs .eq. 0) then
107 print *, " No Errors"
109 print *, " Found ", toterrs, " errors"
113 call mpi_finalize(ierr)