From 0b19adab3c242d3d85614e0d2a27fafa8f283a17 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 4 Feb 2022 19:12:32 +0100 Subject: [PATCH] Round of fixes for matrix remote build. Something still wrong. --- base/tools/psb_c_remote_mat.F90 | 147 ++++++++++++++++++-------------- base/tools/psb_cspalloc.f90 | 8 +- base/tools/psb_cspasb.f90 | 36 +++++--- base/tools/psb_cspins.F90 | 6 +- base/tools/psb_d_remote_mat.F90 | 147 ++++++++++++++++++-------------- base/tools/psb_dspalloc.f90 | 8 +- base/tools/psb_dspasb.f90 | 36 +++++--- base/tools/psb_dspins.F90 | 6 +- base/tools/psb_s_remote_mat.F90 | 147 ++++++++++++++++++-------------- base/tools/psb_sspalloc.f90 | 8 +- base/tools/psb_sspasb.f90 | 36 +++++--- base/tools/psb_sspins.F90 | 6 +- base/tools/psb_z_remote_mat.F90 | 147 ++++++++++++++++++-------------- base/tools/psb_zspalloc.f90 | 8 +- base/tools/psb_zspasb.f90 | 36 +++++--- base/tools/psb_zspins.F90 | 6 +- test/pargen/psb_d_pde3d.F90 | 4 +- test/pargen/psb_s_pde3d.F90 | 4 +- 18 files changed, 464 insertions(+), 332 deletions(-) diff --git a/base/tools/psb_c_remote_mat.F90 b/base/tools/psb_c_remote_mat.F90 index acd2ba6e..fcccd26d 100644 --- a/base/tools/psb_c_remote_mat.F90 +++ b/base/tools/psb_c_remote_mat.F90 @@ -98,20 +98,19 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info) integer(psb_ipk_) :: nnp, nrcvs, nsnds integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_), allocatable :: brvindx(:), & - & rvsz(:), bsdindx(:),sdsz(:) + & rvsz(:), bsdindx(:),sdsz(:), sdsi(:), rvsi(:) integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) complex(psb_spk_), allocatable :: valsnd(:) type(psb_lc_coo_sparse_mat), allocatable :: acoo - integer(psb_ipk_), pointer :: idxv(:) class(psb_i_base_vect_type), pointer :: pdxv - integer(psb_ipk_), allocatable :: ipdxv(:), ladj(:), ila(:), iprc(:) + integer(psb_ipk_), allocatable :: ladj(:), ila(:), iprc(:) logical :: rowcnv_,colcnv_,rowscale_,colscale_ character(len=5) :: outfmt_ integer(psb_ipk_) :: debug_level, debug_unit, err_act character(len=20) :: name, ch_err info=psb_success_ - name='psb_csphalo' + name='psb_c_remote_mat' call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -129,9 +128,9 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info) call b%free() - - Allocate(brvindx(np+1),& - & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) + + Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& + & bsdindx(np+1), acoo,stat=info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ @@ -140,71 +139,94 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info) end if - nz = a%get_nzeros() - allocate(ila(nz)) - write(0,*) me,name,' size :',nz,size(ila) - call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) - nouth = count(ila(1:nz)<0) - write(0,*) me,name,' Count out of halo :',nouth - call psb_max(ctxt,nouth) - if ((nouth/=0).and.(me==0)) & - & write(0,*) 'Warning: would require reinit of DESC_A' - - call psi_graph_fnd_owner(a%ia(1:nz),iprc,ladj,desc_a%indxmap,info) - call psb_msort_unique(ladj,nnp) - write(0,*) me,name,' Processes:',ladj(1:nnp) + nz = a%get_nzeros() + allocate(ila(nz)) + !write(0,*) me,name,' size :',nz,size(ila) + call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) + nouth = count(ila(1:nz)<0) + !write(0,*) me,name,' Count out of halo :',nouth + call psb_max(ctxt,nouth) + if ((nouth/=0).and.(me==0)) & + & write(0,*) 'Warning: would require reinit of DESC_A' - icomm = desc_a%get_mpic() - Allocate(brvindx(np+1),& - & rvsz(np),sdsz(np),bsdindx(np+1), stat=info) - sdsz(:)=0 - rvsz(:)=0 - ipx = 1 - brvindx(ipx) = 0 - bsdindx(ipx) = 0 - counter=1 - idx = 0 - idxs = 0 - idxr = 0 - do i=1,nz - if (iprc(i) >=0) then - sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 - else - write(0,*)me,name,' Error from fnd_owner: ',iprc(i) - end if - end do - call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& - & rvsz,1,psb_mpi_mpk_,icomm,minfo) - if (minfo /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='mpi_alltoall') - goto 9999 - end if - write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) - nsnds = count(sdsz /= 0) - nrcvs = count(rvsz /= 0) - idxs = 0 - idxr = 0 - counter = 1 - + call psi_graph_fnd_owner(a%ia(1:nz),iprc,ladj,desc_a%indxmap,info) + call psb_msort_unique(ladj,nnp) + !write(0,*) me,name,' Processes:',ladj(1:nnp) - - - lnnz = max(iszr,iszs,lone) - lnc = a%get_ncols() - call acoo%allocate(lnr,lnc,lnnz) + icomm = desc_a%get_mpic() + sdsz(:)=0 + rvsz(:)=0 + sdsi(:)=0 + rvsi(:)=0 + ipx = 1 + brvindx(:) = 0 + bsdindx(:) = 0 + counter=1 + idx = 0 + idxs = 0 + idxr = 0 + do i=1,nz + if (iprc(i) >=0) then + sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 + else + write(0,*)me,name,' Error from fnd_owner: ',iprc(i) + end if + end do + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (minfo /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) + nsnds = count(sdsz /= 0) + nrcvs = count(rvsz /= 0) + idxs = 0 + idxr = 0 + counter = 1 + Do proc=0,np-1 + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + Enddo + + iszs = sum(sdsz) + iszr = sum(rvsz) + call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) + if (psb_errstatus_fatal()) then + write(0,*) 'Error from acoo%allocate ' + info = 4010 + goto 9999 + end if if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - + !write(debug_unit,*) me,' ',trim(name),': ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) + !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) + !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='ensure_size') goto 9999 end if + do k=1, nz + proc = iprc(k) + sdsi(proc+1) = sdsi(proc+1) + 1 + !rvsi(proc) = rvsi(proc) + 1 + iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k) + jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) + valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) + end do + do proc=0,np-1 + if (sdsi(proc+1) /= sdsz(proc+1)) & + & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) + end do select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) @@ -218,7 +240,7 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) - + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo) if (minfo == mpi_success) & @@ -239,10 +261,9 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info) call psb_errpush(info,name,a_err='alltoallv') goto 9999 end if - + call acoo%set_nzeros(iszr) call acoo%mv_to_coo(b,info) - - + Deallocate(brvindx,bsdindx,rvsz,sdsz,& & iasnd,jasnd,valsnd,stat=info) if (debug_level >= psb_debug_outer_)& diff --git a/base/tools/psb_cspalloc.f90 b/base/tools/psb_cspalloc.f90 index 379cb935..286bb4a0 100644 --- a/base/tools/psb_cspalloc.f90 +++ b/base/tools/psb_cspalloc.f90 @@ -114,16 +114,16 @@ subroutine psb_cspalloc(a, desc_a, info, nnz, bldmode) goto 9999 end if - write(0,*) name,'Setting a%remote_build ',& - & bldmode_,psb_matbld_noremote_,psb_matbld_remote_ +!!$ write(0,*) name,'Setting a%remote_build ',& +!!$ & bldmode_,psb_matbld_noremote_,psb_matbld_remote_ a%remote_build = bldmode_ select case(a%remote_build) case (psb_matbld_noremote_) ! nothing needed - write(0,*) name,' matbld_noremote_ nothing needed' + !write(0,*) name,' matbld_noremote_ nothing needed' case (psb_matbld_remote_) - write(0,*) name,' matbld_remote_ start ' + !write(0,*) name,' matbld_remote_ start ' allocate(a%rmta) nnzrmt_ = max(100,(nnz_/100)) call a%rmta%allocate(m,n,nnzrmt_) diff --git a/base/tools/psb_cspasb.f90 b/base/tools/psb_cspasb.f90 index 4904d336..99c8990e 100644 --- a/base/tools/psb_cspasb.f90 +++ b/base/tools/psb_cspasb.f90 @@ -106,26 +106,38 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl, mold) ! First case: we come from a fresh build. ! - n_row = desc_a%get_local_rows() - n_col = desc_a%get_local_cols() - call a%set_nrows(n_row) - call a%set_ncols(n_col) - end if - - if (a%is_bld()) then - select case(a%remote_build) case (psb_matbld_noremote_) ! nothing needed case (psb_matbld_remote_) - write(0,*) me,name,' Size of rmta:',a%rmta%get_nzeros() + !write(0,*) me,name,' Size of rmta:',a%rmta%get_nzeros() block type(psb_lc_coo_sparse_mat) :: a_add - + integer(psb_ipk_), allocatable :: ila(:), jla(:) + integer(psb_ipk_) :: nz, nzt,k call psb_remote_mat(a%rmta,desc_a,a_add,info) - - end block + nz = a_add%get_nzeros() +!!$ write(0,*) me,name,' Nz to be added',nz + nzt = nz + call psb_sum(ctxt,nzt) + if (nzt>0) call psb_cd_reinit(desc_a, info) + if (nz > 0) then + ! + ! Should we check for new indices here? + ! + call psb_realloc(nz,ila,info) + call psb_realloc(nz,jla,info) + call desc_a%indxmap%g2l(a_add%ia(1:nz),ila(1:nz),info,owned=.true.) + if (info == 0) call desc_a%indxmap%g2l_ins(a_add%ja(1:nz),jla(1:nz),info) + !write(0,*) me,name,' Check before insert',a%get_nzeros() + n_row = desc_a%get_local_rows() + n_col = desc_a%get_local_cols() + call a%csput(nz,ila,jla,a_add%val,ione,n_row,ione,n_col,info) + !write(0,*) me,name,' Check after insert',a%get_nzeros(),nz + end if + if (nzt > 0) call psb_cdasb(desc_a,info) + end block end select call a%cscnv(info,type=afmt,dupl=dupl, mold=mold) diff --git a/base/tools/psb_cspins.F90 b/base/tools/psb_cspins.F90 index 6c050b0c..553e3e3d 100644 --- a/base/tools/psb_cspins.F90 +++ b/base/tools/psb_cspins.F90 @@ -164,9 +164,9 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) do i=1,nz if (ila(i)<0) then k=k+1 - lila(k) = ia(k) - ljla(k) = ja(k) - lval(k) = val(k) + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) end if end do if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl diff --git a/base/tools/psb_d_remote_mat.F90 b/base/tools/psb_d_remote_mat.F90 index 3e35970a..290a6f3d 100644 --- a/base/tools/psb_d_remote_mat.F90 +++ b/base/tools/psb_d_remote_mat.F90 @@ -98,20 +98,19 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info) integer(psb_ipk_) :: nnp, nrcvs, nsnds integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_), allocatable :: brvindx(:), & - & rvsz(:), bsdindx(:),sdsz(:) + & rvsz(:), bsdindx(:),sdsz(:), sdsi(:), rvsi(:) integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) real(psb_dpk_), allocatable :: valsnd(:) type(psb_ld_coo_sparse_mat), allocatable :: acoo - integer(psb_ipk_), pointer :: idxv(:) class(psb_i_base_vect_type), pointer :: pdxv - integer(psb_ipk_), allocatable :: ipdxv(:), ladj(:), ila(:), iprc(:) + integer(psb_ipk_), allocatable :: ladj(:), ila(:), iprc(:) logical :: rowcnv_,colcnv_,rowscale_,colscale_ character(len=5) :: outfmt_ integer(psb_ipk_) :: debug_level, debug_unit, err_act character(len=20) :: name, ch_err info=psb_success_ - name='psb_dsphalo' + name='psb_d_remote_mat' call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -129,9 +128,9 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info) call b%free() - - Allocate(brvindx(np+1),& - & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) + + Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& + & bsdindx(np+1), acoo,stat=info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ @@ -140,71 +139,94 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info) end if - nz = a%get_nzeros() - allocate(ila(nz)) - write(0,*) me,name,' size :',nz,size(ila) - call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) - nouth = count(ila(1:nz)<0) - write(0,*) me,name,' Count out of halo :',nouth - call psb_max(ctxt,nouth) - if ((nouth/=0).and.(me==0)) & - & write(0,*) 'Warning: would require reinit of DESC_A' - - call psi_graph_fnd_owner(a%ia(1:nz),iprc,ladj,desc_a%indxmap,info) - call psb_msort_unique(ladj,nnp) - write(0,*) me,name,' Processes:',ladj(1:nnp) + nz = a%get_nzeros() + allocate(ila(nz)) + !write(0,*) me,name,' size :',nz,size(ila) + call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) + nouth = count(ila(1:nz)<0) + !write(0,*) me,name,' Count out of halo :',nouth + call psb_max(ctxt,nouth) + if ((nouth/=0).and.(me==0)) & + & write(0,*) 'Warning: would require reinit of DESC_A' - icomm = desc_a%get_mpic() - Allocate(brvindx(np+1),& - & rvsz(np),sdsz(np),bsdindx(np+1), stat=info) - sdsz(:)=0 - rvsz(:)=0 - ipx = 1 - brvindx(ipx) = 0 - bsdindx(ipx) = 0 - counter=1 - idx = 0 - idxs = 0 - idxr = 0 - do i=1,nz - if (iprc(i) >=0) then - sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 - else - write(0,*)me,name,' Error from fnd_owner: ',iprc(i) - end if - end do - call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& - & rvsz,1,psb_mpi_mpk_,icomm,minfo) - if (minfo /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='mpi_alltoall') - goto 9999 - end if - write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) - nsnds = count(sdsz /= 0) - nrcvs = count(rvsz /= 0) - idxs = 0 - idxr = 0 - counter = 1 - + call psi_graph_fnd_owner(a%ia(1:nz),iprc,ladj,desc_a%indxmap,info) + call psb_msort_unique(ladj,nnp) + !write(0,*) me,name,' Processes:',ladj(1:nnp) - - - lnnz = max(iszr,iszs,lone) - lnc = a%get_ncols() - call acoo%allocate(lnr,lnc,lnnz) + icomm = desc_a%get_mpic() + sdsz(:)=0 + rvsz(:)=0 + sdsi(:)=0 + rvsi(:)=0 + ipx = 1 + brvindx(:) = 0 + bsdindx(:) = 0 + counter=1 + idx = 0 + idxs = 0 + idxr = 0 + do i=1,nz + if (iprc(i) >=0) then + sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 + else + write(0,*)me,name,' Error from fnd_owner: ',iprc(i) + end if + end do + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (minfo /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) + nsnds = count(sdsz /= 0) + nrcvs = count(rvsz /= 0) + idxs = 0 + idxr = 0 + counter = 1 + Do proc=0,np-1 + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + Enddo + + iszs = sum(sdsz) + iszr = sum(rvsz) + call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) + if (psb_errstatus_fatal()) then + write(0,*) 'Error from acoo%allocate ' + info = 4010 + goto 9999 + end if if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - + !write(debug_unit,*) me,' ',trim(name),': ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) + !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) + !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='ensure_size') goto 9999 end if + do k=1, nz + proc = iprc(k) + sdsi(proc+1) = sdsi(proc+1) + 1 + !rvsi(proc) = rvsi(proc) + 1 + iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k) + jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) + valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) + end do + do proc=0,np-1 + if (sdsi(proc+1) /= sdsz(proc+1)) & + & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) + end do select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) @@ -218,7 +240,7 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) - + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo) if (minfo == mpi_success) & @@ -239,10 +261,9 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info) call psb_errpush(info,name,a_err='alltoallv') goto 9999 end if - + call acoo%set_nzeros(iszr) call acoo%mv_to_coo(b,info) - - + Deallocate(brvindx,bsdindx,rvsz,sdsz,& & iasnd,jasnd,valsnd,stat=info) if (debug_level >= psb_debug_outer_)& diff --git a/base/tools/psb_dspalloc.f90 b/base/tools/psb_dspalloc.f90 index 3d945274..781a3abf 100644 --- a/base/tools/psb_dspalloc.f90 +++ b/base/tools/psb_dspalloc.f90 @@ -114,16 +114,16 @@ subroutine psb_dspalloc(a, desc_a, info, nnz, bldmode) goto 9999 end if - write(0,*) name,'Setting a%remote_build ',& - & bldmode_,psb_matbld_noremote_,psb_matbld_remote_ +!!$ write(0,*) name,'Setting a%remote_build ',& +!!$ & bldmode_,psb_matbld_noremote_,psb_matbld_remote_ a%remote_build = bldmode_ select case(a%remote_build) case (psb_matbld_noremote_) ! nothing needed - write(0,*) name,' matbld_noremote_ nothing needed' + !write(0,*) name,' matbld_noremote_ nothing needed' case (psb_matbld_remote_) - write(0,*) name,' matbld_remote_ start ' + !write(0,*) name,' matbld_remote_ start ' allocate(a%rmta) nnzrmt_ = max(100,(nnz_/100)) call a%rmta%allocate(m,n,nnzrmt_) diff --git a/base/tools/psb_dspasb.f90 b/base/tools/psb_dspasb.f90 index bc66eb11..c9d3cd08 100644 --- a/base/tools/psb_dspasb.f90 +++ b/base/tools/psb_dspasb.f90 @@ -106,26 +106,38 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold) ! First case: we come from a fresh build. ! - n_row = desc_a%get_local_rows() - n_col = desc_a%get_local_cols() - call a%set_nrows(n_row) - call a%set_ncols(n_col) - end if - - if (a%is_bld()) then - select case(a%remote_build) case (psb_matbld_noremote_) ! nothing needed case (psb_matbld_remote_) - write(0,*) me,name,' Size of rmta:',a%rmta%get_nzeros() + !write(0,*) me,name,' Size of rmta:',a%rmta%get_nzeros() block type(psb_ld_coo_sparse_mat) :: a_add - + integer(psb_ipk_), allocatable :: ila(:), jla(:) + integer(psb_ipk_) :: nz, nzt,k call psb_remote_mat(a%rmta,desc_a,a_add,info) - - end block + nz = a_add%get_nzeros() +!!$ write(0,*) me,name,' Nz to be added',nz + nzt = nz + call psb_sum(ctxt,nzt) + if (nzt>0) call psb_cd_reinit(desc_a, info) + if (nz > 0) then + ! + ! Should we check for new indices here? + ! + call psb_realloc(nz,ila,info) + call psb_realloc(nz,jla,info) + call desc_a%indxmap%g2l(a_add%ia(1:nz),ila(1:nz),info,owned=.true.) + if (info == 0) call desc_a%indxmap%g2l_ins(a_add%ja(1:nz),jla(1:nz),info) + !write(0,*) me,name,' Check before insert',a%get_nzeros() + n_row = desc_a%get_local_rows() + n_col = desc_a%get_local_cols() + call a%csput(nz,ila,jla,a_add%val,ione,n_row,ione,n_col,info) + !write(0,*) me,name,' Check after insert',a%get_nzeros(),nz + end if + if (nzt > 0) call psb_cdasb(desc_a,info) + end block end select call a%cscnv(info,type=afmt,dupl=dupl, mold=mold) diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index 06276fa8..064b816c 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -164,9 +164,9 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) do i=1,nz if (ila(i)<0) then k=k+1 - lila(k) = ia(k) - ljla(k) = ja(k) - lval(k) = val(k) + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) end if end do if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl diff --git a/base/tools/psb_s_remote_mat.F90 b/base/tools/psb_s_remote_mat.F90 index 0a78d2b6..26b12652 100644 --- a/base/tools/psb_s_remote_mat.F90 +++ b/base/tools/psb_s_remote_mat.F90 @@ -98,20 +98,19 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info) integer(psb_ipk_) :: nnp, nrcvs, nsnds integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_), allocatable :: brvindx(:), & - & rvsz(:), bsdindx(:),sdsz(:) + & rvsz(:), bsdindx(:),sdsz(:), sdsi(:), rvsi(:) integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) real(psb_spk_), allocatable :: valsnd(:) type(psb_ls_coo_sparse_mat), allocatable :: acoo - integer(psb_ipk_), pointer :: idxv(:) class(psb_i_base_vect_type), pointer :: pdxv - integer(psb_ipk_), allocatable :: ipdxv(:), ladj(:), ila(:), iprc(:) + integer(psb_ipk_), allocatable :: ladj(:), ila(:), iprc(:) logical :: rowcnv_,colcnv_,rowscale_,colscale_ character(len=5) :: outfmt_ integer(psb_ipk_) :: debug_level, debug_unit, err_act character(len=20) :: name, ch_err info=psb_success_ - name='psb_ssphalo' + name='psb_s_remote_mat' call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -129,9 +128,9 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info) call b%free() - - Allocate(brvindx(np+1),& - & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) + + Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& + & bsdindx(np+1), acoo,stat=info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ @@ -140,71 +139,94 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info) end if - nz = a%get_nzeros() - allocate(ila(nz)) - write(0,*) me,name,' size :',nz,size(ila) - call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) - nouth = count(ila(1:nz)<0) - write(0,*) me,name,' Count out of halo :',nouth - call psb_max(ctxt,nouth) - if ((nouth/=0).and.(me==0)) & - & write(0,*) 'Warning: would require reinit of DESC_A' - - call psi_graph_fnd_owner(a%ia(1:nz),iprc,ladj,desc_a%indxmap,info) - call psb_msort_unique(ladj,nnp) - write(0,*) me,name,' Processes:',ladj(1:nnp) + nz = a%get_nzeros() + allocate(ila(nz)) + !write(0,*) me,name,' size :',nz,size(ila) + call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) + nouth = count(ila(1:nz)<0) + !write(0,*) me,name,' Count out of halo :',nouth + call psb_max(ctxt,nouth) + if ((nouth/=0).and.(me==0)) & + & write(0,*) 'Warning: would require reinit of DESC_A' - icomm = desc_a%get_mpic() - Allocate(brvindx(np+1),& - & rvsz(np),sdsz(np),bsdindx(np+1), stat=info) - sdsz(:)=0 - rvsz(:)=0 - ipx = 1 - brvindx(ipx) = 0 - bsdindx(ipx) = 0 - counter=1 - idx = 0 - idxs = 0 - idxr = 0 - do i=1,nz - if (iprc(i) >=0) then - sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 - else - write(0,*)me,name,' Error from fnd_owner: ',iprc(i) - end if - end do - call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& - & rvsz,1,psb_mpi_mpk_,icomm,minfo) - if (minfo /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='mpi_alltoall') - goto 9999 - end if - write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) - nsnds = count(sdsz /= 0) - nrcvs = count(rvsz /= 0) - idxs = 0 - idxr = 0 - counter = 1 - + call psi_graph_fnd_owner(a%ia(1:nz),iprc,ladj,desc_a%indxmap,info) + call psb_msort_unique(ladj,nnp) + !write(0,*) me,name,' Processes:',ladj(1:nnp) - - - lnnz = max(iszr,iszs,lone) - lnc = a%get_ncols() - call acoo%allocate(lnr,lnc,lnnz) + icomm = desc_a%get_mpic() + sdsz(:)=0 + rvsz(:)=0 + sdsi(:)=0 + rvsi(:)=0 + ipx = 1 + brvindx(:) = 0 + bsdindx(:) = 0 + counter=1 + idx = 0 + idxs = 0 + idxr = 0 + do i=1,nz + if (iprc(i) >=0) then + sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 + else + write(0,*)me,name,' Error from fnd_owner: ',iprc(i) + end if + end do + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (minfo /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) + nsnds = count(sdsz /= 0) + nrcvs = count(rvsz /= 0) + idxs = 0 + idxr = 0 + counter = 1 + Do proc=0,np-1 + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + Enddo + + iszs = sum(sdsz) + iszr = sum(rvsz) + call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) + if (psb_errstatus_fatal()) then + write(0,*) 'Error from acoo%allocate ' + info = 4010 + goto 9999 + end if if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - + !write(debug_unit,*) me,' ',trim(name),': ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) + !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) + !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='ensure_size') goto 9999 end if + do k=1, nz + proc = iprc(k) + sdsi(proc+1) = sdsi(proc+1) + 1 + !rvsi(proc) = rvsi(proc) + 1 + iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k) + jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) + valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) + end do + do proc=0,np-1 + if (sdsi(proc+1) /= sdsz(proc+1)) & + & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) + end do select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) @@ -218,7 +240,7 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) - + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo) if (minfo == mpi_success) & @@ -239,10 +261,9 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info) call psb_errpush(info,name,a_err='alltoallv') goto 9999 end if - + call acoo%set_nzeros(iszr) call acoo%mv_to_coo(b,info) - - + Deallocate(brvindx,bsdindx,rvsz,sdsz,& & iasnd,jasnd,valsnd,stat=info) if (debug_level >= psb_debug_outer_)& diff --git a/base/tools/psb_sspalloc.f90 b/base/tools/psb_sspalloc.f90 index 2d79b0ba..14e784da 100644 --- a/base/tools/psb_sspalloc.f90 +++ b/base/tools/psb_sspalloc.f90 @@ -114,16 +114,16 @@ subroutine psb_sspalloc(a, desc_a, info, nnz, bldmode) goto 9999 end if - write(0,*) name,'Setting a%remote_build ',& - & bldmode_,psb_matbld_noremote_,psb_matbld_remote_ +!!$ write(0,*) name,'Setting a%remote_build ',& +!!$ & bldmode_,psb_matbld_noremote_,psb_matbld_remote_ a%remote_build = bldmode_ select case(a%remote_build) case (psb_matbld_noremote_) ! nothing needed - write(0,*) name,' matbld_noremote_ nothing needed' + !write(0,*) name,' matbld_noremote_ nothing needed' case (psb_matbld_remote_) - write(0,*) name,' matbld_remote_ start ' + !write(0,*) name,' matbld_remote_ start ' allocate(a%rmta) nnzrmt_ = max(100,(nnz_/100)) call a%rmta%allocate(m,n,nnzrmt_) diff --git a/base/tools/psb_sspasb.f90 b/base/tools/psb_sspasb.f90 index fa9a2a49..9249c59c 100644 --- a/base/tools/psb_sspasb.f90 +++ b/base/tools/psb_sspasb.f90 @@ -106,26 +106,38 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold) ! First case: we come from a fresh build. ! - n_row = desc_a%get_local_rows() - n_col = desc_a%get_local_cols() - call a%set_nrows(n_row) - call a%set_ncols(n_col) - end if - - if (a%is_bld()) then - select case(a%remote_build) case (psb_matbld_noremote_) ! nothing needed case (psb_matbld_remote_) - write(0,*) me,name,' Size of rmta:',a%rmta%get_nzeros() + !write(0,*) me,name,' Size of rmta:',a%rmta%get_nzeros() block type(psb_ls_coo_sparse_mat) :: a_add - + integer(psb_ipk_), allocatable :: ila(:), jla(:) + integer(psb_ipk_) :: nz, nzt,k call psb_remote_mat(a%rmta,desc_a,a_add,info) - - end block + nz = a_add%get_nzeros() +!!$ write(0,*) me,name,' Nz to be added',nz + nzt = nz + call psb_sum(ctxt,nzt) + if (nzt>0) call psb_cd_reinit(desc_a, info) + if (nz > 0) then + ! + ! Should we check for new indices here? + ! + call psb_realloc(nz,ila,info) + call psb_realloc(nz,jla,info) + call desc_a%indxmap%g2l(a_add%ia(1:nz),ila(1:nz),info,owned=.true.) + if (info == 0) call desc_a%indxmap%g2l_ins(a_add%ja(1:nz),jla(1:nz),info) + !write(0,*) me,name,' Check before insert',a%get_nzeros() + n_row = desc_a%get_local_rows() + n_col = desc_a%get_local_cols() + call a%csput(nz,ila,jla,a_add%val,ione,n_row,ione,n_col,info) + !write(0,*) me,name,' Check after insert',a%get_nzeros(),nz + end if + if (nzt > 0) call psb_cdasb(desc_a,info) + end block end select call a%cscnv(info,type=afmt,dupl=dupl, mold=mold) diff --git a/base/tools/psb_sspins.F90 b/base/tools/psb_sspins.F90 index c4abb9f6..e49e7423 100644 --- a/base/tools/psb_sspins.F90 +++ b/base/tools/psb_sspins.F90 @@ -164,9 +164,9 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) do i=1,nz if (ila(i)<0) then k=k+1 - lila(k) = ia(k) - ljla(k) = ja(k) - lval(k) = val(k) + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) end if end do if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl diff --git a/base/tools/psb_z_remote_mat.F90 b/base/tools/psb_z_remote_mat.F90 index 1acc57b2..7b2ade7c 100644 --- a/base/tools/psb_z_remote_mat.F90 +++ b/base/tools/psb_z_remote_mat.F90 @@ -98,20 +98,19 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info) integer(psb_ipk_) :: nnp, nrcvs, nsnds integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_), allocatable :: brvindx(:), & - & rvsz(:), bsdindx(:),sdsz(:) + & rvsz(:), bsdindx(:),sdsz(:), sdsi(:), rvsi(:) integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) complex(psb_dpk_), allocatable :: valsnd(:) type(psb_lz_coo_sparse_mat), allocatable :: acoo - integer(psb_ipk_), pointer :: idxv(:) class(psb_i_base_vect_type), pointer :: pdxv - integer(psb_ipk_), allocatable :: ipdxv(:), ladj(:), ila(:), iprc(:) + integer(psb_ipk_), allocatable :: ladj(:), ila(:), iprc(:) logical :: rowcnv_,colcnv_,rowscale_,colscale_ character(len=5) :: outfmt_ integer(psb_ipk_) :: debug_level, debug_unit, err_act character(len=20) :: name, ch_err info=psb_success_ - name='psb_zsphalo' + name='psb_z_remote_mat' call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -129,9 +128,9 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info) call b%free() - - Allocate(brvindx(np+1),& - & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) + + Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& + & bsdindx(np+1), acoo,stat=info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ @@ -140,71 +139,94 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info) end if - nz = a%get_nzeros() - allocate(ila(nz)) - write(0,*) me,name,' size :',nz,size(ila) - call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) - nouth = count(ila(1:nz)<0) - write(0,*) me,name,' Count out of halo :',nouth - call psb_max(ctxt,nouth) - if ((nouth/=0).and.(me==0)) & - & write(0,*) 'Warning: would require reinit of DESC_A' - - call psi_graph_fnd_owner(a%ia(1:nz),iprc,ladj,desc_a%indxmap,info) - call psb_msort_unique(ladj,nnp) - write(0,*) me,name,' Processes:',ladj(1:nnp) + nz = a%get_nzeros() + allocate(ila(nz)) + !write(0,*) me,name,' size :',nz,size(ila) + call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) + nouth = count(ila(1:nz)<0) + !write(0,*) me,name,' Count out of halo :',nouth + call psb_max(ctxt,nouth) + if ((nouth/=0).and.(me==0)) & + & write(0,*) 'Warning: would require reinit of DESC_A' - icomm = desc_a%get_mpic() - Allocate(brvindx(np+1),& - & rvsz(np),sdsz(np),bsdindx(np+1), stat=info) - sdsz(:)=0 - rvsz(:)=0 - ipx = 1 - brvindx(ipx) = 0 - bsdindx(ipx) = 0 - counter=1 - idx = 0 - idxs = 0 - idxr = 0 - do i=1,nz - if (iprc(i) >=0) then - sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 - else - write(0,*)me,name,' Error from fnd_owner: ',iprc(i) - end if - end do - call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& - & rvsz,1,psb_mpi_mpk_,icomm,minfo) - if (minfo /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='mpi_alltoall') - goto 9999 - end if - write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) - nsnds = count(sdsz /= 0) - nrcvs = count(rvsz /= 0) - idxs = 0 - idxr = 0 - counter = 1 - + call psi_graph_fnd_owner(a%ia(1:nz),iprc,ladj,desc_a%indxmap,info) + call psb_msort_unique(ladj,nnp) + !write(0,*) me,name,' Processes:',ladj(1:nnp) - - - lnnz = max(iszr,iszs,lone) - lnc = a%get_ncols() - call acoo%allocate(lnr,lnc,lnnz) + icomm = desc_a%get_mpic() + sdsz(:)=0 + rvsz(:)=0 + sdsi(:)=0 + rvsi(:)=0 + ipx = 1 + brvindx(:) = 0 + bsdindx(:) = 0 + counter=1 + idx = 0 + idxs = 0 + idxr = 0 + do i=1,nz + if (iprc(i) >=0) then + sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 + else + write(0,*)me,name,' Error from fnd_owner: ',iprc(i) + end if + end do + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (minfo /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) + nsnds = count(sdsz /= 0) + nrcvs = count(rvsz /= 0) + idxs = 0 + idxr = 0 + counter = 1 + Do proc=0,np-1 + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + Enddo + + iszs = sum(sdsz) + iszr = sum(rvsz) + call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) + if (psb_errstatus_fatal()) then + write(0,*) 'Error from acoo%allocate ' + info = 4010 + goto 9999 + end if if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - + !write(debug_unit,*) me,' ',trim(name),': ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) + !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) + !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='ensure_size') goto 9999 end if + do k=1, nz + proc = iprc(k) + sdsi(proc+1) = sdsi(proc+1) + 1 + !rvsi(proc) = rvsi(proc) + 1 + iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k) + jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) + valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) + end do + do proc=0,np-1 + if (sdsi(proc+1) /= sdsz(proc+1)) & + & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) + end do select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) @@ -218,7 +240,7 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) - + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo) if (minfo == mpi_success) & @@ -239,10 +261,9 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info) call psb_errpush(info,name,a_err='alltoallv') goto 9999 end if - + call acoo%set_nzeros(iszr) call acoo%mv_to_coo(b,info) - - + Deallocate(brvindx,bsdindx,rvsz,sdsz,& & iasnd,jasnd,valsnd,stat=info) if (debug_level >= psb_debug_outer_)& diff --git a/base/tools/psb_zspalloc.f90 b/base/tools/psb_zspalloc.f90 index 1d76d66c..3b0fc7d2 100644 --- a/base/tools/psb_zspalloc.f90 +++ b/base/tools/psb_zspalloc.f90 @@ -114,16 +114,16 @@ subroutine psb_zspalloc(a, desc_a, info, nnz, bldmode) goto 9999 end if - write(0,*) name,'Setting a%remote_build ',& - & bldmode_,psb_matbld_noremote_,psb_matbld_remote_ +!!$ write(0,*) name,'Setting a%remote_build ',& +!!$ & bldmode_,psb_matbld_noremote_,psb_matbld_remote_ a%remote_build = bldmode_ select case(a%remote_build) case (psb_matbld_noremote_) ! nothing needed - write(0,*) name,' matbld_noremote_ nothing needed' + !write(0,*) name,' matbld_noremote_ nothing needed' case (psb_matbld_remote_) - write(0,*) name,' matbld_remote_ start ' + !write(0,*) name,' matbld_remote_ start ' allocate(a%rmta) nnzrmt_ = max(100,(nnz_/100)) call a%rmta%allocate(m,n,nnzrmt_) diff --git a/base/tools/psb_zspasb.f90 b/base/tools/psb_zspasb.f90 index 67353739..d92daa2c 100644 --- a/base/tools/psb_zspasb.f90 +++ b/base/tools/psb_zspasb.f90 @@ -106,26 +106,38 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold) ! First case: we come from a fresh build. ! - n_row = desc_a%get_local_rows() - n_col = desc_a%get_local_cols() - call a%set_nrows(n_row) - call a%set_ncols(n_col) - end if - - if (a%is_bld()) then - select case(a%remote_build) case (psb_matbld_noremote_) ! nothing needed case (psb_matbld_remote_) - write(0,*) me,name,' Size of rmta:',a%rmta%get_nzeros() + !write(0,*) me,name,' Size of rmta:',a%rmta%get_nzeros() block type(psb_lz_coo_sparse_mat) :: a_add - + integer(psb_ipk_), allocatable :: ila(:), jla(:) + integer(psb_ipk_) :: nz, nzt,k call psb_remote_mat(a%rmta,desc_a,a_add,info) - - end block + nz = a_add%get_nzeros() +!!$ write(0,*) me,name,' Nz to be added',nz + nzt = nz + call psb_sum(ctxt,nzt) + if (nzt>0) call psb_cd_reinit(desc_a, info) + if (nz > 0) then + ! + ! Should we check for new indices here? + ! + call psb_realloc(nz,ila,info) + call psb_realloc(nz,jla,info) + call desc_a%indxmap%g2l(a_add%ia(1:nz),ila(1:nz),info,owned=.true.) + if (info == 0) call desc_a%indxmap%g2l_ins(a_add%ja(1:nz),jla(1:nz),info) + !write(0,*) me,name,' Check before insert',a%get_nzeros() + n_row = desc_a%get_local_rows() + n_col = desc_a%get_local_cols() + call a%csput(nz,ila,jla,a_add%val,ione,n_row,ione,n_col,info) + !write(0,*) me,name,' Check after insert',a%get_nzeros(),nz + end if + if (nzt > 0) call psb_cdasb(desc_a,info) + end block end select call a%cscnv(info,type=afmt,dupl=dupl, mold=mold) diff --git a/base/tools/psb_zspins.F90 b/base/tools/psb_zspins.F90 index 2a654e14..835a4d04 100644 --- a/base/tools/psb_zspins.F90 +++ b/base/tools/psb_zspins.F90 @@ -164,9 +164,9 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) do i=1,nz if (ila(i)<0) then k=k+1 - lila(k) = ia(k) - ljla(k) = ja(k) - lval(k) = val(k) + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) end if end do if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl diff --git a/test/pargen/psb_d_pde3d.F90 b/test/pargen/psb_d_pde3d.F90 index 483e6d9c..2384d410 100644 --- a/test/pargen/psb_d_pde3d.F90 +++ b/test/pargen/psb_d_pde3d.F90 @@ -679,9 +679,9 @@ contains t1 = psb_wtime() if (info == psb_success_) then if (present(amold)) then - call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=amold) + call psb_spasb(a,desc_a,info,dupl=psb_dupl_add_,mold=amold) else - call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + call psb_spasb(a,desc_a,info,dupl=psb_dupl_add_,afmt=afmt) end if end if call psb_barrier(ctxt) diff --git a/test/pargen/psb_s_pde3d.F90 b/test/pargen/psb_s_pde3d.F90 index b27f8818..96dbd5db 100644 --- a/test/pargen/psb_s_pde3d.F90 +++ b/test/pargen/psb_s_pde3d.F90 @@ -679,9 +679,9 @@ contains t1 = psb_wtime() if (info == psb_success_) then if (present(amold)) then - call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=amold) + call psb_spasb(a,desc_a,info,dupl=psb_dupl_add_,mold=amold) else - call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + call psb_spasb(a,desc_a,info,dupl=psb_dupl_add_,afmt=afmt) end if end if call psb_barrier(ctxt)