fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Fixed IN_PLACE option for collectives.

Browse Source
maint-3.8.1
sfilippone 1 year ago
parent d82b090289
commit 5caee551e5
20 changed files with 3720 additions and 858 deletions
Show Stats Download Patch File Download Diff File

39
base/comm/psb_cgather.f90
Unescape Escape View File

@ -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,31 +126,35 @@ 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
! 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

37
base/comm/psb_cgather_a.f90
Unescape Escape View File

@ -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

39
base/comm/psb_dgather.f90
Unescape Escape View File

@ -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,31 +126,35 @@ 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
! 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

37
base/comm/psb_dgather_a.f90
Unescape Escape View File

@ -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

37
base/comm/psb_egather_a.f90
Unescape Escape View File

@ -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

37
base/comm/psb_i2gather_a.f90
Unescape Escape View File

@ -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

39
base/comm/psb_igather.f90
Unescape Escape View File

@ -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,31 +126,35 @@ 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
! 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

39
base/comm/psb_lgather.f90
Unescape Escape View File

@ -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,31 +126,35 @@ 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
! 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

37
base/comm/psb_mgather_a.f90
Unescape Escape View File

@ -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

39
base/comm/psb_sgather.f90
Unescape Escape View File

@ -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,31 +126,35 @@ 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
! 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

37
base/comm/psb_sgather_a.f90
Unescape Escape View File

@ -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

39
base/comm/psb_zgather.f90
Unescape Escape View File

@ -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,31 +126,35 @@ 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
! 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

37
base/comm/psb_zgather_a.f90
Unescape Escape View File

@ -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

469
base/modules/penv/psi_c_collective_mod.F90
Unescape Escape View File

@ -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)
@ -1272,5 +1620,4 @@ contains
end subroutine psb_c_e_simple_triad_a2av
end module psi_c_collective_mod

645
base/modules/penv/psi_d_collective_mod.F90
Unescape Escape View File

@ -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)
@ -136,18 +145,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_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)
@ -201,20 +220,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_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)
@ -270,26 +300,35 @@ 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_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)
@ -1832,5 +2260,4 @@ contains
end subroutine psb_d_e_simple_triad_a2av
end module psi_d_collective_mod

601
base/modules/penv/psi_e_collective_mod.F90
Unescape Escape View File

@ -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)
@ -133,18 +142,27 @@ contains
end if
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)
@ -198,20 +217,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_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)
@ -267,26 +297,35 @@ 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_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)
@ -1690,5 +2098,4 @@ contains
end subroutine psb_e_e_simple_triad_a2av
end module psi_e_collective_mod

601
base/modules/penv/psi_i2_collective_mod.F90
Unescape Escape View File

@ -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)
@ -133,18 +142,27 @@ contains
end if
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)
@ -198,20 +217,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_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)
@ -267,26 +297,35 @@ 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_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)
@ -1690,5 +2098,4 @@ contains
end subroutine psb_i2_e_simple_triad_a2av
end module psi_i2_collective_mod

601
base/modules/penv/psi_m_collective_mod.F90
Unescape Escape View File

@ -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)
@ -133,18 +142,27 @@ contains
end if
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)
@ -198,20 +217,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_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)
@ -267,26 +297,35 @@ 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_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)
@ -1690,5 +2098,4 @@ contains
end subroutine psb_m_e_simple_triad_a2av
end module psi_m_collective_mod

645
base/modules/penv/psi_s_collective_mod.F90
Unescape Escape View File

@ -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)
@ -136,18 +145,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_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)
@ -201,20 +220,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_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)
@ -270,26 +300,35 @@ 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_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)
@ -1832,5 +2260,4 @@ contains
end subroutine psb_s_e_simple_triad_a2av
end module psi_s_collective_mod

469
base/modules/penv/psi_z_collective_mod.F90
Unescape Escape View File

@ -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)
@ -1272,5 +1620,4 @@ contains
end subroutine psb_z_e_simple_triad_a2av
end module psi_z_collective_mod

Write Preview
Loading…
Cancel
Save