1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
!
! (C) 2004 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
! Thanks to
! William R. Magro
! for this test
!
! It has been modifiedly slightly to work with the automated MPI
! tests.
! WDG.
!
! It was further modified to use MPI_Get_address instead of MPI_Address
! for MPICH, and to fit in the MPICH test harness - WDG
!
program bustit
use mpi_f08
implicit none
TYPE(MPI_Comm) comm
TYPE(MPI_Datatype) newtype
integer me
integer position
TYPE(MPI_Datatype) type(5)
integer length(5)
integer (kind=MPI_ADDRESS_KIND) disp(5)
integer bufsize
integer errs, toterrs
parameter (bufsize=100)
character buf(bufsize)
character name*(10)
TYPE(MPI_Status) status
integer i, size
double precision x
integer src, dest
integer ierr
errs = 0
! Enroll in MPI
call mtest_init(ierr)
! get my rank
call mpi_comm_rank(MPI_COMM_WORLD, me, ierr)
call mpi_comm_size(MPI_COMM_WORLD, size, ierr )
if (size .lt. 2) then
print *, "Must have at least 2 processes"
call MPI_Abort( MPI_COMM_WORLD, 1, ierr )
endif
comm = MPI_COMM_WORLD
src = 0
dest = 1
if(me.eq.src) then
i=5
x=5.1234d0
name="Hello"
type(1)=MPI_CHARACTER
length(1)=5
call mpi_get_address(name,disp(1),ierr)
type(2)=MPI_DOUBLE_PRECISION
length(2)=1
call mpi_get_address(x,disp(2),ierr)
call mpi_type_create_struct(2,length,disp,type,newtype,ierr)
call mpi_type_commit(newtype,ierr)
call mpi_barrier( MPI_COMM_WORLD, ierr )
call mpi_send(MPI_BOTTOM,1,newtype,dest,1,comm,ierr)
call mpi_type_free(newtype,ierr)
! write(*,*) "Sent ",name(1:5),x
else
! Everyone calls barrier incase size > 2
call mpi_barrier( MPI_COMM_WORLD, ierr )
if (me.eq.dest) then
position=0
name = " "
x = 0.0d0
call mpi_recv(buf,bufsize,MPI_PACKED, src, &
& 1, comm, status, ierr)
call mpi_unpack(buf,bufsize,position, &
& name,5,MPI_CHARACTER, comm,ierr)
call mpi_unpack(buf,bufsize,position, &
& x,1,MPI_DOUBLE_PRECISION, comm,ierr)
! Check the return values (/= is not-equal in F90)
if (name /= "Hello") then
errs = errs + 1
print *, "Received ", name, " but expected Hello"
endif
if (abs(x-5.1234) .gt. 1.0e-6) then
errs = errs + 1
print *, "Received ", x, " but expected 5.1234"
endif
endif
endif
!
! Sum up errs and report the result
call mtest_finalize(errs)
end
|
