fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-16 19:02:09 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
New conversions for CSR/CSC
This commit is contained in:
Salvatore Filippone
2015-03-28 16:58:52 +00:00
parent d890ca7586
commit 983a79d22a
12 changed files with 184 additions and 632 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psb_c_base_mat_mod.f90
+3 -1
View File
@@ -1873,6 +1873,7 @@ contains
call a%set_nrows(izero)
call a%set_ncols(izero)
call a%set_nzeros(izero)
call a%set_sort_status(psb_unsorted_)
return
@@ -1904,8 +1905,9 @@ contains
call move_alloc(a%ia,itemp)
call move_alloc(a%ja,a%ia)
call move_alloc(itemp,a%ja)
call a%set_sorted(.false.)
call a%set_sort_status(psb_unsorted_)
return
base/modules/psb_d_base_mat_mod.f90
+3 -1
View File
@@ -1873,6 +1873,7 @@ contains
call a%set_nrows(izero)
call a%set_ncols(izero)
call a%set_nzeros(izero)
call a%set_sort_status(psb_unsorted_)
return
@@ -1904,8 +1905,9 @@ contains
call move_alloc(a%ia,itemp)
call move_alloc(a%ja,a%ia)
call move_alloc(itemp,a%ja)
call a%set_sorted(.false.)
call a%set_sort_status(psb_unsorted_)
return
base/modules/psb_s_base_mat_mod.f90
+3 -1
View File
@@ -1873,6 +1873,7 @@ contains
call a%set_nrows(izero)
call a%set_ncols(izero)
call a%set_nzeros(izero)
call a%set_sort_status(psb_unsorted_)
return
@@ -1904,8 +1905,9 @@ contains
call move_alloc(a%ia,itemp)
call move_alloc(a%ja,a%ia)
call move_alloc(itemp,a%ja)
call a%set_sorted(.false.)
call a%set_sort_status(psb_unsorted_)
return
base/modules/psb_z_base_mat_mod.f90
+3 -1
View File
@@ -1873,6 +1873,7 @@ contains
call a%set_nrows(izero)
call a%set_ncols(izero)
call a%set_nzeros(izero)
call a%set_sort_status(psb_unsorted_)
return
@@ -1904,8 +1905,9 @@ contains
call move_alloc(a%ia,itemp)
call move_alloc(a%ja,a%ia)
call move_alloc(itemp,a%ja)
call a%set_sorted(.false.)
call a%set_sort_status(psb_unsorted_)
return
base/serial/impl/psb_c_csc_impl.f90
+14 -58
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
base/serial/impl/psb_c_csr_impl.f90
+29 -99
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
@@ -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
@@ -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
base/serial/impl/psb_d_csc_impl.f90
+14 -58
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
base/serial/impl/psb_d_csr_impl.f90
+29 -99
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
@@ -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
@@ -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'
@@ -2887,55 +2852,20 @@ subroutine psb_d_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_d_mv_csr_from_coo
base/serial/impl/psb_s_csc_impl.f90
+14 -58
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
base/serial/impl/psb_s_csr_impl.f90
+29 -99
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
@@ -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
@@ -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
base/serial/impl/psb_z_csc_impl.f90
+14 -58
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
base/serial/impl/psb_z_csr_impl.f90
+29 -99
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
@@ -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
@@ -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