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

psblas-3.3-maint:

Browse Source 
base/serial/f77/symbmm.f
 base/serial/impl/psb_c_csc_impl.f90
 base/serial/impl/psb_c_csr_impl.f90
 base/serial/impl/psb_d_csc_impl.f90
 base/serial/impl/psb_d_csr_impl.f90
 base/serial/impl/psb_s_csc_impl.f90
 base/serial/impl/psb_s_csr_impl.f90
 base/serial/impl/psb_z_csc_impl.f90
 base/serial/impl/psb_z_csr_impl.f90
 base/serial/psb_dspspmm.f90
 base/serial/psb_dsymbmm.f90
 base/tools/psb_csphalo.F90
 base/tools/psb_dsphalo.F90
 base/tools/psb_ssphalo.F90
 base/tools/psb_zsphalo.F90

Fix reallocation bug in spspmm.
psblas-3.3-maint
Salvatore Filippone 9 years ago
parent 2ea1d0afbd
commit 66640872fa
13 changed files with 206 additions and 650 deletions
Show Stats Download Patch File Download Diff File

4
base/serial/f77/symbmm.f
Unescape Escape View File

@ -101,6 +101,10 @@ c
nze = max(ic(i+1), nint((dble(ic(i))*(dble(n)/i))) )
endif
call psb_realloc(nze,jc,info)
if (info /= 0) then
write(0,*) 'Failed realloc ',nze,info
return
end if
end if
do 40 j= ic(i),ic(i+1)-1

75
base/serial/impl/psb_c_csc_impl.f90
Unescape Escape View File

