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

psblas3:

Browse Source 
New conversions for CSR/CSC
psblas3-accel
Salvatore Filippone 10 years ago
parent d890ca7586
commit 983a79d22a
12 changed files with 184 additions and 632 deletions
Show Stats Download Patch File Download Diff File

4
base/modules/psb_c_base_mat_mod.f90
Unescape Escape View File

@ -1873,6 +1873,7 @@ contains
call a%set_nrows(izero) call a%set_nrows(izero)
call a%set_ncols(izero) call a%set_ncols(izero)
call a%set_nzeros(izero) call a%set_nzeros(izero)
call a%set_sort_status(psb_unsorted_)
return return
@ -1904,8 +1905,9 @@ contains
call move_alloc(a%ia,itemp) call move_alloc(a%ia,itemp)
call move_alloc(a%ja,a%ia) call move_alloc(a%ja,a%ia)
call move_alloc(itemp,a%ja) call move_alloc(itemp,a%ja)
call a%set_sorted(.false.) call a%set_sorted(.false.)
call a%set_sort_status(psb_unsorted_)
return return

4
base/modules/psb_d_base_mat_mod.f90
Unescape Escape View File

@ -1873,6 +1873,7 @@ contains
call a%set_nrows(izero) call a%set_nrows(izero)
call a%set_ncols(izero) call a%set_ncols(izero)
call a%set_nzeros(izero) call a%set_nzeros(izero)
call a%set_sort_status(psb_unsorted_)
return return
@ -1904,8 +1905,9 @@ contains
call move_alloc(a%ia,itemp) call move_alloc(a%ia,itemp)
call move_alloc(a%ja,a%ia) call move_alloc(a%ja,a%ia)
call move_alloc(itemp,a%ja) call move_alloc(itemp,a%ja)
call a%set_sorted(.false.) call a%set_sorted(.false.)
call a%set_sort_status(psb_unsorted_)
return return

4
base/modules/psb_s_base_mat_mod.f90
Unescape Escape View File

@ -1873,6 +1873,7 @@ contains
call a%set_nrows(izero) call a%set_nrows(izero)
call a%set_ncols(izero) call a%set_ncols(izero)
call a%set_nzeros(izero) call a%set_nzeros(izero)
call a%set_sort_status(psb_unsorted_)
return return
@ -1904,8 +1905,9 @@ contains
call move_alloc(a%ia,itemp) call move_alloc(a%ia,itemp)
call move_alloc(a%ja,a%ia) call move_alloc(a%ja,a%ia)
call move_alloc(itemp,a%ja) call move_alloc(itemp,a%ja)
call a%set_sorted(.false.) call a%set_sorted(.false.)
call a%set_sort_status(psb_unsorted_)
return return

4
base/modules/psb_z_base_mat_mod.f90
Unescape Escape View File

@ -1873,6 +1873,7 @@ contains
call a%set_nrows(izero) call a%set_nrows(izero)
call a%set_ncols(izero) call a%set_ncols(izero)
call a%set_nzeros(izero) call a%set_nzeros(izero)
call a%set_sort_status(psb_unsorted_)
return return
@ -1904,8 +1905,9 @@ contains
call move_alloc(a%ia,itemp) call move_alloc(a%ia,itemp)
call move_alloc(a%ja,a%ia) call move_alloc(a%ja,a%ia)
call move_alloc(itemp,a%ja) call move_alloc(itemp,a%ja)
call a%set_sorted(.false.) call a%set_sorted(.false.)
call a%set_sort_status(psb_unsorted_)
return return

