Newer
Older
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
program coll_exer
use mpi
implicit none
integer, parameter :: n_mpi_tasks = 4
integer :: ntasks, rank, ierr, i, color, sub_comm
integer, dimension(2*n_mpi_tasks) :: sendbuf, recvbuf
integer, dimension(2*n_mpi_tasks**2) :: printbuf
integer, dimension(n_mpi_tasks) :: offsets, counts
call mpi_init(ierr)
call mpi_comm_size(MPI_COMM_WORLD, ntasks, ierr)
call mpi_comm_rank(MPI_COMM_WORLD, rank, ierr)
if (ntasks /= n_mpi_tasks) then
if (rank == 0) then
print *, "Run this program with ", n_mpi_tasks, " tasks."
end if
call mpi_abort(MPI_COMM_WORLD, -1, ierr)
end if
! Initialize message buffers
call init_buffers
! Print data that will be sent
call print_buffers(sendbuf)
! Gather varying size data to task 1
counts = (/1,1,2,4/)
offsets(1) = 0
do i = 2, ntasks
offsets(i) = offsets(i-1) + counts(i-1)
end do
call mpi_gatherv(sendbuf, counts(rank+1), MPI_INTEGER, recvbuf, counts, &
& offsets, MPI_INTEGER, 1, MPI_COMM_WORLD, ierr)
! Print data that was received
call print_buffers(recvbuf)
call mpi_finalize(ierr)
contains
subroutine init_buffers
implicit none
integer :: i
do i = 1, 2*n_mpi_tasks
recvbuf(i) = -1
sendbuf(i) = i + 2*n_mpi_tasks * rank - 1
end do
end subroutine init_buffers
subroutine print_buffers(buffer)
implicit none
integer, dimension(:), intent(in) :: buffer
integer, parameter :: bufsize = 2*n_mpi_tasks
integer :: i
character(len=40) :: pformat
write(pformat,'(A,I3,A)') '(A4,I2,":",', bufsize, 'I3)'
call mpi_gather(buffer, bufsize, MPI_INTEGER, &
& printbuf, bufsize, MPI_INTEGER, &
& 0, MPI_COMM_WORLD, ierr)
if (rank == 0) then
do i = 1, ntasks
write(*,pformat) 'Task', i - 1, printbuf((i-1)*bufsize+1:i*bufsize)
end do
print *
end if
end subroutine print_buffers
end program coll_exer