1include(mpifx_common.m4)
2
3dnl ************************************************************************
4dnl *** mpifx_gatherv
5dnl ************************************************************************
6
7define(`_subroutine_mpifx_gatherv_dr0',`dnl
8dnl
9dnl $1: subroutine suffix
10dnl $2: send/recv buffer type
11dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.)
12dnl $4: send/recv buffer rank (1, 2, etc.)
13dnl $5: corresponding MPI type
14dnl
15!> Gathers results of variable length on one process (type $1).
16!!
17!! \param mycomm  MPI communicator.
18!! \param send  Quantity to be sent for gathering.
19!! \param recv  Received data on receive node (undefined on other nodes)
20!! \param recvcounts Counts of received data from each process
21!! \param displs Entry i specifies where to place data from process rank i-1
22!!               (default: computed from recvcounts assuming order with rank)
23!! \param root  Root process for the result (default: mycomm%masterrank)
24!! \param error  Error code on exit.
25!!
26subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, displs, root, error)
27  type(mpifx_comm), intent(in) :: mycomm
28  $2, intent(in) :: send$3
29  $2, intent(out) :: recv$3
30  integer, intent(in) :: recvcounts(:)
31  integer, intent(in), optional :: displs(:)
32  integer, intent(in), optional :: root
33  integer, intent(out), optional :: error
34
35  integer :: root0, error0, ii
36  integer, allocatable :: displs0(:)
37
38
39  _handle_inoptflag(root0, root, mycomm%masterrank)
40
41  if (mycomm%rank == root0) then
42    _assert(size(recv) == sum(recvcounts))
43    allocate(displs0(mycomm%size))
44    if (present(displs)) then
45      _assert(size(displs) == mycomm%size)
46      displs0 = displs
47    else
48      displs0(1) = 0
49      do ii = 2, mycomm%size
50        displs0(ii) = displs0(ii-1) + recvcounts(ii-1)
51      end do
52    end if
53  end if
54
55  call mpi_gatherv(send, size(send), $5, recv, recvcounts, displs0, &
56      & $5, root0, mycomm%id, error0)
57
58  call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_$1", error)
59
60end subroutine mpifx_gatherv_$1
61')
62
63
64define(`_subroutine_mpifx_gatherv_dr1',`dnl
65dnl
66dnl $1: subroutine suffix
67dnl $2: send/recv buffer type
68dnl $3: send buffer rank specifier ("", (:), (:,:), etc.)
69dnl $4: send buffer size (1 or size(send))
70dnl $5: recv buffer rank specifier ((:), (:,:), etc.)
71dnl $6: recv buffers rank (1, 2, etc.)
72dnl $7: corresponding MPI type
73dnl
74!> Gathers results on one process (type $1).
75!!
76!! \param mycomm  MPI communicator.
77!! \param send  Quantity to be sent for gathering.
78!! \param recv  Received data on receive node (indefined on other nodes)
79!! \param recvcounts Counts of received data from each process
80!! \param displs Entry i specifies where to place data from process rank i-1
81!!               (default: computed from recvcounts assuming order with rank)
82!! \param root  Root process for the result (default: mycomm%masterrank)
83!! \param error  Error code on exit.
84!!
85subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, displs, root, error)
86  type(mpifx_comm), intent(in) :: mycomm
87  $2, intent(in) :: send$3
88  $2, intent(out) :: recv$5
89  integer, intent(in) :: recvcounts(:)
90  integer, intent(in), optional :: displs(:)
91  integer, intent(in), optional :: root
92  integer, intent(out), optional :: error
93
94  integer :: ii, root0, error0
95  integer, allocatable :: displs0(:)
96
97  _handle_inoptflag(root0, root, mycomm%masterrank)
98
99  if (mycomm%rank == root0) then
100    _assert(size(recv) == sum(recvcounts))
101    _assert(size(recv, dim=$6) == mycomm%size)
102    allocate(displs0(mycomm%size))
103    if (present(displs)) then
104      _assert(size(displs) == mycomm%size)
105      displs0 = displs
106    else
107      displs0(1) = 0
108      do ii = 2, mycomm%size
109        displs0(ii) = displs0(ii-1) + recvcounts(ii-1)
110      end do
111    end if
112  end if
113
114  call mpi_gatherv(send, $4, $7, recv, recvcounts, displs0, &
115       & $7,  root0, mycomm%id, error0)
116
117  call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_$1", error)
118
119end subroutine mpifx_gatherv_$1
120')
121
122