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

Round of fixes for matrix remote build. Something still wrong.

Browse Source
remotebuild
Salvatore Filippone 3 years ago
parent 6d0b26ecf1
commit 0b19adab3c
18 changed files with 464 additions and 332 deletions
Show Stats Download Patch File Download Diff File

67
base/tools/psb_c_remote_mat.F90
Unescape Escape View File

@ -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
@ -130,8 +129,8 @@ 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_
@ -142,26 +141,26 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info)
nz = a%get_nzeros()
allocate(ila(nz))
write(0,*) me,name,' size :',nz,size(ila)
!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
!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)
!write(0,*) me,name,' Processes:',ladj(1:nnp)
icomm = desc_a%get_mpic()
Allocate(brvindx(np+1),&
& rvsz(np),sdsz(np),bsdindx(np+1), stat=info)
sdsz(:)=0
rvsz(:)=0
sdsi(:)=0
rvsi(:)=0
ipx = 1
brvindx(ipx) = 0
bsdindx(ipx) = 0
brvindx(:) = 0
bsdindx(:) = 0
counter=1
idx = 0
idxs = 0
@ -180,31 +179,54 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info)
call psb_errpush(info,name,a_err='mpi_alltoall')
goto 9999
end if
write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:)
!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
lnnz = max(iszr,iszs,lone)
lnc = a%get_ncols()
call acoo%allocate(lnr,lnc,lnnz)
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_)
@ -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_)&

8
base/tools/psb_cspalloc.f90
Unescape Escape View File

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

34
base/tools/psb_cspasb.f90
Unescape Escape View File

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

6
base/tools/psb_cspins.F90
Unescape Escape View File

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

67
base/tools/psb_d_remote_mat.F90
Unescape Escape View File

@ -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
@ -130,8 +129,8 @@ 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_
@ -142,26 +141,26 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info)
nz = a%get_nzeros()
allocate(ila(nz))
write(0,*) me,name,' size :',nz,size(ila)
!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
!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)
!write(0,*) me,name,' Processes:',ladj(1:nnp)
icomm = desc_a%get_mpic()
Allocate(brvindx(np+1),&
& rvsz(np),sdsz(np),bsdindx(np+1), stat=info)
sdsz(:)=0
rvsz(:)=0
sdsi(:)=0
rvsi(:)=0
ipx = 1
brvindx(ipx) = 0
bsdindx(ipx) = 0
brvindx(:) = 0
bsdindx(:) = 0
counter=1
idx = 0
idxs = 0
@ -180,31 +179,54 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info)
call psb_errpush(info,name,a_err='mpi_alltoall')
goto 9999
end if
write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:)
!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
lnnz = max(iszr,iszs,lone)
lnc = a%get_ncols()
call acoo%allocate(lnr,lnc,lnnz)
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_)
@ -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_)&

8
base/tools/psb_dspalloc.f90
Unescape Escape View File

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

34
base/tools/psb_dspasb.f90
Unescape Escape View File

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

6
base/tools/psb_dspins.F90
Unescape Escape View File

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

67
base/tools/psb_s_remote_mat.F90
Unescape Escape View File

@ -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
@ -130,8 +129,8 @@ 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_
@ -142,26 +141,26 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info)
nz = a%get_nzeros()
allocate(ila(nz))
write(0,*) me,name,' size :',nz,size(ila)
!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
!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)
!write(0,*) me,name,' Processes:',ladj(1:nnp)
icomm = desc_a%get_mpic()
Allocate(brvindx(np+1),&
& rvsz(np),sdsz(np),bsdindx(np+1), stat=info)
sdsz(:)=0
rvsz(:)=0
sdsi(:)=0
rvsi(:)=0
ipx = 1
brvindx(ipx) = 0
bsdindx(ipx) = 0
brvindx(:) = 0
bsdindx(:) = 0
counter=1
idx = 0
idxs = 0
@ -180,31 +179,54 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info)
call psb_errpush(info,name,a_err='mpi_alltoall')
goto 9999
end if
write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:)
!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
lnnz = max(iszr,iszs,lone)
lnc = a%get_ncols()
call acoo%allocate(lnr,lnc,lnnz)
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_)
@ -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_)&

8
base/tools/psb_sspalloc.f90
Unescape Escape View File

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

34
base/tools/psb_sspasb.f90
Unescape Escape View File

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

6
base/tools/psb_sspins.F90
Unescape Escape View File

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

67
base/tools/psb_z_remote_mat.F90
Unescape Escape View File

@ -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
@ -130,8 +129,8 @@ 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_
@ -142,26 +141,26 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info)
nz = a%get_nzeros()
allocate(ila(nz))
write(0,*) me,name,' size :',nz,size(ila)
!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
!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)
!write(0,*) me,name,' Processes:',ladj(1:nnp)
icomm = desc_a%get_mpic()
Allocate(brvindx(np+1),&
& rvsz(np),sdsz(np),bsdindx(np+1), stat=info)
sdsz(:)=0
rvsz(:)=0
sdsi(:)=0
rvsi(:)=0
ipx = 1
brvindx(ipx) = 0
bsdindx(ipx) = 0
brvindx(:) = 0
bsdindx(:) = 0
counter=1
idx = 0
idxs = 0
@ -180,31 +179,54 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info)
call psb_errpush(info,name,a_err='mpi_alltoall')
goto 9999
end if
write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:)
!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
lnnz = max(iszr,iszs,lone)
lnc = a%get_ncols()
call acoo%allocate(lnr,lnc,lnnz)
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_)
@ -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_)&

8
base/tools/psb_zspalloc.f90
Unescape Escape View File

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

34
base/tools/psb_zspasb.f90
Unescape Escape View File

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

6
base/tools/psb_zspins.F90
Unescape Escape View File

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

4
test/pargen/psb_d_pde3d.F90
Unescape Escape View File

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

4
test/pargen/psb_s_pde3d.F90
Unescape Escape View File

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

Write Preview
Loading…
Cancel
Save