72
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 type(psb_c_coo_sparse_mat) :: tmp
integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ integer(psb_ipk_) :: nza, nr, i,j,k,ip,irw, err_act, nc, nrl
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc, icl
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='c_mv_csc_from_coo' 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 psb_realloc(max(nr+1,nc+1),a%icp,info)
call b%free() call b%free()
if (nza <= 0) then a%icp(:) = 0
a%icp(:) = 1 do k=1,nza
else i = itemp(k)
a%icp(1) = 1 a%icp(i) = a%icp(i) + 1
if (nc < itemp(nza)) then end do
write(debug_unit,*) trim(name),': CLSHR=.false. : ',& ip = 1
&nc,itemp(nza),' Expect trouble!' do i=1,nc
info = 12 nrl = a%icp(i)
end if a%icp(i) = ip
ip = ip + nrl
j = 1 end do
i = 1 a%icp(nc+1) = ip
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
end subroutine psb_c_mv_csc_from_coo end subroutine psb_c_mv_csc_from_coo
@ -2351,7 +2311,6 @@ subroutine psb_c_mv_csc_to_fmt(a,b,info)
!locals !locals
type(psb_c_coo_sparse_mat) :: tmp type(psb_c_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2391,7 +2350,6 @@ subroutine psb_c_cp_csc_to_fmt(a,b,info)
!locals !locals
type(psb_c_coo_sparse_mat) :: tmp type(psb_c_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2433,7 +2391,6 @@ subroutine psb_c_mv_csc_from_fmt(a,b,info)
!locals !locals
type(psb_c_coo_sparse_mat) :: tmp type(psb_c_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2474,7 +2431,6 @@ subroutine psb_c_cp_csc_from_fmt(a,b,info)
!locals !locals
type(psb_c_coo_sparse_mat) :: tmp type(psb_c_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit

128
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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='c_cp_csr_from_coo' 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) if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info)
endif 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 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name character(len=20) :: name
@ -2861,7 +2826,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='mv_from_coo' 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 psb_realloc(max(nr+1,nc+1),a%irp,info)
call b%free() 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 end subroutine psb_c_mv_csr_from_coo

72
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 type(psb_d_coo_sparse_mat) :: tmp
integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ integer(psb_ipk_) :: nza, nr, i,j,k,ip,irw, err_act, nc, nrl
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc, icl
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='d_mv_csc_from_coo' 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 psb_realloc(max(nr+1,nc+1),a%icp,info)
call b%free() call b%free()
if (nza <= 0) then a%icp(:) = 0
a%icp(:) = 1 do k=1,nza
else i = itemp(k)
a%icp(1) = 1 a%icp(i) = a%icp(i) + 1
if (nc < itemp(nza)) then end do
write(debug_unit,*) trim(name),': CLSHR=.false. : ',& ip = 1
&nc,itemp(nza),' Expect trouble!' do i=1,nc
info = 12 nrl = a%icp(i)
end if a%icp(i) = ip
ip = ip + nrl
j = 1 end do
i = 1 a%icp(nc+1) = ip
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
end subroutine psb_d_mv_csc_from_coo end subroutine psb_d_mv_csc_from_coo
@ -2351,7 +2311,6 @@ subroutine psb_d_mv_csc_to_fmt(a,b,info)
!locals !locals
type(psb_d_coo_sparse_mat) :: tmp type(psb_d_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2391,7 +2350,6 @@ subroutine psb_d_cp_csc_to_fmt(a,b,info)
!locals !locals
type(psb_d_coo_sparse_mat) :: tmp type(psb_d_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2433,7 +2391,6 @@ subroutine psb_d_mv_csc_from_fmt(a,b,info)
!locals !locals
type(psb_d_coo_sparse_mat) :: tmp type(psb_d_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2474,7 +2431,6 @@ subroutine psb_d_cp_csc_from_fmt(a,b,info)
!locals !locals
type(psb_d_coo_sparse_mat) :: tmp type(psb_d_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit

128
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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='d_cp_csr_from_coo' 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) if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info)
endif 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 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name character(len=20) :: name
@ -2861,7 +2826,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='mv_from_coo' 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 psb_realloc(max(nr+1,nc+1),a%irp,info)
call b%free() 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 end subroutine psb_d_mv_csr_from_coo

72
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 type(psb_s_coo_sparse_mat) :: tmp
integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ integer(psb_ipk_) :: nza, nr, i,j,k,ip,irw, err_act, nc, nrl
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc, icl
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='s_mv_csc_from_coo' 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 psb_realloc(max(nr+1,nc+1),a%icp,info)
call b%free() call b%free()
if (nza <= 0) then a%icp(:) = 0
a%icp(:) = 1 do k=1,nza
else i = itemp(k)
a%icp(1) = 1 a%icp(i) = a%icp(i) + 1
if (nc < itemp(nza)) then end do
write(debug_unit,*) trim(name),': CLSHR=.false. : ',& ip = 1
&nc,itemp(nza),' Expect trouble!' do i=1,nc
info = 12 nrl = a%icp(i)
end if a%icp(i) = ip
ip = ip + nrl
j = 1 end do
i = 1 a%icp(nc+1) = ip
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
end subroutine psb_s_mv_csc_from_coo end subroutine psb_s_mv_csc_from_coo
@ -2351,7 +2311,6 @@ subroutine psb_s_mv_csc_to_fmt(a,b,info)
!locals !locals
type(psb_s_coo_sparse_mat) :: tmp type(psb_s_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2391,7 +2350,6 @@ subroutine psb_s_cp_csc_to_fmt(a,b,info)
!locals !locals
type(psb_s_coo_sparse_mat) :: tmp type(psb_s_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2433,7 +2391,6 @@ subroutine psb_s_mv_csc_from_fmt(a,b,info)
!locals !locals
type(psb_s_coo_sparse_mat) :: tmp type(psb_s_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2474,7 +2431,6 @@ subroutine psb_s_cp_csc_from_fmt(a,b,info)
!locals !locals
type(psb_s_coo_sparse_mat) :: tmp type(psb_s_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit

128
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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='s_cp_csr_from_coo' 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) if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info)
endif 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 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name character(len=20) :: name
@ -2861,7 +2826,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='mv_from_coo' 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 psb_realloc(max(nr+1,nc+1),a%irp,info)
call b%free() 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 end subroutine psb_s_mv_csr_from_coo

72
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 type(psb_z_coo_sparse_mat) :: tmp
integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ integer(psb_ipk_) :: nza, nr, i,j,k,ip,irw, err_act, nc, nrl
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc, icl
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='z_mv_csc_from_coo' 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 psb_realloc(max(nr+1,nc+1),a%icp,info)
call b%free() call b%free()
if (nza <= 0) then a%icp(:) = 0
a%icp(:) = 1 do k=1,nza
else i = itemp(k)
a%icp(1) = 1 a%icp(i) = a%icp(i) + 1
if (nc < itemp(nza)) then end do
write(debug_unit,*) trim(name),': CLSHR=.false. : ',& ip = 1
&nc,itemp(nza),' Expect trouble!' do i=1,nc
info = 12 nrl = a%icp(i)
end if a%icp(i) = ip
ip = ip + nrl
j = 1 end do
i = 1 a%icp(nc+1) = ip
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
end subroutine psb_z_mv_csc_from_coo end subroutine psb_z_mv_csc_from_coo
@ -2351,7 +2311,6 @@ subroutine psb_z_mv_csc_to_fmt(a,b,info)
!locals !locals
type(psb_z_coo_sparse_mat) :: tmp type(psb_z_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2391,7 +2350,6 @@ subroutine psb_z_cp_csc_to_fmt(a,b,info)
!locals !locals
type(psb_z_coo_sparse_mat) :: tmp type(psb_z_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2433,7 +2391,6 @@ subroutine psb_z_mv_csc_from_fmt(a,b,info)
!locals !locals
type(psb_z_coo_sparse_mat) :: tmp type(psb_z_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -2474,7 +2431,6 @@ subroutine psb_z_cp_csc_from_fmt(a,b,info)
!locals !locals
type(psb_z_coo_sparse_mat) :: tmp type(psb_z_coo_sparse_mat) :: tmp
logical :: rwshr_
integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc
integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit

128
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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='z_cp_csr_from_coo' 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) if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info)
endif 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 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(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name character(len=20) :: name
@ -2861,7 +2826,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info)
integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_), allocatable :: itemp(:)
!locals !locals
logical :: rwshr_ 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_), Parameter :: maxtry=8
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='mv_from_coo' 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 psb_realloc(max(nr+1,nc+1),a%irp,info)
call b%free() 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 end subroutine psb_z_mv_csr_from_coo

Write Preview
Loading…
Cancel
Save