mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-19 12:22:10 +00:00
Fixed IN_PLACE option for collectives.
This commit is contained in:
sfilippone
+24
-19
@@ -58,10 +58,11 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
|
||||
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
|
||||
complex(psb_spk_), allocatable :: llocx(:)
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_cgatherv'
|
||||
@@ -125,32 +126,36 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:) = czero
|
||||
llocx = locx%get_vect()
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = llocx(i)
|
||||
end do
|
||||
|
||||
llocx = locx%get_vect()
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = czero
|
||||
llocx(idx) = czero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
+23
-14
@@ -60,7 +60,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
& maxk, k, jlx, ilx, i, j, loc_rows
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
@@ -232,11 +232,11 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_cgatherv'
|
||||
@@ -307,23 +307,32 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:)=czero
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = locx(i)
|
||||
end do
|
||||
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = czero
|
||||
locx(idx) = czero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,locx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
+24
-19
@@ -58,10 +58,11 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
|
||||
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
|
||||
real(psb_dpk_), allocatable :: llocx(:)
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_dgatherv'
|
||||
@@ -125,32 +126,36 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:) = dzero
|
||||
llocx = locx%get_vect()
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = llocx(i)
|
||||
end do
|
||||
|
||||
llocx = locx%get_vect()
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = dzero
|
||||
llocx(idx) = dzero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
+23
-14
@@ -60,7 +60,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
& maxk, k, jlx, ilx, i, j, loc_rows
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
@@ -232,11 +232,11 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_dgatherv'
|
||||
@@ -307,23 +307,32 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:)=dzero
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = locx(i)
|
||||
end do
|
||||
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = dzero
|
||||
locx(idx) = dzero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,locx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
+23
-14
@@ -60,7 +60,7 @@ subroutine psb_egatherm(globx, locx, desc_a, info, iroot)
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
& maxk, k, jlx, ilx, i, j, loc_rows
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
@@ -232,11 +232,11 @@ subroutine psb_egatherv(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_egatherv'
|
||||
@@ -307,23 +307,32 @@ subroutine psb_egatherv(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:)=ezero
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = locx(i)
|
||||
end do
|
||||
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = ezero
|
||||
locx(idx) = ezero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,locx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
@@ -60,7 +60,7 @@ subroutine psb_i2gatherm(globx, locx, desc_a, info, iroot)
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
& maxk, k, jlx, ilx, i, j, loc_rows
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
@@ -232,11 +232,11 @@ subroutine psb_i2gatherv(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_i2gatherv'
|
||||
@@ -307,23 +307,32 @@ subroutine psb_i2gatherv(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:)=i2zero
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = locx(i)
|
||||
end do
|
||||
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = i2zero
|
||||
locx(idx) = i2zero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,locx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
+24
-19
@@ -58,10 +58,11 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
|
||||
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
|
||||
integer(psb_ipk_), allocatable :: llocx(:)
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_igatherv'
|
||||
@@ -125,32 +126,36 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:) = izero
|
||||
llocx = locx%get_vect()
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = llocx(i)
|
||||
end do
|
||||
|
||||
llocx = locx%get_vect()
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = izero
|
||||
llocx(idx) = izero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
+24
-19
@@ -58,10 +58,11 @@ subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
|
||||
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
|
||||
integer(psb_lpk_), allocatable :: llocx(:)
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_lgatherv'
|
||||
@@ -125,32 +126,36 @@ subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:) = lzero
|
||||
llocx = locx%get_vect()
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = llocx(i)
|
||||
end do
|
||||
|
||||
llocx = locx%get_vect()
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = lzero
|
||||
llocx(idx) = lzero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
+23
-14
@@ -60,7 +60,7 @@ subroutine psb_mgatherm(globx, locx, desc_a, info, iroot)
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
& maxk, k, jlx, ilx, i, j, loc_rows
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
@@ -232,11 +232,11 @@ subroutine psb_mgatherv(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_mgatherv'
|
||||
@@ -307,23 +307,32 @@ subroutine psb_mgatherv(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:)=mzero
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = locx(i)
|
||||
end do
|
||||
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = mzero
|
||||
locx(idx) = mzero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,locx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
+24
-19
@@ -58,10 +58,11 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
|
||||
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
|
||||
real(psb_spk_), allocatable :: llocx(:)
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_sgatherv'
|
||||
@@ -125,32 +126,36 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:) = szero
|
||||
llocx = locx%get_vect()
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = llocx(i)
|
||||
end do
|
||||
|
||||
llocx = locx%get_vect()
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = szero
|
||||
llocx(idx) = szero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
+23
-14
@@ -60,7 +60,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
& maxk, k, jlx, ilx, i, j, loc_rows
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
@@ -232,11 +232,11 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_sgatherv'
|
||||
@@ -307,23 +307,32 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:)=szero
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = locx(i)
|
||||
end do
|
||||
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = szero
|
||||
locx(idx) = szero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,locx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
+24
-19
@@ -58,10 +58,11 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
|
||||
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
|
||||
complex(psb_dpk_), allocatable :: llocx(:)
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_zgatherv'
|
||||
@@ -125,32 +126,36 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:) = zzero
|
||||
llocx = locx%get_vect()
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = llocx(i)
|
||||
end do
|
||||
|
||||
llocx = locx%get_vect()
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = zzero
|
||||
llocx(idx) = zzero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
+23
-14
@@ -60,7 +60,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
& maxk, k, jlx, ilx, i, j, loc_rows
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
@@ -232,11 +232,11 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
|
||||
|
||||
! locals
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank
|
||||
integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows
|
||||
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
|
||||
& maxk, k, jlx, ilx, i, j
|
||||
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
|
||||
|
||||
integer(psb_mpk_), allocatable :: szs(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_zgatherv'
|
||||
@@ -307,23 +307,32 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
globx(:)=zzero
|
||||
|
||||
do i=1,desc_a%get_local_rows()
|
||||
call psb_loc_to_glob(i,idx,desc_a,info)
|
||||
globx(idx) = locx(i)
|
||||
end do
|
||||
|
||||
! adjust overlapped elements
|
||||
do i=1, size(desc_a%ovrlap_elem,1)
|
||||
if (me /= desc_a%ovrlap_elem(i,3)) then
|
||||
idx = desc_a%ovrlap_elem(i,1)
|
||||
call psb_loc_to_glob(idx,desc_a,info)
|
||||
globx(idx) = zzero
|
||||
locx(idx) = zzero
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_sum(ctxt,globx(1:m),root=root)
|
||||
loc_rows = desc_a%get_local_rows()
|
||||
if ((me == root).or.(root == -1)) then
|
||||
allocate(szs(np))
|
||||
end if
|
||||
call psb_gather(ctxt,loc_rows,szs,root=root)
|
||||
if ((me == root).or.(root == -1)) then
|
||||
if (sum(szs) /= m) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_realloc(m,globx,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
call psb_gatherv(ctxt,locx(1:loc_rows),globx,szs,root=root)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
@@ -34,6 +34,14 @@ module psi_c_collective_mod
|
||||
use psb_desc_const_mod
|
||||
|
||||
|
||||
interface psb_gather
|
||||
module procedure psb_cgather_s, psb_cgather_v
|
||||
end interface psb_gather
|
||||
|
||||
interface psb_gatherv
|
||||
module procedure psb_cgatherv_v
|
||||
end interface
|
||||
|
||||
interface psb_sum
|
||||
module procedure psb_csums, psb_csumv, psb_csumm
|
||||
end interface
|
||||
@@ -76,6 +84,250 @@ contains
|
||||
|
||||
|
||||
|
||||
!
|
||||
! gather
|
||||
!
|
||||
subroutine psb_cgather_s(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
complex(psb_spk_), intent(inout) :: dat, resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,1,psb_mpi_c_spk_,&
|
||||
& resv,1,psb_mpi_c_spk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,1,psb_mpi_c_spk_,&
|
||||
& resv,1,psb_mpi_c_spk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,1,psb_mpi_c_spk_,&
|
||||
& resv,1,psb_mpi_c_spk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,1,psb_mpi_c_spk_,&
|
||||
& resv,1,psb_mpi_c_spk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_cgather_s
|
||||
|
||||
subroutine psb_cgather_v(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,size(dat),psb_mpi_c_spk_,&
|
||||
& resv,size(dat),psb_mpi_c_spk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,size(dat),psb_mpi_c_spk_,&
|
||||
& resv,size(dat),psb_mpi_c_spk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,size(dat),psb_mpi_c_spk_,&
|
||||
& resv,size(dat),psb_mpi_c_spk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,size(dat),psb_mpi_c_spk_,&
|
||||
& resv,size(dat),psb_mpi_c_spk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_cgather_v
|
||||
|
||||
subroutine psb_cgatherv_v(ctxt,dat,resv,szs,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_), intent(in), optional :: szs(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info,i
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
integer(psb_mpk_), allocatable :: displs(:)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_allgatherv(dat,size(dat),psb_mpi_c_spk_,&
|
||||
& resv,szs,displs,psb_mpi_c_spk_,icomm,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_gatherv(dat,size(dat),psb_mpi_c_spk_,&
|
||||
& resv,szs,displs,psb_mpi_c_spk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_iallgatherv(dat,size(dat),psb_mpi_c_spk_,&
|
||||
& resv,szs,displs,psb_mpi_c_spk_,icomm,request,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_igatherv(dat,size(dat),psb_mpi_c_spk_,&
|
||||
& resv,szs,displs,psb_mpi_c_spk_,root_,icomm,request,info)
|
||||
endif
|
||||
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_cgatherv_v
|
||||
|
||||
|
||||
|
||||
!
|
||||
! SUM
|
||||
!
|
||||
@@ -124,20 +376,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -190,20 +452,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -258,20 +530,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_, icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_, icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,root_, icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -328,20 +610,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -395,20 +687,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
psb_mpi_c_spk_,mpi_camx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -463,20 +765,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -532,20 +844,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -599,20 +921,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -667,20 +999,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -901,12 +1243,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_scan(dat_,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iscan(dat_,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -952,12 +1295,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_exscan(dat_,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iexscan(dat_,dat,1,&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -980,12 +1324,13 @@ contains
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
@@ -1003,12 +1348,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_scan(dat_,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1029,12 +1375,13 @@ contains
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -1053,12 +1400,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_exscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iexscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_c_spk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1271,6 +1619,5 @@ contains
|
||||
Enddo
|
||||
|
||||
end subroutine psb_c_e_simple_triad_a2av
|
||||
|
||||
|
||||
end module psi_c_collective_mod
|
||||
|
||||
@@ -45,6 +45,14 @@ module psi_d_collective_mod
|
||||
module procedure psb_d_nrm2s, psb_d_nrm2v
|
||||
end interface psb_nrm2
|
||||
|
||||
interface psb_gather
|
||||
module procedure psb_dgather_s, psb_dgather_v
|
||||
end interface psb_gather
|
||||
|
||||
interface psb_gatherv
|
||||
module procedure psb_dgatherv_v
|
||||
end interface
|
||||
|
||||
interface psb_sum
|
||||
module procedure psb_dsums, psb_dsumv, psb_dsumm
|
||||
end interface
|
||||
@@ -110,6 +118,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
real(psb_dpk_) :: dat_
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -134,20 +143,29 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_r_dpk_,mpi_max,icomm,info)
|
||||
call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_r_dpk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_r_dpk_,mpi_max,root_,icomm,info)
|
||||
if (iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,psb_mpi_r_dpk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,psb_mpi_r_dpk_,mpi_max,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info)
|
||||
if (iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -174,6 +192,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
real(psb_dpk_) :: dat_(1) ! This is a dummy
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
@@ -200,21 +219,31 @@ contains
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -242,6 +271,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
real(psb_dpk_) :: dat_(1,1) ! this is a dummy
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
@@ -268,28 +298,37 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,info)
|
||||
endif
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,info)
|
||||
endif
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
|
||||
#endif
|
||||
end subroutine psb_dmaxm
|
||||
|
||||
@@ -340,18 +379,27 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_r_dpk_,mpi_min,icomm,info)
|
||||
call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_r_dpk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_r_dpk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,psb_mpi_r_dpk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,psb_mpi_r_dpk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -405,20 +453,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -473,20 +531,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -545,20 +613,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -612,20 +690,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& mpi_dnrm2_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& mpi_dnrm2_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& mpi_dnrm2_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& mpi_dnrm2_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -636,6 +724,250 @@ contains
|
||||
end subroutine psb_d_nrm2v
|
||||
|
||||
|
||||
!
|
||||
! gather
|
||||
!
|
||||
subroutine psb_dgather_s(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
real(psb_dpk_), intent(inout) :: dat, resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,1,psb_mpi_r_dpk_,&
|
||||
& resv,1,psb_mpi_r_dpk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,1,psb_mpi_r_dpk_,&
|
||||
& resv,1,psb_mpi_r_dpk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,1,psb_mpi_r_dpk_,&
|
||||
& resv,1,psb_mpi_r_dpk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,1,psb_mpi_r_dpk_,&
|
||||
& resv,1,psb_mpi_r_dpk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_dgather_s
|
||||
|
||||
subroutine psb_dgather_v(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
real(psb_dpk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& resv,size(dat),psb_mpi_r_dpk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& resv,size(dat),psb_mpi_r_dpk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& resv,size(dat),psb_mpi_r_dpk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& resv,size(dat),psb_mpi_r_dpk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_dgather_v
|
||||
|
||||
subroutine psb_dgatherv_v(ctxt,dat,resv,szs,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
real(psb_dpk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_), intent(in), optional :: szs(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info,i
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
integer(psb_mpk_), allocatable :: displs(:)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_allgatherv(dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& resv,szs,displs,psb_mpi_r_dpk_,icomm,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_gatherv(dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& resv,szs,displs,psb_mpi_r_dpk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_iallgatherv(dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& resv,szs,displs,psb_mpi_r_dpk_,icomm,request,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_igatherv(dat,size(dat),psb_mpi_r_dpk_,&
|
||||
& resv,szs,displs,psb_mpi_r_dpk_,root_,icomm,request,info)
|
||||
endif
|
||||
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_dgatherv_v
|
||||
|
||||
|
||||
|
||||
!
|
||||
! SUM
|
||||
!
|
||||
@@ -684,20 +1016,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -750,20 +1092,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -818,20 +1170,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_, icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_, icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,root_, icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -888,20 +1250,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -955,20 +1327,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
psb_mpi_r_dpk_,mpi_damx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1023,20 +1405,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1092,20 +1484,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1159,20 +1561,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1227,20 +1639,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1461,12 +1883,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_scan(dat_,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iscan(dat_,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -1512,12 +1935,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_exscan(dat_,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iexscan(dat_,dat,1,&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -1540,12 +1964,13 @@ contains
|
||||
real(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
real(psb_dpk_), allocatable :: dat_(:)
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
@@ -1563,12 +1988,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_scan(dat_,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1589,12 +2015,13 @@ contains
|
||||
real(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
real(psb_dpk_), allocatable :: dat_(:)
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
real(psb_dpk_), allocatable :: dat_(:)
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -1613,12 +2040,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_exscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iexscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_r_dpk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1831,6 +2259,5 @@ contains
|
||||
Enddo
|
||||
|
||||
end subroutine psb_d_e_simple_triad_a2av
|
||||
|
||||
|
||||
end module psi_d_collective_mod
|
||||
|
||||
@@ -42,6 +42,14 @@ module psi_e_collective_mod
|
||||
end interface psb_min
|
||||
|
||||
|
||||
interface psb_gather
|
||||
module procedure psb_egather_s, psb_egather_v
|
||||
end interface psb_gather
|
||||
|
||||
interface psb_gatherv
|
||||
module procedure psb_egatherv_v
|
||||
end interface
|
||||
|
||||
interface psb_sum
|
||||
module procedure psb_esums, psb_esumv, psb_esumm
|
||||
end interface
|
||||
@@ -107,6 +115,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_epk_) :: dat_
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -131,20 +140,29 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_epk_,mpi_max,icomm,info)
|
||||
call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_epk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_epk_,mpi_max,root_,icomm,info)
|
||||
if (iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,psb_mpi_epk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,psb_mpi_epk_,mpi_max,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,request,info)
|
||||
if (iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -171,6 +189,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_epk_) :: dat_(1) ! This is a dummy
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
@@ -197,21 +216,31 @@ contains
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -239,6 +268,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_epk_) :: dat_(1,1) ! this is a dummy
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
@@ -265,28 +295,37 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,info)
|
||||
endif
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,info)
|
||||
endif
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
|
||||
#endif
|
||||
end subroutine psb_emaxm
|
||||
|
||||
@@ -337,18 +376,27 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_epk_,mpi_min,icomm,info)
|
||||
call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_epk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_epk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,psb_mpi_epk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,psb_mpi_epk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -402,20 +450,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -470,20 +528,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -494,6 +562,250 @@ contains
|
||||
|
||||
|
||||
|
||||
!
|
||||
! gather
|
||||
!
|
||||
subroutine psb_egather_s(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
integer(psb_epk_), intent(inout) :: dat, resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,1,psb_mpi_epk_,&
|
||||
& resv,1,psb_mpi_epk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,1,psb_mpi_epk_,&
|
||||
& resv,1,psb_mpi_epk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,1,psb_mpi_epk_,&
|
||||
& resv,1,psb_mpi_epk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,1,psb_mpi_epk_,&
|
||||
& resv,1,psb_mpi_epk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_egather_s
|
||||
|
||||
subroutine psb_egather_v(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
integer(psb_epk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,size(dat),psb_mpi_epk_,&
|
||||
& resv,size(dat),psb_mpi_epk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,size(dat),psb_mpi_epk_,&
|
||||
& resv,size(dat),psb_mpi_epk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,size(dat),psb_mpi_epk_,&
|
||||
& resv,size(dat),psb_mpi_epk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,size(dat),psb_mpi_epk_,&
|
||||
& resv,size(dat),psb_mpi_epk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_egather_v
|
||||
|
||||
subroutine psb_egatherv_v(ctxt,dat,resv,szs,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
integer(psb_epk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_), intent(in), optional :: szs(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info,i
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
integer(psb_mpk_), allocatable :: displs(:)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_allgatherv(dat,size(dat),psb_mpi_epk_,&
|
||||
& resv,szs,displs,psb_mpi_epk_,icomm,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_gatherv(dat,size(dat),psb_mpi_epk_,&
|
||||
& resv,szs,displs,psb_mpi_epk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_iallgatherv(dat,size(dat),psb_mpi_epk_,&
|
||||
& resv,szs,displs,psb_mpi_epk_,icomm,request,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_igatherv(dat,size(dat),psb_mpi_epk_,&
|
||||
& resv,szs,displs,psb_mpi_epk_,root_,icomm,request,info)
|
||||
endif
|
||||
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_egatherv_v
|
||||
|
||||
|
||||
|
||||
!
|
||||
! SUM
|
||||
!
|
||||
@@ -542,20 +854,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -608,20 +930,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -676,20 +1008,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_, icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_, icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,root_, icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -746,20 +1088,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -813,20 +1165,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
psb_mpi_epk_,mpi_eamx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -881,20 +1243,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -950,20 +1322,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1017,20 +1399,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1085,20 +1477,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1319,12 +1721,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_scan(dat_,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iscan(dat_,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -1370,12 +1773,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_exscan(dat_,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iexscan(dat_,dat,1,&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -1398,12 +1802,13 @@ contains
|
||||
integer(psb_epk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
integer(psb_epk_), allocatable :: dat_(:)
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
@@ -1421,12 +1826,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_scan(dat_,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1447,12 +1853,13 @@ contains
|
||||
integer(psb_epk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_epk_), allocatable :: dat_(:)
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_epk_), allocatable :: dat_(:)
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -1471,12 +1878,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_exscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iexscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_epk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1689,6 +2097,5 @@ contains
|
||||
Enddo
|
||||
|
||||
end subroutine psb_e_e_simple_triad_a2av
|
||||
|
||||
|
||||
end module psi_e_collective_mod
|
||||
|
||||
@@ -42,6 +42,14 @@ module psi_i2_collective_mod
|
||||
end interface psb_min
|
||||
|
||||
|
||||
interface psb_gather
|
||||
module procedure psb_i2gather_s, psb_i2gather_v
|
||||
end interface psb_gather
|
||||
|
||||
interface psb_gatherv
|
||||
module procedure psb_i2gatherv_v
|
||||
end interface
|
||||
|
||||
interface psb_sum
|
||||
module procedure psb_i2sums, psb_i2sumv, psb_i2summ
|
||||
end interface
|
||||
@@ -107,6 +115,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_i2pk_) :: dat_
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -131,20 +140,29 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_i2pk_,mpi_max,icomm,info)
|
||||
call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_i2pk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_i2pk_,mpi_max,root_,icomm,info)
|
||||
if (iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,psb_mpi_i2pk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,psb_mpi_i2pk_,mpi_max,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,request,info)
|
||||
if (iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -171,6 +189,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_i2pk_) :: dat_(1) ! This is a dummy
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
@@ -197,21 +216,31 @@ contains
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -239,6 +268,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_i2pk_) :: dat_(1,1) ! this is a dummy
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
@@ -265,28 +295,37 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,info)
|
||||
endif
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,info)
|
||||
endif
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
|
||||
#endif
|
||||
end subroutine psb_i2maxm
|
||||
|
||||
@@ -337,18 +376,27 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_i2pk_,mpi_min,icomm,info)
|
||||
call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_i2pk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_i2pk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,psb_mpi_i2pk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,psb_mpi_i2pk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -402,20 +450,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -470,20 +528,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -494,6 +562,250 @@ contains
|
||||
|
||||
|
||||
|
||||
!
|
||||
! gather
|
||||
!
|
||||
subroutine psb_i2gather_s(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
integer(psb_i2pk_), intent(inout) :: dat, resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,1,psb_mpi_i2pk_,&
|
||||
& resv,1,psb_mpi_i2pk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,1,psb_mpi_i2pk_,&
|
||||
& resv,1,psb_mpi_i2pk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,1,psb_mpi_i2pk_,&
|
||||
& resv,1,psb_mpi_i2pk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,1,psb_mpi_i2pk_,&
|
||||
& resv,1,psb_mpi_i2pk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_i2gather_s
|
||||
|
||||
subroutine psb_i2gather_v(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
integer(psb_i2pk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,size(dat),psb_mpi_i2pk_,&
|
||||
& resv,size(dat),psb_mpi_i2pk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,size(dat),psb_mpi_i2pk_,&
|
||||
& resv,size(dat),psb_mpi_i2pk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,size(dat),psb_mpi_i2pk_,&
|
||||
& resv,size(dat),psb_mpi_i2pk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,size(dat),psb_mpi_i2pk_,&
|
||||
& resv,size(dat),psb_mpi_i2pk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_i2gather_v
|
||||
|
||||
subroutine psb_i2gatherv_v(ctxt,dat,resv,szs,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
integer(psb_i2pk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_), intent(in), optional :: szs(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info,i
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
integer(psb_mpk_), allocatable :: displs(:)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_allgatherv(dat,size(dat),psb_mpi_i2pk_,&
|
||||
& resv,szs,displs,psb_mpi_i2pk_,icomm,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_gatherv(dat,size(dat),psb_mpi_i2pk_,&
|
||||
& resv,szs,displs,psb_mpi_i2pk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_iallgatherv(dat,size(dat),psb_mpi_i2pk_,&
|
||||
& resv,szs,displs,psb_mpi_i2pk_,icomm,request,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_igatherv(dat,size(dat),psb_mpi_i2pk_,&
|
||||
& resv,szs,displs,psb_mpi_i2pk_,root_,icomm,request,info)
|
||||
endif
|
||||
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_i2gatherv_v
|
||||
|
||||
|
||||
|
||||
!
|
||||
! SUM
|
||||
!
|
||||
@@ -542,20 +854,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -608,20 +930,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -676,20 +1008,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_, icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_, icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,root_, icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -746,20 +1088,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -813,20 +1165,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
psb_mpi_i2pk_,mpi_i2amx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -881,20 +1243,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -950,20 +1322,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1017,20 +1399,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1085,20 +1477,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1319,12 +1721,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_scan(dat_,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iscan(dat_,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -1370,12 +1773,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_exscan(dat_,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iexscan(dat_,dat,1,&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -1398,12 +1802,13 @@ contains
|
||||
integer(psb_i2pk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
integer(psb_i2pk_), allocatable :: dat_(:)
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
@@ -1421,12 +1826,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_scan(dat_,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1447,12 +1853,13 @@ contains
|
||||
integer(psb_i2pk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_i2pk_), allocatable :: dat_(:)
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_i2pk_), allocatable :: dat_(:)
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -1471,12 +1878,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_exscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iexscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1689,6 +2097,5 @@ contains
|
||||
Enddo
|
||||
|
||||
end subroutine psb_i2_e_simple_triad_a2av
|
||||
|
||||
|
||||
end module psi_i2_collective_mod
|
||||
|
||||
@@ -42,6 +42,14 @@ module psi_m_collective_mod
|
||||
end interface psb_min
|
||||
|
||||
|
||||
interface psb_gather
|
||||
module procedure psb_mgather_s, psb_mgather_v
|
||||
end interface psb_gather
|
||||
|
||||
interface psb_gatherv
|
||||
module procedure psb_mgatherv_v
|
||||
end interface
|
||||
|
||||
interface psb_sum
|
||||
module procedure psb_msums, psb_msumv, psb_msumm
|
||||
end interface
|
||||
@@ -107,6 +115,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_mpk_) :: dat_
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -131,20 +140,29 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_mpk_,mpi_max,icomm,info)
|
||||
call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_mpk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_mpk_,mpi_max,root_,icomm,info)
|
||||
if (iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,psb_mpi_mpk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,psb_mpi_mpk_,mpi_max,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,request,info)
|
||||
if (iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -171,6 +189,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_mpk_) :: dat_(1) ! This is a dummy
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
@@ -197,21 +216,31 @@ contains
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -239,6 +268,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_mpk_) :: dat_(1,1) ! this is a dummy
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
@@ -265,28 +295,37 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,info)
|
||||
endif
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,info)
|
||||
endif
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
|
||||
#endif
|
||||
end subroutine psb_mmaxm
|
||||
|
||||
@@ -337,18 +376,27 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_mpk_,mpi_min,icomm,info)
|
||||
call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_mpk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_mpk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,psb_mpi_mpk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,psb_mpi_mpk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -402,20 +450,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -470,20 +528,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -494,6 +562,250 @@ contains
|
||||
|
||||
|
||||
|
||||
!
|
||||
! gather
|
||||
!
|
||||
subroutine psb_mgather_s(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
integer(psb_mpk_), intent(inout) :: dat, resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,1,psb_mpi_mpk_,&
|
||||
& resv,1,psb_mpi_mpk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,1,psb_mpi_mpk_,&
|
||||
& resv,1,psb_mpi_mpk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,1,psb_mpi_mpk_,&
|
||||
& resv,1,psb_mpi_mpk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,1,psb_mpi_mpk_,&
|
||||
& resv,1,psb_mpi_mpk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_mgather_s
|
||||
|
||||
subroutine psb_mgather_v(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
integer(psb_mpk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,size(dat),psb_mpi_mpk_,&
|
||||
& resv,size(dat),psb_mpi_mpk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,size(dat),psb_mpi_mpk_,&
|
||||
& resv,size(dat),psb_mpi_mpk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,size(dat),psb_mpi_mpk_,&
|
||||
& resv,size(dat),psb_mpi_mpk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,size(dat),psb_mpi_mpk_,&
|
||||
& resv,size(dat),psb_mpi_mpk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_mgather_v
|
||||
|
||||
subroutine psb_mgatherv_v(ctxt,dat,resv,szs,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
integer(psb_mpk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_), intent(in), optional :: szs(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info,i
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
integer(psb_mpk_), allocatable :: displs(:)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_allgatherv(dat,size(dat),psb_mpi_mpk_,&
|
||||
& resv,szs,displs,psb_mpi_mpk_,icomm,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_gatherv(dat,size(dat),psb_mpi_mpk_,&
|
||||
& resv,szs,displs,psb_mpi_mpk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_iallgatherv(dat,size(dat),psb_mpi_mpk_,&
|
||||
& resv,szs,displs,psb_mpi_mpk_,icomm,request,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_igatherv(dat,size(dat),psb_mpi_mpk_,&
|
||||
& resv,szs,displs,psb_mpi_mpk_,root_,icomm,request,info)
|
||||
endif
|
||||
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_mgatherv_v
|
||||
|
||||
|
||||
|
||||
!
|
||||
! SUM
|
||||
!
|
||||
@@ -542,20 +854,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -608,20 +930,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -676,20 +1008,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_, icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_, icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,root_, icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -746,20 +1088,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -813,20 +1165,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
psb_mpi_mpk_,mpi_mamx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -881,20 +1243,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -950,20 +1322,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1017,20 +1399,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1085,20 +1477,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1319,12 +1721,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_scan(dat_,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iscan(dat_,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -1370,12 +1773,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_exscan(dat_,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iexscan(dat_,dat,1,&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -1398,12 +1802,13 @@ contains
|
||||
integer(psb_mpk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
integer(psb_mpk_), allocatable :: dat_(:)
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
@@ -1421,12 +1826,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_scan(dat_,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1447,12 +1853,13 @@ contains
|
||||
integer(psb_mpk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_), allocatable :: dat_(:)
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
integer(psb_mpk_), allocatable :: dat_(:)
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -1471,12 +1878,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_exscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iexscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_mpk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1689,6 +2097,5 @@ contains
|
||||
Enddo
|
||||
|
||||
end subroutine psb_m_e_simple_triad_a2av
|
||||
|
||||
|
||||
end module psi_m_collective_mod
|
||||
|
||||
@@ -45,6 +45,14 @@ module psi_s_collective_mod
|
||||
module procedure psb_s_nrm2s, psb_s_nrm2v
|
||||
end interface psb_nrm2
|
||||
|
||||
interface psb_gather
|
||||
module procedure psb_sgather_s, psb_sgather_v
|
||||
end interface psb_gather
|
||||
|
||||
interface psb_gatherv
|
||||
module procedure psb_sgatherv_v
|
||||
end interface
|
||||
|
||||
interface psb_sum
|
||||
module procedure psb_ssums, psb_ssumv, psb_ssumm
|
||||
end interface
|
||||
@@ -110,6 +118,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
real(psb_spk_) :: dat_
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -134,20 +143,29 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_r_spk_,mpi_max,icomm,info)
|
||||
call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_r_spk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_r_spk_,mpi_max,root_,icomm,info)
|
||||
if (iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,psb_mpi_r_spk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,psb_mpi_r_spk_,mpi_max,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,request,info)
|
||||
if (iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -174,6 +192,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
real(psb_spk_) :: dat_(1) ! This is a dummy
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
@@ -200,21 +219,31 @@ contains
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -242,6 +271,7 @@ contains
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
real(psb_spk_) :: dat_(1,1) ! this is a dummy
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
@@ -268,28 +298,37 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,info)
|
||||
endif
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,info)
|
||||
endif
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_max,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
|
||||
#endif
|
||||
end subroutine psb_smaxm
|
||||
|
||||
@@ -340,18 +379,27 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_r_spk_,mpi_min,icomm,info)
|
||||
call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_r_spk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_r_spk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,psb_mpi_r_spk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,psb_mpi_r_spk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -405,20 +453,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -473,20 +531,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_min,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -545,20 +613,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -612,20 +690,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),psb_mpi_r_spk_,&
|
||||
& mpi_snrm2_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,&
|
||||
& mpi_snrm2_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),psb_mpi_r_spk_,&
|
||||
& mpi_snrm2_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),psb_mpi_r_spk_,&
|
||||
& mpi_snrm2_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -636,6 +724,250 @@ contains
|
||||
end subroutine psb_s_nrm2v
|
||||
|
||||
|
||||
!
|
||||
! gather
|
||||
!
|
||||
subroutine psb_sgather_s(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
real(psb_spk_), intent(inout) :: dat, resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,1,psb_mpi_r_spk_,&
|
||||
& resv,1,psb_mpi_r_spk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,1,psb_mpi_r_spk_,&
|
||||
& resv,1,psb_mpi_r_spk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,1,psb_mpi_r_spk_,&
|
||||
& resv,1,psb_mpi_r_spk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,1,psb_mpi_r_spk_,&
|
||||
& resv,1,psb_mpi_r_spk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_sgather_s
|
||||
|
||||
subroutine psb_sgather_v(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
real(psb_spk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,size(dat),psb_mpi_r_spk_,&
|
||||
& resv,size(dat),psb_mpi_r_spk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,size(dat),psb_mpi_r_spk_,&
|
||||
& resv,size(dat),psb_mpi_r_spk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,size(dat),psb_mpi_r_spk_,&
|
||||
& resv,size(dat),psb_mpi_r_spk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,size(dat),psb_mpi_r_spk_,&
|
||||
& resv,size(dat),psb_mpi_r_spk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_sgather_v
|
||||
|
||||
subroutine psb_sgatherv_v(ctxt,dat,resv,szs,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
real(psb_spk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_), intent(in), optional :: szs(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info,i
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
integer(psb_mpk_), allocatable :: displs(:)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_allgatherv(dat,size(dat),psb_mpi_r_spk_,&
|
||||
& resv,szs,displs,psb_mpi_r_spk_,icomm,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_gatherv(dat,size(dat),psb_mpi_r_spk_,&
|
||||
& resv,szs,displs,psb_mpi_r_spk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_iallgatherv(dat,size(dat),psb_mpi_r_spk_,&
|
||||
& resv,szs,displs,psb_mpi_r_spk_,icomm,request,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_igatherv(dat,size(dat),psb_mpi_r_spk_,&
|
||||
& resv,szs,displs,psb_mpi_r_spk_,root_,icomm,request,info)
|
||||
endif
|
||||
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_sgatherv_v
|
||||
|
||||
|
||||
|
||||
!
|
||||
! SUM
|
||||
!
|
||||
@@ -684,20 +1016,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -750,20 +1092,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -818,20 +1170,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_, icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_, icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,root_, icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -888,20 +1250,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -955,20 +1327,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
psb_mpi_r_spk_,mpi_samx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1023,20 +1405,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1092,20 +1484,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1159,20 +1561,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1227,20 +1639,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1461,12 +1883,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_scan(dat_,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iscan(dat_,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -1512,12 +1935,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_exscan(dat_,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iexscan(dat_,dat,1,&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -1540,12 +1964,13 @@ contains
|
||||
real(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
real(psb_spk_), allocatable :: dat_(:)
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
@@ -1563,12 +1988,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_scan(dat_,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1589,12 +2015,13 @@ contains
|
||||
real(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
real(psb_spk_), allocatable :: dat_(:)
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
real(psb_spk_), allocatable :: dat_(:)
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -1613,12 +2040,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_exscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iexscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_r_spk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1831,6 +2259,5 @@ contains
|
||||
Enddo
|
||||
|
||||
end subroutine psb_s_e_simple_triad_a2av
|
||||
|
||||
|
||||
end module psi_s_collective_mod
|
||||
|
||||
@@ -34,6 +34,14 @@ module psi_z_collective_mod
|
||||
use psb_desc_const_mod
|
||||
|
||||
|
||||
interface psb_gather
|
||||
module procedure psb_zgather_s, psb_zgather_v
|
||||
end interface psb_gather
|
||||
|
||||
interface psb_gatherv
|
||||
module procedure psb_zgatherv_v
|
||||
end interface
|
||||
|
||||
interface psb_sum
|
||||
module procedure psb_zsums, psb_zsumv, psb_zsumm
|
||||
end interface
|
||||
@@ -76,6 +84,250 @@ contains
|
||||
|
||||
|
||||
|
||||
!
|
||||
! gather
|
||||
!
|
||||
subroutine psb_zgather_s(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
complex(psb_dpk_), intent(inout) :: dat, resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,1,psb_mpi_c_dpk_,&
|
||||
& resv,1,psb_mpi_c_dpk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,1,psb_mpi_c_dpk_,&
|
||||
& resv,1,psb_mpi_c_dpk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,1,psb_mpi_c_dpk_,&
|
||||
& resv,1,psb_mpi_c_dpk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,1,psb_mpi_c_dpk_,&
|
||||
& resv,1,psb_mpi_c_dpk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_zgather_s
|
||||
|
||||
subroutine psb_zgather_v(ctxt,dat,resv,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allgather(dat,size(dat),psb_mpi_c_dpk_,&
|
||||
& resv,size(dat),psb_mpi_c_dpk_,icomm,info)
|
||||
else
|
||||
call mpi_gather(dat,size(dat),psb_mpi_c_dpk_,&
|
||||
& resv,size(dat),psb_mpi_c_dpk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallgather(dat,size(dat),psb_mpi_c_dpk_,&
|
||||
& resv,size(dat),psb_mpi_c_dpk_,icomm,request,info)
|
||||
else
|
||||
call mpi_igather(dat,size(dat),psb_mpi_c_dpk_,&
|
||||
& resv,size(dat),psb_mpi_c_dpk_,root_,icomm,request,info)
|
||||
endif
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_zgather_v
|
||||
|
||||
subroutine psb_zgatherv_v(ctxt,dat,resv,szs,root,mode,request)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_ctxt_type), intent(in) :: ctxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:), resv(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_), intent(in), optional :: szs(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info,i
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
integer(psb_mpk_), allocatable :: displs(:)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
resv(0) = dat
|
||||
#else
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
if (present(mode)) then
|
||||
collective_sync = .false.
|
||||
collective_start = iand(mode,psb_collective_start_) /= 0
|
||||
collective_end = iand(mode,psb_collective_end_) /= 0
|
||||
if (.not.present(request)) then
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
else
|
||||
collective_sync = .true.
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_allgatherv(dat,size(dat),psb_mpi_c_dpk_,&
|
||||
& resv,szs,displs,psb_mpi_c_dpk_,icomm,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_gatherv(dat,size(dat),psb_mpi_c_dpk_,&
|
||||
& resv,szs,displs,psb_mpi_c_dpk_,root_,icomm,info)
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
call mpi_iallgatherv(dat,size(dat),psb_mpi_c_dpk_,&
|
||||
& resv,szs,displs,psb_mpi_c_dpk_,icomm,request,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
if (size(szs) < np) write(0,*) 'Error: bad input sizes'
|
||||
allocate(displs(np))
|
||||
displs(1) = 0
|
||||
do i=2, np
|
||||
displs(i) = displs(i-1) + szs(i-1)
|
||||
end do
|
||||
else
|
||||
allocate(displs(0))
|
||||
end if
|
||||
call mpi_igatherv(dat,size(dat),psb_mpi_c_dpk_,&
|
||||
& resv,szs,displs,psb_mpi_c_dpk_,root_,icomm,request,info)
|
||||
endif
|
||||
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
end subroutine psb_zgatherv_v
|
||||
|
||||
|
||||
|
||||
!
|
||||
! SUM
|
||||
!
|
||||
@@ -124,20 +376,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -190,20 +452,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -258,20 +530,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_, icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_, icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,root_, icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -328,20 +610,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -395,20 +687,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
psb_mpi_c_dpk_,mpi_zamx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -463,20 +765,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -532,20 +844,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_allreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iallreduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -599,20 +921,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -667,20 +999,30 @@ contains
|
||||
end if
|
||||
if (collective_sync) then
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_allreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,icomm,info)
|
||||
else
|
||||
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info)
|
||||
if(iam==root_) then
|
||||
call mpi_reduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info)
|
||||
end if
|
||||
endif
|
||||
else
|
||||
if (collective_start) then
|
||||
if (root_ == -1) then
|
||||
call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iallreduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info)
|
||||
if(iam==root_) then
|
||||
call mpi_ireduce(mpi_in_place,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info)
|
||||
else
|
||||
call mpi_ireduce(dat,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info)
|
||||
end if
|
||||
end if
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -901,12 +1243,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_scan(dat_,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iscan(dat_,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -952,12 +1295,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_exscan(dat_,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,1,&
|
||||
call mpi_iexscan(dat_,dat,1,&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,request,minfo)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,minfo)
|
||||
@@ -980,12 +1324,13 @@ contains
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
icomm = psb_get_mpi_comm(ctxt)
|
||||
@@ -1003,12 +1348,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_scan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_scan(dat_,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1029,12 +1375,13 @@ contains
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_ipk_), intent(in), optional :: mode
|
||||
integer(psb_mpk_), intent(inout), optional :: request
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
integer(psb_mpk_) :: minfo
|
||||
integer(psb_mpk_) :: icomm
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
logical :: collective_start, collective_end, collective_sync
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ctxt,iam,np)
|
||||
@@ -1053,12 +1400,13 @@ contains
|
||||
collective_start = .false.
|
||||
collective_end = .false.
|
||||
end if
|
||||
dat_ = dat
|
||||
if (collective_sync) then
|
||||
call mpi_exscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_exscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,minfo)
|
||||
else
|
||||
if (collective_start) then
|
||||
call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),&
|
||||
call mpi_iexscan(dat_,dat,size(dat),&
|
||||
& psb_mpi_c_dpk_,mpi_sum,icomm,request,info)
|
||||
else if (collective_end) then
|
||||
call mpi_wait(request,status,info)
|
||||
@@ -1271,6 +1619,5 @@ contains
|
||||
Enddo
|
||||
|
||||
end subroutine psb_z_e_simple_triad_a2av
|
||||
|
||||
|
||||
end module psi_z_collective_mod
|
||||
|
||||
Reference in New Issue
Block a user