@ -2143,7 +2143,6 @@ subroutine psb_c_cp_csc_from_coo(a,b,info)
type(psb_c_coo_sparse_mat) :: tmp
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2171,7 +2170,6 @@ subroutine psb_c_cp_csc_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2214,7 +2212,6 @@ subroutine psb_c_mv_csc_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2258,8 +2255,7 @@ subroutine psb_c_mv_csc_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc, icl
integer(psb_ipk_) :: nza, nr, i,j,k,ip,irw, err_act, nc, nrl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='c_mv_csc_from_coo'
@ -2285,55 +2281,19 @@ subroutine psb_c_mv_csc_from_coo(a,b,info)
call psb_realloc(max(nr+1,nc+1),a%icp,info)
call b%free()
if (nza <= 0) then
a%icp(:) = 1
else
a%icp(1) = 1
if (nc < itemp(nza)) then
write(debug_unit,*) trim(name),': CLSHR=.false. : ',&
&nc,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
icl = itemp(j)
outer: do
inner: do
if (i >= icl) exit inner
if (i > nc) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nc,j,nza,icl
exit outer
end if
a%icp(i+1) = a%icp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= icl) then
a%icp(i+1) = j
icl = itemp(j)
i = i + 1
endif
if (i > nc) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i > nc) exit
a%icp(i+1) = j
i = i + 1
end do
endif
a%icp(:) = 0
do k=1,nza
i = itemp(k)
a%icp(i) = a%icp(i) + 1
end do
ip = 1
do i=1,nc
nrl = a%icp(i)
a%icp(i) = ip
ip = ip + nrl
end do
a%icp(nc+1) = ip
end subroutine psb_c_mv_csc_from_coo
@ -2351,7 +2311,6 @@ subroutine psb_c_mv_csc_to_fmt(a,b,info)
!locals
type(psb_c_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2391,7 +2350,6 @@ subroutine psb_c_cp_csc_to_fmt(a,b,info)
!locals
type(psb_c_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2433,7 +2391,6 @@ subroutine psb_c_mv_csc_from_fmt(a,b,info)
!locals
type(psb_c_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2474,7 +2431,6 @@ subroutine psb_c_cp_csc_from_fmt(a,b,info)
!locals
type(psb_c_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2866,7 +2822,8 @@ subroutine psb_ccscspspmm(a,b,c,info)
nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb
! Estimate number of nonzeros on output.
! Turns out this is often a large overestimate.
call c%allocate(ma,nb,min(nzc,nze,nzeb))
!call c%allocate(ma,nb,min(nzc,nze,nzeb))
call c%allocate(ma,nb,nzc)
call csc_spspmm(a,b,c,info)

135
base/serial/impl/psb_c_csr_impl.f90
Unescape Escape View File

@ -2664,7 +2664,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_) :: nza, nr, nc, i,j,k,ip,irw, err_act, ncl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='c_cp_csr_from_coo'
@ -2707,55 +2707,20 @@ subroutine psb_c_cp_csr_from_coo(a,b,info)
if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info)
endif
if (nza <= 0) then
a%irp(:) = 1
else
a%irp(1) = 1
if (nr < itemp(nza)) then
write(debug_unit,*) trim(name),': RWSHR=.false. : ',&
&nr,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
irw = itemp(j)
outer: do
inner: do
if (i >= irw) exit inner
if (i>nr) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nr,j,nza,irw
exit outer
end if
a%irp(i+1) = a%irp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= irw) then
a%irp(i+1) = j
irw = itemp(j)
i = i + 1
endif
if (i>nr) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i>nr) exit
a%irp(i+1) = j
i = i + 1
end do
endif
a%irp(:) = 0
do k=1,nza
i = itemp(k)
a%irp(i) = a%irp(i) + 1
end do
ip = 1
do i=1,nr
ncl = a%irp(i)
a%irp(i) = ip
ip = ip + ncl
end do
a%irp(nr+1) = ip
end subroutine psb_c_cp_csr_from_coo
@ -2796,7 +2761,7 @@ subroutine psb_c_cp_csr_to_coo(a,b,info)
end do
end do
call b%set_nzeros(a%get_nzeros())
call b%set_sorted()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
end subroutine psb_c_cp_csr_to_coo
@ -2816,7 +2781,7 @@ subroutine psb_c_mv_csr_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_) :: nza, nr, nc,i,j,k,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
@ -2839,7 +2804,7 @@ subroutine psb_c_mv_csr_to_coo(a,b,info)
end do
end do
call a%free()
call b%set_sorted()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
end subroutine psb_c_mv_csr_to_coo
@ -2861,7 +2826,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_) :: nza, nr, nc, i,j,k, ip,irw, err_act, ncl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='mv_from_coo'
@ -2887,55 +2852,20 @@ subroutine psb_c_mv_csr_from_coo(a,b,info)
call psb_realloc(max(nr+1,nc+1),a%irp,info)
call b%free()
if (nza <= 0) then
a%irp(:) = 1
else
a%irp(1) = 1
if (nr < itemp(nza)) then
write(debug_unit,*) trim(name),': RWSHR=.false. : ',&
&nr,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
irw = itemp(j)
outer: do
inner: do
if (i >= irw) exit inner
if (i>nr) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nr,j,nza,irw
exit outer
end if
a%irp(i+1) = a%irp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= irw) then
a%irp(i+1) = j
irw = itemp(j)
i = i + 1
endif
if (i>nr) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i>nr) exit
a%irp(i+1) = j
i = i + 1
end do
endif
a%irp(:) = 0
do k=1,nza
i = itemp(k)
a%irp(i) = a%irp(i) + 1
end do
ip = 1
do i=1,nr
ncl = a%irp(i)
a%irp(i) = ip
ip = ip + ncl
end do
a%irp(nr+1) = ip
end subroutine psb_c_mv_csr_from_coo
@ -3132,7 +3062,8 @@ subroutine psb_ccsrspspmm(a,b,c,info)
nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb
! Estimate number of nonzeros on output.
! Turns out this is often a large overestimate.
call c%allocate(ma,nb,min(nzc,nze,nzeb))
!call c%allocate(ma,nb,min(nzc,nze,nzeb))
call c%allocate(ma,nb,nzc)
call csr_spspmm(a,b,c,info)

75
base/serial/impl/psb_d_csc_impl.f90
Unescape Escape View File

