From 983a79d22afceafdf655a7432df7dc2330107336 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 28 Mar 2015 16:58:52 +0000 Subject: [PATCH] psblas3: New conversions for CSR/CSC --- base/modules/psb_c_base_mat_mod.f90 | 4 +- base/modules/psb_d_base_mat_mod.f90 | 4 +- base/modules/psb_s_base_mat_mod.f90 | 4 +- base/modules/psb_z_base_mat_mod.f90 | 4 +- base/serial/impl/psb_c_csc_impl.f90 | 72 +++------------- base/serial/impl/psb_c_csr_impl.f90 | 128 +++++++--------------------- base/serial/impl/psb_d_csc_impl.f90 | 72 +++------------- base/serial/impl/psb_d_csr_impl.f90 | 128 +++++++--------------------- base/serial/impl/psb_s_csc_impl.f90 | 72 +++------------- base/serial/impl/psb_s_csr_impl.f90 | 128 +++++++--------------------- base/serial/impl/psb_z_csc_impl.f90 | 72 +++------------- base/serial/impl/psb_z_csr_impl.f90 | 128 +++++++--------------------- 12 files changed, 184 insertions(+), 632 deletions(-) diff --git a/base/modules/psb_c_base_mat_mod.f90 b/base/modules/psb_c_base_mat_mod.f90 index a032db7c..90db864c 100644 --- a/base/modules/psb_c_base_mat_mod.f90 +++ b/base/modules/psb_c_base_mat_mod.f90 @@ -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 diff --git a/base/modules/psb_d_base_mat_mod.f90 b/base/modules/psb_d_base_mat_mod.f90 index ed60940f..304b02b3 100644 --- a/base/modules/psb_d_base_mat_mod.f90 +++ b/base/modules/psb_d_base_mat_mod.f90 @@ -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 diff --git a/base/modules/psb_s_base_mat_mod.f90 b/base/modules/psb_s_base_mat_mod.f90 index 640d61e2..10d4e40b 100644 --- a/base/modules/psb_s_base_mat_mod.f90 +++ b/base/modules/psb_s_base_mat_mod.f90 @@ -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 diff --git a/base/modules/psb_z_base_mat_mod.f90 b/base/modules/psb_z_base_mat_mod.f90 index 81727804..fcc375fe 100644 --- a/base/modules/psb_z_base_mat_mod.f90 +++ b/base/modules/psb_z_base_mat_mod.f90 @@ -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 diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index ddc93c5c..b5fe760d 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index a1982a62..bd142014 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index 84d5e705..2c4b7aff 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index a8635ff0..40831d54 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index ec4685fb..d53292ef 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index fadbcf84..ace8618a 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index c9acff5f..054372c9 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index bd77634e..71e1da5c 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -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