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

Defined non-blocking version of PSB_SUM.

Browse Source
split_sum
Salvatore Filippone 3 years ago
parent 6945b1495e
commit 336f7bf132
9 changed files with 970 additions and 288 deletions
Show Stats Download Patch File Download Diff File

2
base/modules/Makefile
Unescape Escape View File

@ -375,7 +375,7 @@ psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o psblas/psb_d_psblas_mod.o ps
psb_base_mod.o: $(MODULES) psb_base_mod.o: $(MODULES)
penv/psi_penv_mod.o: penv/psi_penv_mod.F90 psb_const_mod.o serial/psb_vect_mod.o serial/psb_mat_mod.o penv/psi_penv_mod.o: penv/psi_penv_mod.F90 psb_const_mod.o serial/psb_vect_mod.o serial/psb_mat_mod.o desc/psb_desc_const_mod.o
$(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@
psb_penv_mod.o: psb_penv_mod.F90 $(COMMINT) $(BASIC_MODS) psb_penv_mod.o: psb_penv_mod.F90 $(COMMINT) $(BASIC_MODS)

3
base/modules/desc/psb_desc_const_mod.f90
Unescape Escape View File

@ -48,6 +48,9 @@ module psb_desc_const_mod
! The following are bit fields. ! The following are bit fields.
integer(psb_ipk_), parameter :: psb_swap_send_=1, psb_swap_recv_=2 integer(psb_ipk_), parameter :: psb_swap_send_=1, psb_swap_recv_=2
integer(psb_ipk_), parameter :: psb_swap_sync_=4, psb_swap_mpi_=8 integer(psb_ipk_), parameter :: psb_swap_sync_=4, psb_swap_mpi_=8
integer(psb_ipk_), parameter :: psb_collective_start_=1, psb_collective_end_=2
integer(psb_ipk_), parameter :: psb_collective_sync_=4
! Choice among lists on which to base data exchange ! Choice among lists on which to base data exchange
integer(psb_ipk_), parameter :: psb_no_comm_=-1 integer(psb_ipk_), parameter :: psb_no_comm_=-1
integer(psb_ipk_), parameter :: psb_comm_halo_=1, psb_comm_ovr_=2 integer(psb_ipk_), parameter :: psb_comm_halo_=1, psb_comm_ovr_=2

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

@ -31,7 +31,8 @@
! !
module psi_c_collective_mod module psi_c_collective_mod
use psi_penv_mod use psi_penv_mod
use psb_desc_const_mod
interface psb_sum interface psb_sum
module procedure psb_csums, psb_csumv, psb_csumm module procedure psb_csums, psb_csumv, psb_csumm
@ -79,7 +80,7 @@ contains
! SUM ! SUM
! !
subroutine psb_csums(ctxt,dat,root) subroutine psb_csums(ctxt,dat,root,mode,request)
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -90,11 +91,16 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
complex(psb_spk_), intent(inout) :: dat complex(psb_spk_), intent(inout) :: dat
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
complex(psb_spk_) :: dat_ complex(psb_spk_) :: dat_
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -104,17 +110,41 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,icomm,info) collective_sync = .false.
dat = dat_ 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 else
call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,root_,icomm,info) collective_sync = .true.
if (iam == root_) dat = dat_ collective_start = .false.
endif collective_end = .false.
end if
if (collective_sync) then
if (root_ == -1) then
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)
endif
else
if (collective_start) then
if (root_ == -1) then
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)
end if
else if (collective_end) then
call mpi_wait(request,status,info)
end if
end if
#endif #endif
end subroutine psb_csums end subroutine psb_csums
subroutine psb_csumv(ctxt,dat,root) subroutine psb_csumv(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -126,10 +156,14 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
complex(psb_spk_), intent(inout) :: dat(:) complex(psb_spk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
complex(psb_spk_), allocatable :: dat_(:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -140,25 +174,55 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_) & collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_spk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_spk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_csumv end subroutine psb_csumv
subroutine psb_csumm(ctxt,dat,root) subroutine psb_csumm(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -170,11 +234,15 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
complex(psb_spk_), intent(inout) :: dat(:,:) complex(psb_spk_), intent(inout) :: dat(:,:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
complex(psb_spk_), allocatable :: dat_(:,:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -185,21 +253,50 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_)& collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_spk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_spk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_csumm end subroutine psb_csumm

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

@ -31,7 +31,8 @@
! !
module psi_d_collective_mod module psi_d_collective_mod
use psi_penv_mod use psi_penv_mod
use psb_desc_const_mod
interface psb_max interface psb_max
module procedure psb_dmaxs, psb_dmaxv, psb_dmaxm module procedure psb_dmaxs, psb_dmaxv, psb_dmaxm
end interface end interface
@ -441,7 +442,7 @@ contains
! SUM ! SUM
! !
subroutine psb_dsums(ctxt,dat,root) subroutine psb_dsums(ctxt,dat,root,mode,request)
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -452,11 +453,16 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
real(psb_dpk_), intent(inout) :: dat real(psb_dpk_), intent(inout) :: dat
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
real(psb_dpk_) :: dat_ real(psb_dpk_) :: dat_
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -466,17 +472,41 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,icomm,info) collective_sync = .false.
dat = dat_ 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 else
call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) collective_sync = .true.
if (iam == root_) dat = dat_ collective_start = .false.
endif collective_end = .false.
end if
if (collective_sync) then
if (root_ == -1) then
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)
endif
else
if (collective_start) then
if (root_ == -1) then
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)
end if
else if (collective_end) then
call mpi_wait(request,status,info)
end if
end if
#endif #endif
end subroutine psb_dsums end subroutine psb_dsums
subroutine psb_dsumv(ctxt,dat,root) subroutine psb_dsumv(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -488,10 +518,14 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
real(psb_dpk_), intent(inout) :: dat(:) real(psb_dpk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
real(psb_dpk_), allocatable :: dat_(:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -502,25 +536,55 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_) & collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_dsumv end subroutine psb_dsumv
subroutine psb_dsumm(ctxt,dat,root) subroutine psb_dsumm(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -532,11 +596,15 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
real(psb_dpk_), intent(inout) :: dat(:,:) real(psb_dpk_), intent(inout) :: dat(:,:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
real(psb_dpk_), allocatable :: dat_(:,:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -547,21 +615,50 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_)& collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_dsumm end subroutine psb_dsumm

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

@ -31,7 +31,8 @@
! !
module psi_e_collective_mod module psi_e_collective_mod
use psi_penv_mod use psi_penv_mod
use psb_desc_const_mod
interface psb_max interface psb_max
module procedure psb_emaxs, psb_emaxv, psb_emaxm module procedure psb_emaxs, psb_emaxv, psb_emaxm
end interface end interface
@ -349,7 +350,7 @@ contains
! SUM ! SUM
! !
subroutine psb_esums(ctxt,dat,root) subroutine psb_esums(ctxt,dat,root,mode,request)
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -360,11 +361,16 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_epk_), intent(inout) :: dat integer(psb_epk_), intent(inout) :: dat
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
integer(psb_epk_) :: dat_ integer(psb_epk_) :: dat_
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -374,17 +380,41 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_sum,icomm,info) collective_sync = .false.
dat = dat_ 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 else
call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_sum,root_,icomm,info) collective_sync = .true.
if (iam == root_) dat = dat_ collective_start = .false.
endif collective_end = .false.
end if
if (collective_sync) then
if (root_ == -1) then
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)
endif
else
if (collective_start) then
if (root_ == -1) then
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)
end if
else if (collective_end) then
call mpi_wait(request,status,info)
end if
end if
#endif #endif
end subroutine psb_esums end subroutine psb_esums
subroutine psb_esumv(ctxt,dat,root) subroutine psb_esumv(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -396,10 +426,14 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_epk_), intent(inout) :: dat(:) integer(psb_epk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
integer(psb_epk_), allocatable :: dat_(:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -410,25 +444,55 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_) & collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_epk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_epk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_esumv end subroutine psb_esumv
subroutine psb_esumm(ctxt,dat,root) subroutine psb_esumm(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -440,11 +504,15 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_epk_), intent(inout) :: dat(:,:) integer(psb_epk_), intent(inout) :: dat(:,:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
integer(psb_epk_), allocatable :: dat_(:,:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -455,21 +523,50 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_)& collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_epk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_epk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_esumm end subroutine psb_esumm

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

@ -31,7 +31,8 @@
! !
module psi_i2_collective_mod module psi_i2_collective_mod
use psi_penv_mod use psi_penv_mod
use psb_desc_const_mod
interface psb_max interface psb_max
module procedure psb_i2maxs, psb_i2maxv, psb_i2maxm module procedure psb_i2maxs, psb_i2maxv, psb_i2maxm
end interface end interface
@ -349,7 +350,7 @@ contains
! SUM ! SUM
! !
subroutine psb_i2sums(ctxt,dat,root) subroutine psb_i2sums(ctxt,dat,root,mode,request)
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -360,11 +361,16 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_i2pk_), intent(inout) :: dat integer(psb_i2pk_), intent(inout) :: dat
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
integer(psb_i2pk_) :: dat_ integer(psb_i2pk_) :: dat_
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -374,17 +380,41 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,icomm,info) collective_sync = .false.
dat = dat_ 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 else
call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,root_,icomm,info) collective_sync = .true.
if (iam == root_) dat = dat_ collective_start = .false.
endif collective_end = .false.
end if
if (collective_sync) then
if (root_ == -1) then
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)
endif
else
if (collective_start) then
if (root_ == -1) then
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)
end if
else if (collective_end) then
call mpi_wait(request,status,info)
end if
end if
#endif #endif
end subroutine psb_i2sums end subroutine psb_i2sums
subroutine psb_i2sumv(ctxt,dat,root) subroutine psb_i2sumv(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -396,10 +426,14 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_i2pk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
integer(psb_i2pk_), allocatable :: dat_(:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -410,25 +444,55 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_) & collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_i2pk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_i2pk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_i2sumv end subroutine psb_i2sumv
subroutine psb_i2summ(ctxt,dat,root) subroutine psb_i2summ(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -440,11 +504,15 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_i2pk_), intent(inout) :: dat(:,:) integer(psb_i2pk_), intent(inout) :: dat(:,:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
integer(psb_i2pk_), allocatable :: dat_(:,:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -455,21 +523,50 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_)& collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_i2pk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_i2pk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_i2summ end subroutine psb_i2summ

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

@ -31,7 +31,8 @@
! !
module psi_m_collective_mod module psi_m_collective_mod
use psi_penv_mod use psi_penv_mod
use psb_desc_const_mod
interface psb_max interface psb_max
module procedure psb_mmaxs, psb_mmaxv, psb_mmaxm module procedure psb_mmaxs, psb_mmaxv, psb_mmaxm
end interface end interface
@ -349,7 +350,7 @@ contains
! SUM ! SUM
! !
subroutine psb_msums(ctxt,dat,root) subroutine psb_msums(ctxt,dat,root,mode,request)
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -360,11 +361,16 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(inout) :: dat integer(psb_mpk_), intent(inout) :: dat
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
integer(psb_mpk_) :: dat_ integer(psb_mpk_) :: dat_
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -374,17 +380,41 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_sum,icomm,info) collective_sync = .false.
dat = dat_ 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 else
call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_sum,root_,icomm,info) collective_sync = .true.
if (iam == root_) dat = dat_ collective_start = .false.
endif collective_end = .false.
end if
if (collective_sync) then
if (root_ == -1) then
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)
endif
else
if (collective_start) then
if (root_ == -1) then
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)
end if
else if (collective_end) then
call mpi_wait(request,status,info)
end if
end if
#endif #endif
end subroutine psb_msums end subroutine psb_msums
subroutine psb_msumv(ctxt,dat,root) subroutine psb_msumv(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -396,10 +426,14 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
integer(psb_mpk_), allocatable :: dat_(:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -410,25 +444,55 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_) & collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_mpk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_mpk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_msumv end subroutine psb_msumv
subroutine psb_msumm(ctxt,dat,root) subroutine psb_msumm(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -440,11 +504,15 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(inout) :: dat(:,:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
integer(psb_mpk_), allocatable :: dat_(:,:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -455,21 +523,50 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_)& collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_mpk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_mpk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_msumm end subroutine psb_msumm

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

@ -31,7 +31,8 @@
! !
module psi_s_collective_mod module psi_s_collective_mod
use psi_penv_mod use psi_penv_mod
use psb_desc_const_mod
interface psb_max interface psb_max
module procedure psb_smaxs, psb_smaxv, psb_smaxm module procedure psb_smaxs, psb_smaxv, psb_smaxm
end interface end interface
@ -441,7 +442,7 @@ contains
! SUM ! SUM
! !
subroutine psb_ssums(ctxt,dat,root) subroutine psb_ssums(ctxt,dat,root,mode,request)
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -452,11 +453,16 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
real(psb_spk_), intent(inout) :: dat real(psb_spk_), intent(inout) :: dat
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
real(psb_spk_) :: dat_ real(psb_spk_) :: dat_
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -466,17 +472,41 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,icomm,info) collective_sync = .false.
dat = dat_ 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 else
call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,root_,icomm,info) collective_sync = .true.
if (iam == root_) dat = dat_ collective_start = .false.
endif collective_end = .false.
end if
if (collective_sync) then
if (root_ == -1) then
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)
endif
else
if (collective_start) then
if (root_ == -1) then
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)
end if
else if (collective_end) then
call mpi_wait(request,status,info)
end if
end if
#endif #endif
end subroutine psb_ssums end subroutine psb_ssums
subroutine psb_ssumv(ctxt,dat,root) subroutine psb_ssumv(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -488,10 +518,14 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
real(psb_spk_), intent(inout) :: dat(:) real(psb_spk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
real(psb_spk_), allocatable :: dat_(:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -502,25 +536,55 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_) & collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_ssumv end subroutine psb_ssumv
subroutine psb_ssumm(ctxt,dat,root) subroutine psb_ssumm(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -532,11 +596,15 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
real(psb_spk_), intent(inout) :: dat(:,:) real(psb_spk_), intent(inout) :: dat(:,:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
real(psb_spk_), allocatable :: dat_(:,:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -547,21 +615,50 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_)& collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_ssumm end subroutine psb_ssumm

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

@ -31,7 +31,8 @@
! !
module psi_z_collective_mod module psi_z_collective_mod
use psi_penv_mod use psi_penv_mod
use psb_desc_const_mod
interface psb_sum interface psb_sum
module procedure psb_zsums, psb_zsumv, psb_zsumm module procedure psb_zsums, psb_zsumv, psb_zsumm
@ -79,7 +80,7 @@ contains
! SUM ! SUM
! !
subroutine psb_zsums(ctxt,dat,root) subroutine psb_zsums(ctxt,dat,root,mode,request)
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -90,11 +91,16 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
complex(psb_dpk_), intent(inout) :: dat complex(psb_dpk_), intent(inout) :: dat
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
complex(psb_dpk_) :: dat_ complex(psb_dpk_) :: dat_
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -104,17 +110,41 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,icomm,info) collective_sync = .false.
dat = dat_ 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 else
call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) collective_sync = .true.
if (iam == root_) dat = dat_ collective_start = .false.
endif collective_end = .false.
end if
if (collective_sync) then
if (root_ == -1) then
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)
endif
else
if (collective_start) then
if (root_ == -1) then
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)
end if
else if (collective_end) then
call mpi_wait(request,status,info)
end if
end if
#endif #endif
end subroutine psb_zsums end subroutine psb_zsums
subroutine psb_zsumv(ctxt,dat,root) subroutine psb_zsumv(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -126,10 +156,14 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
complex(psb_dpk_), intent(inout) :: dat(:) complex(psb_dpk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
complex(psb_dpk_), allocatable :: dat_(:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -140,25 +174,55 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_) & collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_zsumv end subroutine psb_zsumv
subroutine psb_zsumm(ctxt,dat,root) subroutine psb_zsumm(ctxt,dat,root,mode,request)
use psb_realloc_mod use psb_realloc_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -170,11 +234,15 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt type(psb_ctxt_type), intent(in) :: ctxt
complex(psb_dpk_), intent(inout) :: dat(:,:) complex(psb_dpk_), intent(inout) :: dat(:,:)
integer(psb_mpk_), intent(in), optional :: root 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_) :: root_
complex(psb_dpk_), allocatable :: dat_(:,:) integer(psb_mpk_) :: iam, np, info
integer(psb_mpk_) :: iam, np, info, icomm integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: status(mpi_status_size)
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
logical :: collective_start, collective_end, collective_sync
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
call psb_info(ctxt,iam,np) call psb_info(ctxt,iam,np)
@ -185,21 +253,50 @@ contains
root_ = -1 root_ = -1
endif endif
icomm = psb_get_mpi_comm(ctxt) icomm = psb_get_mpi_comm(ctxt)
if (root_ == -1) then if (present(mode)) then
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_sync = .false.
dat_ = dat collective_start = iand(mode,psb_collective_start_) /= 0
if (iinfo == psb_success_)& collective_end = iand(mode,psb_collective_end_) /= 0
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,icomm,info) if (.not.present(request)) then
collective_sync = .true.
collective_start = .false.
collective_end = .false.
end if
else else
if (iam == root_) then collective_sync = .true.
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) collective_start = .false.
dat_ = dat collective_end = .false.
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) end if
if (collective_sync) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,icomm,info)
else else
call psb_realloc(1,1,dat_,iinfo) if (iam == root_) then
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
else
call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info)
end if
end if end if
endif else
if (collective_start) then
if (root_ == -1) then
if (iinfo == psb_success_) &
& call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,&
& icomm,request,info)
else
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(MPI_IN_PLACE,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)
endif
end if
#endif #endif
end subroutine psb_zsumm end subroutine psb_zsumm

Write Preview
Loading…
Cancel
Save