@ -2143,7 +2143,6 @@ subroutine psb_d_cp_csc_from_coo(a,b,info)
type(psb_d_coo_sparse_mat) :: tmp
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2171,7 +2170,6 @@ subroutine psb_d_cp_csc_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2214,7 +2212,6 @@ subroutine psb_d_mv_csc_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2258,8 +2255,7 @@ subroutine psb_d_mv_csc_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc, icl
integer(psb_ipk_) :: nza, nr, i,j,k,ip,irw, err_act, nc, nrl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='d_mv_csc_from_coo'
@ -2285,55 +2281,19 @@ subroutine psb_d_mv_csc_from_coo(a,b,info)
call psb_realloc(max(nr+1,nc+1),a%icp,info)
call b%free()
if (nza <= 0) then
a%icp(:) = 1
else
a%icp(1) = 1
if (nc < itemp(nza)) then
write(debug_unit,*) trim(name),': CLSHR=.false. : ',&
&nc,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
icl = itemp(j)
outer: do
inner: do
if (i >= icl) exit inner
if (i > nc) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nc,j,nza,icl
exit outer
end if
a%icp(i+1) = a%icp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= icl) then
a%icp(i+1) = j
icl = itemp(j)
i = i + 1
endif
if (i > nc) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i > nc) exit
a%icp(i+1) = j
i = i + 1
end do
endif
a%icp(:) = 0
do k=1,nza
i = itemp(k)
a%icp(i) = a%icp(i) + 1
end do
ip = 1
do i=1,nc
nrl = a%icp(i)
a%icp(i) = ip
ip = ip + nrl
end do
a%icp(nc+1) = ip
end subroutine psb_d_mv_csc_from_coo
@ -2351,7 +2311,6 @@ subroutine psb_d_mv_csc_to_fmt(a,b,info)
!locals
type(psb_d_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2391,7 +2350,6 @@ subroutine psb_d_cp_csc_to_fmt(a,b,info)
!locals
type(psb_d_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2433,7 +2391,6 @@ subroutine psb_d_mv_csc_from_fmt(a,b,info)
!locals
type(psb_d_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2474,7 +2431,6 @@ subroutine psb_d_cp_csc_from_fmt(a,b,info)
!locals
type(psb_d_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2866,7 +2822,8 @@ subroutine psb_dcscspspmm(a,b,c,info)
nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb
! Estimate number of nonzeros on output.
! Turns out this is often a large overestimate.
call c%allocate(ma,nb,min(nzc,nze,nzeb))
!call c%allocate(ma,nb,min(nzc,nze,nzeb))
call c%allocate(ma,nb,nzc)
call csc_spspmm(a,b,c,info)

139
base/serial/impl/psb_d_csr_impl.f90
Unescape Escape View File

@ -2664,7 +2664,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_) :: nza, nr, nc, i,j,k,ip,irw, err_act, ncl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='d_cp_csr_from_coo'
@ -2707,55 +2707,20 @@ subroutine psb_d_cp_csr_from_coo(a,b,info)
if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info)
endif
if (nza <= 0) then
a%irp(:) = 1
else
a%irp(1) = 1
if (nr < itemp(nza)) then
write(debug_unit,*) trim(name),': RWSHR=.false. : ',&
&nr,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
irw = itemp(j)
outer: do
inner: do
if (i >= irw) exit inner
if (i>nr) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nr,j,nza,irw
exit outer
end if
a%irp(i+1) = a%irp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= irw) then
a%irp(i+1) = j
irw = itemp(j)
i = i + 1
endif
if (i>nr) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i>nr) exit
a%irp(i+1) = j
i = i + 1
end do
endif
a%irp(:) = 0
do k=1,nza
i = itemp(k)
a%irp(i) = a%irp(i) + 1
end do
ip = 1
do i=1,nr
ncl = a%irp(i)
a%irp(i) = ip
ip = ip + ncl
end do
a%irp(nr+1) = ip
end subroutine psb_d_cp_csr_from_coo
@ -2796,7 +2761,7 @@ subroutine psb_d_cp_csr_to_coo(a,b,info)
end do
end do
call b%set_nzeros(a%get_nzeros())
call b%set_sorted()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
end subroutine psb_d_cp_csr_to_coo
@ -2816,7 +2781,7 @@ subroutine psb_d_mv_csr_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_) :: nza, nr, nc,i,j,k,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
@ -2839,7 +2804,7 @@ subroutine psb_d_mv_csr_to_coo(a,b,info)
end do
end do
call a%free()
call b%set_sorted()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
end subroutine psb_d_mv_csr_to_coo
@ -2861,7 +2826,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_) :: nza, nr, nc, i,j,k, ip,irw, err_act, ncl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='mv_from_coo'
@ -2869,7 +2834,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info)
info = psb_success_
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (.not.b%is_by_rows()) call b%fix(info)
if (info /= psb_success_) return
@ -2877,7 +2842,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info)
nr = b%get_nrows()
nc = b%get_ncols()
nza = b%get_nzeros()
a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat
! Dirty trick: call move_alloc to have the new data allocated just once.
@ -2888,54 +2853,19 @@ subroutine psb_d_mv_csr_from_coo(a,b,info)
call b%free()
if (nza <= 0) then
a%irp(:) = 1
else
a%irp(1) = 1
if (nr < itemp(nza)) then
write(debug_unit,*) trim(name),': RWSHR=.false. : ',&
&nr,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
irw = itemp(j)
outer: do
inner: do
if (i >= irw) exit inner
if (i>nr) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nr,j,nza,irw
exit outer
end if
a%irp(i+1) = a%irp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= irw) then
a%irp(i+1) = j
irw = itemp(j)
i = i + 1
endif
if (i>nr) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i>nr) exit
a%irp(i+1) = j
i = i + 1
end do
endif
a%irp(:) = 0
do k=1,nza
i = itemp(k)
a%irp(i) = a%irp(i) + 1
end do
ip = 1
do i=1,nr
ncl = a%irp(i)
a%irp(i) = ip
ip = ip + ncl
end do
a%irp(nr+1) = ip
end subroutine psb_d_mv_csr_from_coo
@ -3132,7 +3062,8 @@ subroutine psb_dcsrspspmm(a,b,c,info)
nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb
! Estimate number of nonzeros on output.
! Turns out this is often a large overestimate.
call c%allocate(ma,nb,min(nzc,nze,nzeb))
!call c%allocate(ma,nb,min(nzc,nze,nzeb))
call c%allocate(ma,nb,nzc)
call csr_spspmm(a,b,c,info)

