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