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
|
!
! Copyright (C) by Argonne National Laboratory
! See COPYRIGHT in top-level directory
!
! This file created from test/mpi/f77/coll/inplacef.f with f77tof90
!
! This is a simple test that Fortran support the MPI_IN_PLACE value
!
program main
use mpi_f08
integer ierr, errs
integer root
TYPE(MPI_Comm) comm
integer rank, size
integer i
integer MAX_SIZE
parameter (MAX_SIZE=1024)
integer rbuf(MAX_SIZE), rdispls(MAX_SIZE), rcount(MAX_SIZE), &
& sbuf(MAX_SIZE)
errs = 0
call mtest_init( ierr )
comm = MPI_COMM_WORLD
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
root = 0
! Gather with inplace
do i=1,size
rbuf(i) = - i
enddo
rbuf(1+root) = root
if (rank .eq. root) then
call mpi_gather( MPI_IN_PLACE, 1, MPI_INTEGER, rbuf, 1, &
& MPI_INTEGER, root, comm, ierr )
do i=1,size
if (rbuf(i) .ne. i-1) then
errs = errs + 1
print *, '[',rank,'] rbuf(', i, ') = ', rbuf(i), &
& ' in gather'
endif
enddo
else
call mpi_gather( rank, 1, MPI_INTEGER, rbuf, 1, MPI_INTEGER, &
& root, comm, ierr )
endif
! Gatherv with inplace
do i=1,size
rbuf(i) = - i
rcount(i) = 1
rdispls(i) = i-1
enddo
rbuf(1+root) = root
if (rank .eq. root) then
call mpi_gatherv( MPI_IN_PLACE, 1, MPI_INTEGER, rbuf, rcount, &
& rdispls, MPI_INTEGER, root, comm, ierr )
do i=1,size
if (rbuf(i) .ne. i-1) then
errs = errs + 1
print *, '[', rank, '] rbuf(', i, ') = ', rbuf(i), &
& ' in gatherv'
endif
enddo
else
call mpi_gatherv( rank, 1, MPI_INTEGER, rbuf, rcount, rdispls, &
& MPI_INTEGER, root, comm, ierr )
endif
! Scatter with inplace
do i=1,size
sbuf(i) = i
enddo
rbuf(1) = -1
if (rank .eq. root) then
call mpi_scatter( sbuf, 1, MPI_INTEGER, MPI_IN_PLACE, 1, &
& MPI_INTEGER, root, comm, ierr )
else
call mpi_scatter( sbuf, 1, MPI_INTEGER, rbuf, 1, &
& MPI_INTEGER, root, comm, ierr )
if (rbuf(1) .ne. rank+1) then
errs = errs + 1
print *, '[', rank, '] rbuf = ', rbuf(1), &
& ' in scatter'
endif
endif
call mtest_finalize( errs )
end
|