75
base/serial/impl/psb_s_csc_impl.f90
Unescape Escape View File

@ -2143,7 +2143,6 @@ subroutine psb_s_cp_csc_from_coo(a,b,info)
type(psb_s_coo_sparse_mat) :: tmp
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2171,7 +2170,6 @@ subroutine psb_s_cp_csc_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2214,7 +2212,6 @@ subroutine psb_s_mv_csc_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2258,8 +2255,7 @@ subroutine psb_s_mv_csc_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc, icl
integer(psb_ipk_) :: nza, nr, i,j,k,ip,irw, err_act, nc, nrl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='s_mv_csc_from_coo'
@ -2285,55 +2281,19 @@ subroutine psb_s_mv_csc_from_coo(a,b,info)
call psb_realloc(max(nr+1,nc+1),a%icp,info)
call b%free()
if (nza <= 0) then
a%icp(:) = 1
else
a%icp(1) = 1
if (nc < itemp(nza)) then
write(debug_unit,*) trim(name),': CLSHR=.false. : ',&
&nc,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
icl = itemp(j)
outer: do
inner: do
if (i >= icl) exit inner
if (i > nc) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nc,j,nza,icl
exit outer
end if
a%icp(i+1) = a%icp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= icl) then
a%icp(i+1) = j
icl = itemp(j)
i = i + 1
endif
if (i > nc) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i > nc) exit
a%icp(i+1) = j
i = i + 1
end do
endif
a%icp(:) = 0
do k=1,nza
i = itemp(k)
a%icp(i) = a%icp(i) + 1
end do
ip = 1
do i=1,nc
nrl = a%icp(i)
a%icp(i) = ip
ip = ip + nrl
end do
a%icp(nc+1) = ip
end subroutine psb_s_mv_csc_from_coo
@ -2351,7 +2311,6 @@ subroutine psb_s_mv_csc_to_fmt(a,b,info)
!locals
type(psb_s_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2391,7 +2350,6 @@ subroutine psb_s_cp_csc_to_fmt(a,b,info)
!locals
type(psb_s_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2433,7 +2391,6 @@ subroutine psb_s_mv_csc_from_fmt(a,b,info)
!locals
type(psb_s_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2474,7 +2431,6 @@ subroutine psb_s_cp_csc_from_fmt(a,b,info)
!locals
type(psb_s_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2866,7 +2822,8 @@ subroutine psb_scscspspmm(a,b,c,info)
nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb
! Estimate number of nonzeros on output.
! Turns out this is often a large overestimate.
call c%allocate(ma,nb,min(nzc,nze,nzeb))
!call c%allocate(ma,nb,min(nzc,nze,nzeb))
call c%allocate(ma,nb,nzc)
call csc_spspmm(a,b,c,info)

135
base/serial/impl/psb_s_csr_impl.f90
Unescape Escape View File

@ -2664,7 +2664,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_) :: nza, nr, nc, i,j,k,ip,irw, err_act, ncl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='s_cp_csr_from_coo'
@ -2707,55 +2707,20 @@ subroutine psb_s_cp_csr_from_coo(a,b,info)
if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info)
endif
if (nza <= 0) then
a%irp(:) = 1
else
a%irp(1) = 1
if (nr < itemp(nza)) then
write(debug_unit,*) trim(name),': RWSHR=.false. : ',&
&nr,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
irw = itemp(j)
outer: do
inner: do
if (i >= irw) exit inner
if (i>nr) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nr,j,nza,irw
exit outer
end if
a%irp(i+1) = a%irp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= irw) then
a%irp(i+1) = j
irw = itemp(j)
i = i + 1
endif
if (i>nr) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i>nr) exit
a%irp(i+1) = j
i = i + 1
end do
endif
a%irp(:) = 0
do k=1,nza
i = itemp(k)
a%irp(i) = a%irp(i) + 1
end do
ip = 1
do i=1,nr
ncl = a%irp(i)
a%irp(i) = ip
ip = ip + ncl
end do
a%irp(nr+1) = ip
end subroutine psb_s_cp_csr_from_coo
@ -2796,7 +2761,7 @@ subroutine psb_s_cp_csr_to_coo(a,b,info)
end do
end do
call b%set_nzeros(a%get_nzeros())
call b%set_sorted()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
end subroutine psb_s_cp_csr_to_coo
@ -2816,7 +2781,7 @@ subroutine psb_s_mv_csr_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_) :: nza, nr, nc,i,j,k,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
@ -2839,7 +2804,7 @@ subroutine psb_s_mv_csr_to_coo(a,b,info)
end do
end do
call a%free()
call b%set_sorted()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
end subroutine psb_s_mv_csr_to_coo
@ -2861,7 +2826,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_) :: nza, nr, nc, i,j,k, ip,irw, err_act, ncl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='mv_from_coo'
@ -2887,55 +2852,20 @@ subroutine psb_s_mv_csr_from_coo(a,b,info)
call psb_realloc(max(nr+1,nc+1),a%irp,info)
call b%free()
if (nza <= 0) then
a%irp(:) = 1
else
a%irp(1) = 1
if (nr < itemp(nza)) then
write(debug_unit,*) trim(name),': RWSHR=.false. : ',&
&nr,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
irw = itemp(j)
outer: do
inner: do
if (i >= irw) exit inner
if (i>nr) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nr,j,nza,irw
exit outer
end if
a%irp(i+1) = a%irp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= irw) then
a%irp(i+1) = j
irw = itemp(j)
i = i + 1
endif
if (i>nr) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i>nr) exit
a%irp(i+1) = j
i = i + 1
end do
endif
a%irp(:) = 0
do k=1,nza
i = itemp(k)
a%irp(i) = a%irp(i) + 1
end do
ip = 1
do i=1,nr
ncl = a%irp(i)
a%irp(i) = ip
ip = ip + ncl
end do
a%irp(nr+1) = ip
end subroutine psb_s_mv_csr_from_coo
@ -3132,7 +3062,8 @@ subroutine psb_scsrspspmm(a,b,c,info)
nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb
! Estimate number of nonzeros on output.
! Turns out this is often a large overestimate.
call c%allocate(ma,nb,min(nzc,nze,nzeb))
!call c%allocate(ma,nb,min(nzc,nze,nzeb))
call c%allocate(ma,nb,nzc)
call csr_spspmm(a,b,c,info)

