diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 index c4ea27283..b48f77d8e 100644 --- a/base/comm/psb_cspgather.F90 +++ b/base/comm/psb_cspgather.F90 @@ -121,24 +121,41 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) - if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if ((root_ == -1).or.(root_ == me)) then + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + else + if (info == psb_success_) call glob_coo%allocate(1,1,1) + end if if (info /= psb_success_) goto 9999 do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) - call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,& - & glob_coo%val,nzbr,idisp,& - & psb_mpi_c_spk_,icomm,minfo) - if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& - & glob_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& - & glob_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - + if (root_ == -1) then + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_c_spk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_ipk_integer,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_ipk_integer,icomm,minfo) + else + call mpi_gatherv(loc_coo%val,ndx,psb_mpi_c_spk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_c_spk_,root_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_gatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_ipk_integer,root_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_gatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_ipk_integer,root_,icomm,minfo) + end if if (minfo /= psb_success_) then info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') @@ -146,9 +163,11 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep end if call loc_coo%free() - call glob_coo%set_nzeros(nzg) - if (present(dupl)) call glob_coo%set_dupl(dupl) - call globa%mv_from(glob_coo) + if ((root_ == -1).or.(root_ == me)) then + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + end if else write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index f928d822b..0e67c8bf0 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -121,24 +121,41 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) - if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if ((root_ == -1).or.(root_ == me)) then + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + else + if (info == psb_success_) call glob_coo%allocate(1,1,1) + end if if (info /= psb_success_) goto 9999 do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) - call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,& - & glob_coo%val,nzbr,idisp,& - & psb_mpi_r_dpk_,icomm,minfo) - if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& - & glob_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& - & glob_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - + if (root_ == -1) then + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_r_dpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_ipk_integer,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_ipk_integer,icomm,minfo) + else + call mpi_gatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_r_dpk_,root_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_gatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_ipk_integer,root_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_gatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_ipk_integer,root_,icomm,minfo) + end if if (minfo /= psb_success_) then info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') @@ -146,9 +163,11 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep end if call loc_coo%free() - call glob_coo%set_nzeros(nzg) - if (present(dupl)) call glob_coo%set_dupl(dupl) - call globa%mv_from(glob_coo) + if ((root_ == -1).or.(root_ == me)) then + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + end if else write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 index e09eb26b5..4f16b1ee0 100644 --- a/base/comm/psb_sspgather.F90 +++ b/base/comm/psb_sspgather.F90 @@ -121,24 +121,41 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) - if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if ((root_ == -1).or.(root_ == me)) then + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + else + if (info == psb_success_) call glob_coo%allocate(1,1,1) + end if if (info /= psb_success_) goto 9999 do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) - call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,& - & glob_coo%val,nzbr,idisp,& - & psb_mpi_r_spk_,icomm,minfo) - if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& - & glob_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& - & glob_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - + if (root_ == -1) then + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_r_spk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_ipk_integer,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_ipk_integer,icomm,minfo) + else + call mpi_gatherv(loc_coo%val,ndx,psb_mpi_r_spk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_r_spk_,root_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_gatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_ipk_integer,root_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_gatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_ipk_integer,root_,icomm,minfo) + end if if (minfo /= psb_success_) then info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') @@ -146,9 +163,11 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep end if call loc_coo%free() - call glob_coo%set_nzeros(nzg) - if (present(dupl)) call glob_coo%set_dupl(dupl) - call globa%mv_from(glob_coo) + if ((root_ == -1).or.(root_ == me)) then + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + end if else write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 index 090b568d3..a93fa0f87 100644 --- a/base/comm/psb_zspgather.F90 +++ b/base/comm/psb_zspgather.F90 @@ -121,24 +121,41 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) - if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if ((root_ == -1).or.(root_ == me)) then + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + else + if (info == psb_success_) call glob_coo%allocate(1,1,1) + end if if (info /= psb_success_) goto 9999 do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) - call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,& - & glob_coo%val,nzbr,idisp,& - & psb_mpi_c_dpk_,icomm,minfo) - if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& - & glob_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& - & glob_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - + if (root_ == -1) then + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_c_dpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_ipk_integer,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_ipk_integer,icomm,minfo) + else + call mpi_gatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_c_dpk_,root_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_gatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_ipk_integer,root_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_gatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_ipk_integer,root_,icomm,minfo) + end if if (minfo /= psb_success_) then info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') @@ -146,9 +163,11 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep end if call loc_coo%free() - call glob_coo%set_nzeros(nzg) - if (present(dupl)) call glob_coo%set_dupl(dupl) - call globa%mv_from(glob_coo) + if ((root_ == -1).or.(root_ == me)) then + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + end if else write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_