75
base/serial/impl/psb_z_csc_impl.f90
Unescape Escape View File

@ -2143,7 +2143,6 @@ subroutine psb_z_cp_csc_from_coo(a,b,info)
type(psb_z_coo_sparse_mat) :: tmp
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2171,7 +2170,6 @@ subroutine psb_z_cp_csc_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2214,7 +2212,6 @@ subroutine psb_z_mv_csc_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2258,8 +2255,7 @@ subroutine psb_z_mv_csc_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc, icl
integer(psb_ipk_) :: nza, nr, i,j,k,ip,irw, err_act, nc, nrl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='z_mv_csc_from_coo'
@ -2285,55 +2281,19 @@ subroutine psb_z_mv_csc_from_coo(a,b,info)
call psb_realloc(max(nr+1,nc+1),a%icp,info)
call b%free()
if (nza <= 0) then
a%icp(:) = 1
else
a%icp(1) = 1
if (nc < itemp(nza)) then
write(debug_unit,*) trim(name),': CLSHR=.false. : ',&
&nc,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
icl = itemp(j)
outer: do
inner: do
if (i >= icl) exit inner
if (i > nc) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nc,j,nza,icl
exit outer
end if
a%icp(i+1) = a%icp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= icl) then
a%icp(i+1) = j
icl = itemp(j)
i = i + 1
endif
if (i > nc) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i > nc) exit
a%icp(i+1) = j
i = i + 1
end do
endif
a%icp(:) = 0
do k=1,nza
i = itemp(k)
a%icp(i) = a%icp(i) + 1
end do
ip = 1
do i=1,nc
nrl = a%icp(i)
a%icp(i) = ip
ip = ip + nrl
end do
a%icp(nc+1) = ip
end subroutine psb_z_mv_csc_from_coo
@ -2351,7 +2311,6 @@ subroutine psb_z_mv_csc_to_fmt(a,b,info)
!locals
type(psb_z_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2391,7 +2350,6 @@ subroutine psb_z_cp_csc_to_fmt(a,b,info)
!locals
type(psb_z_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2433,7 +2391,6 @@ subroutine psb_z_mv_csc_from_fmt(a,b,info)
!locals
type(psb_z_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2474,7 +2431,6 @@ subroutine psb_z_cp_csc_from_fmt(a,b,info)
!locals
type(psb_z_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
@ -2866,7 +2822,8 @@ subroutine psb_zcscspspmm(a,b,c,info)
nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb
! Estimate number of nonzeros on output.
! Turns out this is often a large overestimate.
call c%allocate(ma,nb,min(nzc,nze,nzeb))
!call c%allocate(ma,nb,min(nzc,nze,nzeb))
call c%allocate(ma,nb,nzc)
call csc_spspmm(a,b,c,info)

135
base/serial/impl/psb_z_csr_impl.f90
Unescape Escape View File

@ -2664,7 +2664,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_) :: nza, nr, nc, i,j,k,ip,irw, err_act, ncl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='z_cp_csr_from_coo'
@ -2707,55 +2707,20 @@ subroutine psb_z_cp_csr_from_coo(a,b,info)
if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info)
endif
if (nza <= 0) then
a%irp(:) = 1
else
a%irp(1) = 1
if (nr < itemp(nza)) then
write(debug_unit,*) trim(name),': RWSHR=.false. : ',&
&nr,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
irw = itemp(j)
outer: do
inner: do
if (i >= irw) exit inner
if (i>nr) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nr,j,nza,irw
exit outer
end if
a%irp(i+1) = a%irp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= irw) then
a%irp(i+1) = j
irw = itemp(j)
i = i + 1
endif
if (i>nr) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i>nr) exit
a%irp(i+1) = j
i = i + 1
end do
endif
a%irp(:) = 0
do k=1,nza
i = itemp(k)
a%irp(i) = a%irp(i) + 1
end do
ip = 1
do i=1,nr
ncl = a%irp(i)
a%irp(i) = ip
ip = ip + ncl
end do
a%irp(nr+1) = ip
end subroutine psb_z_cp_csr_from_coo
@ -2796,7 +2761,7 @@ subroutine psb_z_cp_csr_to_coo(a,b,info)
end do
end do
call b%set_nzeros(a%get_nzeros())
call b%set_sorted()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
end subroutine psb_z_cp_csr_to_coo
@ -2816,7 +2781,7 @@ subroutine psb_z_mv_csr_to_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_) :: nza, nr, nc,i,j,k,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
@ -2839,7 +2804,7 @@ subroutine psb_z_mv_csr_to_coo(a,b,info)
end do
end do
call a%free()
call b%set_sorted()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
end subroutine psb_z_mv_csr_to_coo
@ -2861,7 +2826,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:)
!locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_) :: nza, nr, nc, i,j,k, ip,irw, err_act, ncl
integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='mv_from_coo'
@ -2887,55 +2852,20 @@ subroutine psb_z_mv_csr_from_coo(a,b,info)
call psb_realloc(max(nr+1,nc+1),a%irp,info)
call b%free()
if (nza <= 0) then
a%irp(:) = 1
else
a%irp(1) = 1
if (nr < itemp(nza)) then
write(debug_unit,*) trim(name),': RWSHR=.false. : ',&
&nr,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
irw = itemp(j)
outer: do
inner: do
if (i >= irw) exit inner
if (i>nr) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nr,j,nza,irw
exit outer
end if
a%irp(i+1) = a%irp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= irw) then
a%irp(i+1) = j
irw = itemp(j)
i = i + 1
endif
if (i>nr) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i>nr) exit
a%irp(i+1) = j
i = i + 1
end do
endif
a%irp(:) = 0
do k=1,nza
i = itemp(k)
a%irp(i) = a%irp(i) + 1
end do
ip = 1
do i=1,nr
ncl = a%irp(i)
a%irp(i) = ip
ip = ip + ncl
end do
a%irp(nr+1) = ip
end subroutine psb_z_mv_csr_from_coo
@ -3132,7 +3062,8 @@ subroutine psb_zcsrspspmm(a,b,c,info)
nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb
! Estimate number of nonzeros on output.
! Turns out this is often a large overestimate.
call c%allocate(ma,nb,min(nzc,nze,nzeb))
!call c%allocate(ma,nb,min(nzc,nze,nzeb))
call c%allocate(ma,nb,nzc)
call csr_spspmm(a,b,c,info)

2
base/tools/psb_csphalo.F90
Unescape Escape View File

@ -172,7 +172,7 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
idxs = 0
idxr = 0
call acoo%allocate(izero,a%get_ncols(),info)
call acoo%allocate(izero,a%get_ncols())
call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info)

2
base/tools/psb_dsphalo.F90
Unescape Escape View File

@ -172,7 +172,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
idxs = 0
idxr = 0
call acoo%allocate(izero,a%get_ncols(),info)
call acoo%allocate(izero,a%get_ncols())
call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info)

2
base/tools/psb_ssphalo.F90
Unescape Escape View File

@ -172,7 +172,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
idxs = 0
idxr = 0
call acoo%allocate(izero,a%get_ncols(),info)
call acoo%allocate(izero,a%get_ncols())
call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info)

2
base/tools/psb_zsphalo.F90
Unescape Escape View File

@ -172,7 +172,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
idxs = 0
idxr = 0
call acoo%allocate(izero,a%get_ncols(),info)
call acoo%allocate(izero,a%get_ncols())
call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info)

Write Preview
Loading…
Cancel
Save