From 5d0ff52cb0a4ae44145c0ffed711aa1bf09ada57 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Wed, 10 Jan 2024 00:47:51 +0100 Subject: [PATCH 01/78] sparse API 1st commit --- src/stdlib_sparse.f90 | 6 + src/stdlib_sparse_conversion.fypp | 141 ++++++++++++++++ src/stdlib_sparse_kinds.fypp | 244 ++++++++++++++++++++++++++++ src/stdlib_sparse_matvec.fypp | 193 ++++++++++++++++++++++ test/linalg/test_sparse_matvec.fypp | 88 ++++++++++ 5 files changed, 672 insertions(+) create mode 100644 src/stdlib_sparse.f90 create mode 100644 src/stdlib_sparse_conversion.fypp create mode 100644 src/stdlib_sparse_kinds.fypp create mode 100644 src/stdlib_sparse_matvec.fypp create mode 100644 test/linalg/test_sparse_matvec.fypp diff --git a/src/stdlib_sparse.f90 b/src/stdlib_sparse.f90 new file mode 100644 index 000000000..c9d866151 --- /dev/null +++ b/src/stdlib_sparse.f90 @@ -0,0 +1,6 @@ +!! public API +module stdlib_sparse + use stdlib_sparse_kinds + use stdlib_sparse_matvec + use sparse_stdlib_conversion +end module stdlib_sparse \ No newline at end of file diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp new file mode 100644 index 000000000..3f3a9eb49 --- /dev/null +++ b/src/stdlib_sparse_conversion.fypp @@ -0,0 +1,141 @@ +#:include "common.fypp" +#:set KINDS_TYPES = REAL_KINDS_TYPES +!> The `stdlib_sparse_conversion` module provides sparse to sparse matrix conversion utilities. +!> +!> This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose +module sparse_stdlib_conversion + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp + use stdlib_sparse_kinds + implicit none + private + + public :: dense2coo, coo2dense, coo2csr, csr2coo + interface dense2coo + #:for k1, t1 in (KINDS_TYPES) + module procedure dense2coo_${k1}$ + #:endfor + end interface + + interface coo2dense + #:for k1, t1 in (KINDS_TYPES) + module procedure coo2dense_${k1}$ + #:endfor + end interface + + interface coo2csr + #:for k1, t1 in (KINDS_TYPES) + module procedure coo2csr_${k1}$ + #:endfor + end interface + + interface csr2coo + #:for k1, t1 in (KINDS_TYPES) + module procedure csr2coo_${k1}$ + #:endfor + end interface + +contains + + #:for k1, t1 in (KINDS_TYPES) + subroutine dense2coo_${k1}$(dense,COO) + ${t1}$, intent(in) :: dense(:,:) + type(COO_${k1}$), intent(inout) :: COO + integer :: num_rows, num_cols, nnz + integer :: i, j, idx + + num_rows = size(dense,dim=1) + num_cols = size(dense,dim=2) + nnz = count( abs(dense) > tiny(1._${k1}$) ) + + call COO%malloc(num_rows,num_cols,nnz) + + idx = 1 + do i = 1, num_rows + do j = 1, num_cols + if(abs(dense(i,j)) < tiny(1._${k1}$)) cycle + COO%index(1,idx) = i + COO%index(2,idx) = j + COO%data(idx) = dense(i,j) + idx = idx + 1 + end do + end do + COO%isOrdered = .true. + end subroutine + + #:endfor + + #:for k1, t1 in (KINDS_TYPES) + subroutine coo2dense_${k1}$(COO,dense) + type(COO_${k1}$), intent(in) :: COO + ${t1}$, allocatable, intent(inout) :: dense(:,:) + integer :: idx + + if(.not.allocated(dense)) allocate(dense(COO%nrows,COO%nrows),source=0._${k1}$) + do concurrent(idx = 1:COO%nnz) + dense( COO%index(1,idx) , COO%index(2,idx) ) = COO%data(idx) + end do + end subroutine + + #:endfor + + #:for k1, t1 in (KINDS_TYPES) + subroutine coo2csr_${k1}$(COO,CSR) + !! coo2csr: This function enables transfering data from a COO matrix to a CSR matrix + !! under the hypothesis that the COO is already ordered. + type(COO_${k1}$), intent(in) :: COO + type(CSR_${k1}$), intent(inout) :: CSR + integer :: i + + CSR%nnz = COO%nnz; CSR%nrows = COO%nrows; CSR%ncols = COO%ncols + CSR%base = COO%base; CSR%sym = COO%sym + + if( allocated(CSR%col) ) then + CSR%col(1:COO%nnz) = COO%index(2,1:COO%nnz) + CSR%rowptr(1:CSR%nrows) = 0 + CSR%data(1:CSR%nnz) = COO%data(1:COO%nnz) + else + allocate( CSR%col(CSR%nnz) , source = COO%index(2,1:COO%nnz) ) + allocate( CSR%rowptr(CSR%nrows+1) , source = 0 ) + allocate( CSR%data(CSR%nnz) , source = COO%data(1:COO%nnz) ) + end if + + CSR%rowptr(1) = 1 + do i = 1, COO%nnz + CSR%rowptr( COO%index(1,i)+1 ) = CSR%rowptr( COO%index(1,i)+1 ) + 1 + end do + do i = 1, CSR%nrows + CSR%rowptr( i+1 ) = CSR%rowptr( i+1 ) + CSR%rowptr( i ) + end do + end subroutine + + #:endfor + + #:for k1, t1 in (KINDS_TYPES) + subroutine csr2coo_${k1}$(CSR,COO) + !! csr2coo: This function enables transfering data from a CSR matrix to a COO matrix + !! under the hypothesis that the CSR is already ordered. + type(CSR_${k1}$), intent(in) :: CSR + type(COO_${k1}$), intent(inout) :: COO + integer :: i, j + + COO%nnz = CSR%nnz; COO%nrows = CSR%nrows; COO%ncols = CSR%ncols + COO%base = CSR%base; COO%sym = CSR%sym + + if( .not.allocated(COO%data) ) then + allocate( COO%data(CSR%nnz) , source = CSR%data(1:CSR%nnz) ) + else + COO%data(1:CSR%nnz) = CSR%data(1:CSR%nnz) + end if + + if( .not.allocated(COO%index) ) allocate( COO%index(2,CSR%nnz) ) + + do i = 1, CSR%nrows + do j = CSR%rowptr(i), CSR%rowptr(i+1)-1 + COO%index(1:2,j) = [i,CSR%col(j)] + end do + end do + end subroutine + + #:endfor + +end module sparse_stdlib_conversion \ No newline at end of file diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp new file mode 100644 index 000000000..238ff5993 --- /dev/null +++ b/src/stdlib_sparse_kinds.fypp @@ -0,0 +1,244 @@ +#:include "common.fypp" +#:set KINDS_TYPES = REAL_KINDS_TYPES +!> The `stdlib_sparse_kinds` module provides derived type definitions for different sparse matrices +!> +!> This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose +module stdlib_sparse_kinds + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp + implicit none + + private + + ! -- Global parameters + enum, bind(C) + enumerator :: k_NOSYMMETRY !! Full Sparse matrix (no symmetry considerations) + enumerator :: k_SYMTRIINF !! Symmetric Sparse matrix with triangular inferior storage + enumerator :: k_SYMTRISUP !! Symmetric Sparse matrix with triangular supperior storage + end enum + public :: k_NOSYMMETRY, k_SYMTRIINF, k_SYMTRISUP + ! -- Classes + type, public, abstract :: sparse_t + integer :: nrows = 0 !! number of rows + integer :: ncols = 0 !! number of columns + integer :: nnz = 0 !! number of non-zero values + integer :: sym = k_NOSYMMETRY !! assumed storage symmetry + integer :: base = 1 !! index base = 0 for (C) or 1 (Fortran) + end type + + !! COO: COOrdinates compresed format + type, public, extends(sparse_t) :: COO_t + logical :: isOrdered = .false. !! wether the matrix is ordered or not + integer, allocatable :: index(:,:) !! Matrix coordinates index(2,nnz) + contains + procedure :: malloc => malloc_coo + end type + + #:for k1, t1 in (KINDS_TYPES) + type, public, extends(COO_t) :: COO_${k1}$ + ${t1}$, allocatable :: data(:) !! single precision values + end type + #:endfor + + !! CSR: Compressed sparse row or Yale format + type, extends(sparse_t) :: CSR_t + integer, allocatable :: col(:) !! matrix column pointer + integer, allocatable :: rowptr(:) !! matrix row pointer + contains + procedure :: malloc => malloc_csr + end type + + #:for k1, t1 in (KINDS_TYPES) + type, public, extends(CSR_t) :: CSR_${k1}$ + ${t1}$, allocatable :: data(:) !! single precision values + end type + #:endfor + + !! CSC: Compressed sparse column + type, extends(sparse_t) :: CSC_t + integer, allocatable :: colptr(:) !! matrix column pointer + integer, allocatable :: row(:) !! matrix row pointer + contains + procedure :: malloc => malloc_csc + end type + + #:for k1, t1 in (KINDS_TYPES) + type, public, extends(CSC_t) :: CSC_${k1}$ + ${t1}$, allocatable :: data(:) !! single precision values + end type + #:endfor + + !! Compressed ELLPACK + type, extends(sparse_t) :: ELL_t + integer :: K = 0 !! maximum number of nonzeros per row + integer, allocatable :: index(:,:) !! column indices + contains + procedure :: malloc => malloc_ell + end type + + #:for k1, t1 in (KINDS_TYPES) + type, public, extends(ELL_t) :: ELL_${k1}$ + ${t1}$, allocatable :: data(:,:) !! single precision values + end type + #:endfor + +contains + + subroutine malloc_coo(self,num_rows,num_cols,nnz) + class(COO_t) :: self + integer, intent(in) :: num_rows + integer, intent(in) :: num_cols + integer, intent(in) :: nnz + + integer, allocatable :: temp_idx(:,:) + !----------------------------------------------------- + + self%nrows = num_rows + self%ncols = num_cols + self%nnz = nnz + + if(.not.allocated(self%index)) then + allocate(temp_idx(2,nnz) , source = 0 ) + else + allocate(temp_idx(2,nnz) , source = self%index ) + end if + call move_alloc(from=temp_idx,to=self%index) + + select type(self) + #:for k1, t1 in (KINDS_TYPES) + type is(COO_${k1}$) + block + ${t1}$, allocatable :: temp_data_${k1}$(:) + if(.not.allocated(self%data)) then + allocate(temp_data_${k1}$(nnz) , source = 0._${k1}$ ) + else + allocate(temp_data_${k1}$(nnz) , source = self%data ) + end if + call move_alloc(from=temp_data_${k1}$,to=self%data) + end block + #:endfor + end select + end subroutine + + subroutine malloc_csr(self,num_rows,num_cols,nnz) + class(CSR_t) :: self + integer, intent(in) :: num_rows + integer, intent(in) :: num_cols + integer, intent(in) :: nnz + + integer, allocatable :: temp_idx(:) + !----------------------------------------------------- + + self%nrows = num_rows + self%ncols = num_cols + self%nnz = nnz + + if(.not.allocated(self%col)) then + allocate(temp_idx(nnz) , source = 0 ) + else + allocate(temp_idx(nnz) , source = self%col ) + end if + call move_alloc(from=temp_idx,to=self%col) + + if(.not.allocated(self%rowptr)) then + allocate(temp_idx(num_rows+1) , source = 0 ) + else + allocate(temp_idx(num_rows+1) , source = self%rowptr ) + end if + call move_alloc(from=temp_idx,to=self%rowptr) + + select type(self) + #:for k1, t1 in (KINDS_TYPES) + type is(CSR_${k1}$) + block + ${t1}$, allocatable :: temp_data_${k1}$(:) + if(.not.allocated(self%data)) then + allocate(temp_data_${k1}$(nnz) , source = 0._${k1}$ ) + else + allocate(temp_data_${k1}$(nnz) , source = self%data ) + end if + call move_alloc(from=temp_data_${k1}$,to=self%data) + end block + #:endfor + end select + end subroutine + + subroutine malloc_csc(self,num_rows,num_cols,nnz) + class(CSC_t) :: self + integer, intent(in) :: num_rows + integer, intent(in) :: num_cols + integer, intent(in) :: nnz + + integer, allocatable :: temp_idx(:) + !----------------------------------------------------- + + self%nrows = num_rows + self%ncols = num_cols + self%nnz = nnz + + if(.not.allocated(self%row)) then + allocate(temp_idx(nnz) , source = 0 ) + else + allocate(temp_idx(nnz) , source = self%row ) + end if + call move_alloc(from=temp_idx,to=self%row) + + if(.not.allocated(self%colptr)) then + allocate(temp_idx(num_cols+1) , source = 0 ) + else + allocate(temp_idx(num_cols+1) , source = self%colptr ) + end if + call move_alloc(from=temp_idx,to=self%colptr) + + select type(self) + #:for k1, t1 in (KINDS_TYPES) + type is(CSC_${k1}$) + block + ${t1}$, allocatable :: temp_data_${k1}$(:) + if(.not.allocated(self%data)) then + allocate(temp_data_${k1}$(nnz) , source = 0._${k1}$ ) + else + allocate(temp_data_${k1}$(nnz) , source = self%data ) + end if + call move_alloc(from=temp_data_${k1}$,to=self%data) + end block + #:endfor + end select + end subroutine + + subroutine malloc_ell(self,num_rows,num_cols,num_nz_rows) + class(ELL_t) :: self + integer, intent(in) :: num_rows !! number of rows + integer, intent(in) :: num_cols !! number of columns + integer, intent(in) :: num_nz_rows !! number of non zeros per row + + integer, allocatable :: temp_idx(:,:) + !----------------------------------------------------- + + self%nrows = num_rows + self%ncols = num_cols + self%K = num_nz_rows + + if(.not.allocated(self%index)) then + allocate(temp_idx(num_rows,num_nz_rows) , source = 0 ) + else + allocate(temp_idx(num_rows,num_nz_rows) , source = self%index ) + end if + call move_alloc(from=temp_idx,to=self%index) + + select type(self) + #:for k1, t1 in (KINDS_TYPES) + type is(ELL_${k1}$) + block + ${t1}$, allocatable :: temp_data_${k1}$(:,:) + if(.not.allocated(self%data)) then + allocate(temp_data_${k1}$(num_rows,num_nz_rows) , source = 0._${k1}$ ) + else + allocate(temp_data_${k1}$(num_rows,num_nz_rows) , source = self%data ) + end if + call move_alloc(from=temp_data_${k1}$,to=self%data) + end block + #:endfor + end select + end subroutine + +end module stdlib_sparse_kinds \ No newline at end of file diff --git a/src/stdlib_sparse_matvec.fypp b/src/stdlib_sparse_matvec.fypp new file mode 100644 index 000000000..6f01b3d25 --- /dev/null +++ b/src/stdlib_sparse_matvec.fypp @@ -0,0 +1,193 @@ +#:include "common.fypp" +#:set RANKS = range(1, 2+1) +#:set KINDS_TYPES = REAL_KINDS_TYPES +#! define ranks without parentheses +#:def rksfx2(rank) +#{if rank > 0}#${":," + ":," * (rank - 1)}$#{endif}# +#:enddef +!> The `stdlib_sparse_matvec` module provides matrix-vector product kernels. +!> +!> This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose +module stdlib_sparse_matvec + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp + use stdlib_sparse_kinds + implicit none + private + + public :: matvec + interface matvec ! call matvec(vec_y,matrix,vec_x) => Y = M * X + #:for k1, t1 in (KINDS_TYPES) + #:for rank in RANKS + module procedure matvec_coo_${rank}$d_${k1}$ + module procedure matvec_csr_${rank}$d_${k1}$ + module procedure matvec_csc_${rank}$d_${k1}$ + module procedure matvec_ell_${rank}$d_${k1}$ + + #:endfor + #:endfor + end interface + +contains + + !! matvec_coo + #:for k1, t1 in (KINDS_TYPES) + #:for rank in RANKS + subroutine matvec_coo_${rank}$d_${k1}$(vec_y,matrix,vec_x) + type(COO_${k1}$), intent(in) :: matrix + ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ + ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + integer :: k, ik, jk + + associate( data => matrix%data, index => matrix%index, sym => matrix%sym, nnz => matrix%nnz ) + if( sym == k_NOSYMMETRY) then + do concurrent (k = 1:nnz) + ik = index(1,k) + jk = index(2,k) + vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + data(k) * vec_x(${rksfx2(rank-1)}$jk) + end do + + else + do concurrent (k = 1:nnz) + ik = index(1,k) + jk = index(2,k) + vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + data(k) * vec_x(${rksfx2(rank-1)}$jk) + if( ik==jk ) cycle + vec_y(${rksfx2(rank-1)}$jk) = vec_y(${rksfx2(rank-1)}$jk) + data(k) * vec_x(${rksfx2(rank-1)}$ik) + end do + + end if + end associate + end subroutine + + #:endfor + #:endfor + + !! matvec_csr + #:for k1, t1 in (KINDS_TYPES) + #:for rank in RANKS + subroutine matvec_csr_${rank}$d_${k1}$(vec_y,matrix,vec_x) + type(CSR_${k1}$), intent(in) :: matrix + ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ + ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + integer :: i, j + #:if rank == 1 + ${t1}$ :: aux + #:else + ${t1}$ :: aux(size(vec_x,dim=1)) + #:endif + + associate( data => matrix%data, col => matrix%col, rowptr => matrix%rowptr, & + & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) + if( sym == k_NOSYMMETRY) then + do concurrent(i=1:nrows) + do j = rowptr(i), rowptr(i+1)-1 + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + data(j) * vec_x(${rksfx2(rank-1)}$col(j)) + end do + end do + + else if( sym == k_SYMTRIINF )then + do i = 1 , nrows + aux = 0._${k1}$ + do j = rowptr(i), rowptr(i+1)-2 + aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j)) + vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * vec_x(${rksfx2(rank-1)}$i) + end do + aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$i) + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + aux + end do + + else if( sym == k_SYMTRISUP )then + do i = 1 , nrows + aux = vec_x(${rksfx2(rank-1)}$i) * data(rowptr(i)) + do j = rowptr(i)+1, rowptr(i+1)-1 + aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j)) + vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * vec_x(${rksfx2(rank-1)}$i) + end do + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + aux + end do + + end if + end associate + end subroutine + + #:endfor + #:endfor + + !! matvec_csc + #:for k1, t1 in (KINDS_TYPES) + #:for rank in RANKS + subroutine matvec_csc_${rank}$d_${k1}$(vec_y,matrix,vec_x) + type(CSC_${k1}$), intent(in) :: matrix + ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ + ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + integer :: i, j + #:if rank == 1 + ${t1}$ :: aux + #:else + ${t1}$ :: aux(size(vec_x,dim=1)) + #:endif + + associate( data => matrix%data, colptr => matrix%colptr, row => matrix%row, & + & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) + if( sym == k_NOSYMMETRY) then + do concurrent(j=1:ncols) + do i = colptr(j), colptr(j+1)-1 + vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + data(i) * vec_x(${rksfx2(rank-1)}$j) + end do + end do + + else if( sym == k_SYMTRIINF )then + ! NOT TESTED + do j = 1 , ncols + aux = vec_x(${rksfx2(rank-1)}$j) * data(colptr(j)) + do i = colptr(j)+1, colptr(j+1)-1 + aux = aux + data(i) * vec_x(${rksfx2(rank-1)}$row(i)) + vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + data(i) * vec_x(${rksfx2(rank-1)}$j) + end do + vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + aux + end do + + else if( sym == k_SYMTRISUP )then + ! NOT TESTED + do j = 1 , ncols + aux = 0._${k1}$ + do i = colptr(j), colptr(i+1)-2 + aux = aux + data(i) * vec_x(${rksfx2(rank-1)}$j) + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + data(i) * vec_x(${rksfx2(rank-1)}$row(i)) + end do + aux = aux + data(colptr(j)) * vec_x(${rksfx2(rank-1)}$j) + vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + aux + end do + + end if + end associate + end subroutine + + #:endfor + #:endfor + + !! matvec_ell + #:for k1, t1 in (KINDS_TYPES) + #:for rank in RANKS + subroutine matvec_ell_${rank}$d_${k1}$(vec_y,matrix,vec_x) + type(ELL_${k1}$), intent(in) :: matrix + ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ + ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + integer :: i, j, k + + associate( data => matrix%data, index => matrix%index, MNZ_P_ROW => matrix%K, & + & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) + if( sym == k_NOSYMMETRY) then + do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW) + j = index(i,k) + if(j>0) vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + data(i,k) * vec_x(${rksfx2(rank-1)}$j) + end do + + end if + end associate + end subroutine + + #:endfor + #:endfor + +end module stdlib_sparse_matvec \ No newline at end of file diff --git a/test/linalg/test_sparse_matvec.fypp b/test/linalg/test_sparse_matvec.fypp new file mode 100644 index 000000000..4380c7117 --- /dev/null +++ b/test/linalg/test_sparse_matvec.fypp @@ -0,0 +1,88 @@ +#:include "common.fypp" +#:set KINDS_TYPES = REAL_KINDS_TYPES +module test_sparse_matvec + use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test + use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64 + use stdlib_sparse + + implicit none + +contains + + + !> Collect all exported unit tests + subroutine collect_suite(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("coo", test_coo) & + ] + + end subroutine collect_suite + + subroutine test_coo(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for k1, t1 in (KINDS_TYPES) + block + ${t1}$, allocatable :: dense(:,:) + type(COO_${k1}$) :: COO + ${t1}$, allocatable :: vec_x(:) + ${t1}$, allocatable :: vec_y1(:), vec_y2(:) + + allocate( dense(4,5) , source = & + reshape([9._${k1}$,4._${k1}$, 0._${k1}$,4._${k1}$, & + 0._${k1}$,7._${k1}$, 8._${k1}$,0._${k1}$, & + 0._${k1}$,0._${k1}$,-1._${k1}$,5._${k1}$, & + 0._${k1}$,0._${k1}$, 8._${k1}$,6._${k1}$, & + -3._${k1}$,0._${k1}$, 0._${k1}$,0._${k1}$],[4,5]) ) + + call dense2coo(dense , COO) + + allocate( vec_x(5) , source = 1._${k1}$ ) + allocate( vec_y1(4) , source = 0._${k1}$ ) + allocate( vec_y2(4) , source = 0._${k1}$ ) + + vec_y1 = matmul( dense, vec_x ) + call matvec( vec_y2 , COO , vec_x ) + + call check(error, all(vec_y1 == [6._${k1}$,11._${k1}$,15._${k1}$,15._${k1}$]) ) + if (allocated(error)) return + + call check(error, all(vec_y1 == vec_y2) ) + if (allocated(error)) return + end block + #:endfor + + end subroutine + +end module + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_sparse_matvec, only : collect_suite + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("sparse", collect_suite) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program From c63c0dd4eb064cf45038d11b25777d308b0934de Mon Sep 17 00:00:00 2001 From: jalvesz Date: Wed, 10 Jan 2024 22:18:55 +0100 Subject: [PATCH 02/78] cmake build --- src/CMakeLists.txt | 4 ++++ test/linalg/CMakeLists.txt | 1 + 2 files changed, 5 insertions(+) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 8a6fe66cc..247f7011e 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -30,6 +30,9 @@ set(fppFiles stdlib_sorting_ord_sort.fypp stdlib_sorting_sort.fypp stdlib_sorting_sort_index.fypp + stdlib_sparse_conversion.fypp + stdlib_sparse_kinds.fypp + stdlib_sparse_matvec.fypp stdlib_specialfunctions_gamma.fypp stdlib_stats.fypp stdlib_stats_corr.fypp @@ -78,6 +81,7 @@ set(SRC stdlib_logger.f90 stdlib_sorting_radix_sort.f90 stdlib_system.F90 + stdlib_sparse.f90 stdlib_specialfunctions.f90 stdlib_specialfunctions_legendre.f90 stdlib_quadrature_gauss.f90 diff --git a/test/linalg/CMakeLists.txt b/test/linalg/CMakeLists.txt index 4a315f545..840599685 100644 --- a/test/linalg/CMakeLists.txt +++ b/test/linalg/CMakeLists.txt @@ -2,6 +2,7 @@ set( fppFiles "test_linalg.fypp" "test_linalg_matrix_property_checks.fypp" + "test_sparse_matvec.fypp" ) fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) From 72481bea0f7fbe3407fd9de4e531f21042e3532a Mon Sep 17 00:00:00 2001 From: jalvesz Date: Thu, 11 Jan 2024 22:39:06 +0100 Subject: [PATCH 03/78] add data accessors set and get --- src/stdlib_sparse_kinds.fypp | 148 ++++++++++++++++++++++++++++++++++- 1 file changed, 144 insertions(+), 4 deletions(-) diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 238ff5993..5cff393f2 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -35,7 +35,10 @@ module stdlib_sparse_kinds #:for k1, t1 in (KINDS_TYPES) type, public, extends(COO_t) :: COO_${k1}$ - ${t1}$, allocatable :: data(:) !! single precision values + ${t1}$, allocatable :: data(:) + contains + procedure :: get => get_value_coo_${k1}$ + procedure :: set => set_value_coo_${k1}$ end type #:endfor @@ -49,7 +52,10 @@ module stdlib_sparse_kinds #:for k1, t1 in (KINDS_TYPES) type, public, extends(CSR_t) :: CSR_${k1}$ - ${t1}$, allocatable :: data(:) !! single precision values + ${t1}$, allocatable :: data(:) + contains + procedure :: get => get_value_csr_${k1}$ + procedure :: set => set_value_csr_${k1}$ end type #:endfor @@ -63,7 +69,10 @@ module stdlib_sparse_kinds #:for k1, t1 in (KINDS_TYPES) type, public, extends(CSC_t) :: CSC_${k1}$ - ${t1}$, allocatable :: data(:) !! single precision values + ${t1}$, allocatable :: data(:) + contains + procedure :: get => get_value_csc_${k1}$ + procedure :: set => set_value_csc_${k1}$ end type #:endfor @@ -77,7 +86,10 @@ module stdlib_sparse_kinds #:for k1, t1 in (KINDS_TYPES) type, public, extends(ELL_t) :: ELL_${k1}$ - ${t1}$, allocatable :: data(:,:) !! single precision values + ${t1}$, allocatable :: data(:,:) + contains + procedure :: get => get_value_ell_${k1}$ + procedure :: set => set_value_ell_${k1}$ end type #:endfor @@ -240,5 +252,133 @@ contains #:endfor end select end subroutine + + !================================================================== + ! data accessors + !================================================================== + + #:for k1, t1 in (KINDS_TYPES) + pure ${t1}$ function get_value_coo_${k1}$(self,ik,jk) result(y) + class(COO_${k1}$), intent(in) :: self + integer, intent(in) :: ik, jk + integer :: k + ! naive implementation + do k = 1,self%nnz + if( ik == self%index(1,k) .and. jk == self%index(2,k) ) then + y = self%data(k) + return + end if + end do + y = 0._${k1}$ + end function + + subroutine set_value_coo_${k1}$(self,ik,jk,val) + class(COO_${k1}$), intent(inout) :: self + integer, intent(in) :: ik, jk + ${t1}$, intent(in) :: val + integer :: k + ! naive implementation + do k = 1,self%nnz + if( ik == self%index(1,k) .and. jk == self%index(2,k) ) then + self%data(k) = val + return + end if + end do + end subroutine + + #:endfor + + #:for k1, t1 in (KINDS_TYPES) + pure ${t1}$ function get_value_csr_${k1}$(self,ik,jk) result(y) + class(CSR_${k1}$), intent(in) :: self + integer, intent(in) :: ik, jk + integer :: k + ! naive implementation + do k = self%rowptr(ik), self%rowptr(ik+1)-1 + if( jk == self%col(k) ) then + y = self%data(k) + return + end if + end do + y = 0._${k1}$ + end function + + subroutine set_value_csr_${k1}$(self,ik,jk,val) + class(CSR_${k1}$), intent(inout) :: self + integer, intent(in) :: ik, jk + ${t1}$, intent(in) :: val + integer :: k + ! naive implementation + do k = self%rowptr(ik), self%rowptr(ik+1)-1 + if( jk == self%col(k) ) then + self%data(k) = val + return + end if + end do + end subroutine + + #:endfor + + #:for k1, t1 in (KINDS_TYPES) + pure ${t1}$ function get_value_csc_${k1}$(self,ik,jk) result(y) + class(CSC_${k1}$), intent(in) :: self + integer, intent(in) :: ik, jk + integer :: k + ! naive implementation + do k = self%colptr(jk), self%colptr(jk+1)-1 + if( ik == self%row(k) ) then + y = self%data(k) + return + end if + end do + y = 0._${k1}$ + end function + + subroutine set_value_csc_${k1}$(self,ik,jk,val) + class(CSC_${k1}$), intent(inout) :: self + integer, intent(in) :: ik, jk + ${t1}$, intent(in) :: val + integer :: k + ! naive implementation + do k = self%colptr(jk), self%colptr(jk+1)-1 + if( ik == self%row(k) ) then + self%data(k) = val + return + end if + end do + end subroutine + + #:endfor + + #:for k1, t1 in (KINDS_TYPES) + pure ${t1}$ function get_value_ell_${k1}$(self,ik,jk) result(y) + class(ELL_${k1}$), intent(in) :: self + integer, intent(in) :: ik, jk + integer :: k + ! naive implementation + do k = 1 , self%K + if( jk == self%index(ik,k) ) then + y = self%data(ik,k) + return + end if + end do + y = 0._${k1}$ + end function + + subroutine set_value_ell_${k1}$(self,ik,jk,val) + class(ELL_${k1}$), intent(inout) :: self + integer, intent(in) :: ik, jk + ${t1}$, intent(in) :: val + integer :: k + ! naive implementation + do k = 1 , self%K + if( jk == self%index(ik,k) ) then + self%data(ik,k) = val + return + end if + end do + end subroutine + + #:endfor end module stdlib_sparse_kinds \ No newline at end of file From a7cb6be2d1d1c29ca97191416090ea6b40cfe17e Mon Sep 17 00:00:00 2001 From: jalvesz Date: Thu, 11 Jan 2024 22:49:52 +0100 Subject: [PATCH 04/78] fix typo --- src/stdlib_sparse_conversion.fypp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 3f3a9eb49..9f4903f24 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -80,7 +80,7 @@ contains #:for k1, t1 in (KINDS_TYPES) subroutine coo2csr_${k1}$(COO,CSR) - !! coo2csr: This function enables transfering data from a COO matrix to a CSR matrix + !! coo2csr: This function enables transferring data from a COO matrix to a CSR matrix !! under the hypothesis that the COO is already ordered. type(COO_${k1}$), intent(in) :: COO type(CSR_${k1}$), intent(inout) :: CSR @@ -112,7 +112,7 @@ contains #:for k1, t1 in (KINDS_TYPES) subroutine csr2coo_${k1}$(CSR,COO) - !! csr2coo: This function enables transfering data from a CSR matrix to a COO matrix + !! csr2coo: This function enables transferring data from a CSR matrix to a COO matrix !! under the hypothesis that the CSR is already ordered. type(CSR_${k1}$), intent(in) :: CSR type(COO_${k1}$), intent(inout) :: COO From d48dde58a0b2ff6e1acb622a4fc08d4f34239438 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Fri, 12 Jan 2024 20:30:41 +0100 Subject: [PATCH 05/78] change ij accessor as subroutine --- src/stdlib_sparse_kinds.fypp | 52 ++++++++++++++++------------- test/linalg/test_sparse_matvec.fypp | 15 ++++++++- 2 files changed, 42 insertions(+), 25 deletions(-) diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 5cff393f2..5ec964de8 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -258,24 +258,25 @@ contains !================================================================== #:for k1, t1 in (KINDS_TYPES) - pure ${t1}$ function get_value_coo_${k1}$(self,ik,jk) result(y) + pure subroutine get_value_coo_${k1}$(self,val,ik,jk) class(COO_${k1}$), intent(in) :: self + ${t1}$, intent(out) :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation do k = 1,self%nnz if( ik == self%index(1,k) .and. jk == self%index(2,k) ) then - y = self%data(k) + val = self%data(k) return end if end do - y = 0._${k1}$ - end function + val = 0._${k1}$ + end subroutine - subroutine set_value_coo_${k1}$(self,ik,jk,val) + subroutine set_value_coo_${k1}$(self,val,ik,jk) class(COO_${k1}$), intent(inout) :: self - integer, intent(in) :: ik, jk ${t1}$, intent(in) :: val + integer, intent(in) :: ik, jk integer :: k ! naive implementation do k = 1,self%nnz @@ -289,24 +290,25 @@ contains #:endfor #:for k1, t1 in (KINDS_TYPES) - pure ${t1}$ function get_value_csr_${k1}$(self,ik,jk) result(y) + pure subroutine get_value_csr_${k1}$(self,val,ik,jk) class(CSR_${k1}$), intent(in) :: self + ${t1}$, intent(out) :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation do k = self%rowptr(ik), self%rowptr(ik+1)-1 if( jk == self%col(k) ) then - y = self%data(k) + val = self%data(k) return end if end do - y = 0._${k1}$ - end function + val = 0._${k1}$ + end subroutine - subroutine set_value_csr_${k1}$(self,ik,jk,val) + subroutine set_value_csr_${k1}$(self,val,ik,jk) class(CSR_${k1}$), intent(inout) :: self - integer, intent(in) :: ik, jk ${t1}$, intent(in) :: val + integer, intent(in) :: ik, jk integer :: k ! naive implementation do k = self%rowptr(ik), self%rowptr(ik+1)-1 @@ -320,24 +322,25 @@ contains #:endfor #:for k1, t1 in (KINDS_TYPES) - pure ${t1}$ function get_value_csc_${k1}$(self,ik,jk) result(y) + pure subroutine get_value_csc_${k1}$(self,val,ik,jk) class(CSC_${k1}$), intent(in) :: self + ${t1}$, intent(out) :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation do k = self%colptr(jk), self%colptr(jk+1)-1 if( ik == self%row(k) ) then - y = self%data(k) + val = self%data(k) return end if end do - y = 0._${k1}$ - end function + val = 0._${k1}$ + end subroutine - subroutine set_value_csc_${k1}$(self,ik,jk,val) + subroutine set_value_csc_${k1}$(self,val,ik,jk) class(CSC_${k1}$), intent(inout) :: self - integer, intent(in) :: ik, jk ${t1}$, intent(in) :: val + integer, intent(in) :: ik, jk integer :: k ! naive implementation do k = self%colptr(jk), self%colptr(jk+1)-1 @@ -351,24 +354,25 @@ contains #:endfor #:for k1, t1 in (KINDS_TYPES) - pure ${t1}$ function get_value_ell_${k1}$(self,ik,jk) result(y) + pure subroutine get_value_ell_${k1}$(self,val,ik,jk) class(ELL_${k1}$), intent(in) :: self + ${t1}$, intent(out) :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation do k = 1 , self%K if( jk == self%index(ik,k) ) then - y = self%data(ik,k) + val = self%data(ik,k) return end if end do - y = 0._${k1}$ - end function + val = 0._${k1}$ + end subroutine - subroutine set_value_ell_${k1}$(self,ik,jk,val) + subroutine set_value_ell_${k1}$(self,val,ik,jk) class(ELL_${k1}$), intent(inout) :: self - integer, intent(in) :: ik, jk ${t1}$, intent(in) :: val + integer, intent(in) :: ik, jk integer :: k ! naive implementation do k = 1 , self%K diff --git a/test/linalg/test_sparse_matvec.fypp b/test/linalg/test_sparse_matvec.fypp index 4380c7117..a3678dbb7 100644 --- a/test/linalg/test_sparse_matvec.fypp +++ b/test/linalg/test_sparse_matvec.fypp @@ -31,6 +31,7 @@ contains type(COO_${k1}$) :: COO ${t1}$, allocatable :: vec_x(:) ${t1}$, allocatable :: vec_y1(:), vec_y2(:) + ${t1}$ :: val, err allocate( dense(4,5) , source = & reshape([9._${k1}$,4._${k1}$, 0._${k1}$,4._${k1}$, & @@ -41,6 +42,18 @@ contains call dense2coo(dense , COO) + !> Test assigned values + err = 0._${k1}$ + do j = 1, size(dense,dim=2) + do i = 1, size(dense,dim=1) + call COO%get(val,i,j) + err = err + abs( val - dense(i,j) ) + end do + end do + call check(error, err <= epsilon(0._${k1}$) ) + if (allocated(error)) return + + !> Test matvec allocate( vec_x(5) , source = 1._${k1}$ ) allocate( vec_y1(4) , source = 0._${k1}$ ) allocate( vec_y2(4) , source = 0._${k1}$ ) @@ -50,7 +63,7 @@ contains call check(error, all(vec_y1 == [6._${k1}$,11._${k1}$,15._${k1}$,15._${k1}$]) ) if (allocated(error)) return - + call check(error, all(vec_y1 == vec_y2) ) if (allocated(error)) return end block From 6241ca310f5b0bd319a66ef98600bad17830f80b Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Mon, 29 Jan 2024 10:24:23 +0100 Subject: [PATCH 06/78] fix missing i,j integer declaration --- test/linalg/test_sparse_matvec.fypp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/linalg/test_sparse_matvec.fypp b/test/linalg/test_sparse_matvec.fypp index a3678dbb7..fc4c6a685 100644 --- a/test/linalg/test_sparse_matvec.fypp +++ b/test/linalg/test_sparse_matvec.fypp @@ -32,7 +32,8 @@ contains ${t1}$, allocatable :: vec_x(:) ${t1}$, allocatable :: vec_y1(:), vec_y2(:) ${t1}$ :: val, err - + integer :: i, j + allocate( dense(4,5) , source = & reshape([9._${k1}$,4._${k1}$, 0._${k1}$,4._${k1}$, & 0._${k1}$,7._${k1}$, 8._${k1}$,0._${k1}$, & From 2c2431db40f59b584c341aea188a52ce6adbbb2a Mon Sep 17 00:00:00 2001 From: jalvesz Date: Fri, 3 May 2024 19:14:16 +0200 Subject: [PATCH 07/78] add comments and change _t for _type --- include/common.fypp | 3 + src/stdlib_sparse_conversion.fypp | 21 +++++-- src/stdlib_sparse_kinds.fypp | 96 ++++++++++++++++--------------- src/stdlib_sparse_matvec.fypp | 8 +-- 4 files changed, 75 insertions(+), 53 deletions(-) diff --git a/include/common.fypp b/include/common.fypp index 1683239e4..f120fc936 100644 --- a/include/common.fypp +++ b/include/common.fypp @@ -84,6 +84,9 @@ #! Bitset types to be considered during templating #:set BITSET_TYPES = ["type({})".format(k) for k in BITSET_KINDS] +#! Sparse types to be considered during templating +#:set SPARSE_KINDS = ["COO", "CSR", "CSC", "ELL"] + #! Whether Fortran 90 compatible code should be generated #:set VERSION90 = defined('VERSION90') diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 9f4903f24..bba51a233 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -10,24 +10,41 @@ module sparse_stdlib_conversion private public :: dense2coo, coo2dense, coo2csr, csr2coo + + !> Conversion from dense to coo + !> + !> Enables extracting the non-zero elements of a dense 2D matrix and + !> storing those values in a COO format. The coo matrix is (re)allocated on the fly. interface dense2coo #:for k1, t1 in (KINDS_TYPES) module procedure dense2coo_${k1}$ #:endfor end interface + !> Conversion from coo to dense + !> + !> Enables creating a dense 2D matrix from the non-zero values tored in a COO format + !> The dense matrix can be allocated on the fly if not pre-allocated by the user. interface coo2dense #:for k1, t1 in (KINDS_TYPES) module procedure coo2dense_${k1}$ #:endfor end interface + !> Conversion from coo to csr + !> + !> Enables transferring data from a COO matrix to a CSR matrix + !> under the hypothesis that the COO is already ordered. interface coo2csr #:for k1, t1 in (KINDS_TYPES) module procedure coo2csr_${k1}$ #:endfor end interface + !> Conversion from csr to coo + !> + !> Enables transferring data from a CSR matrix to a COO matrix + !> under the hypothesis that the CSR is already ordered. interface csr2coo #:for k1, t1 in (KINDS_TYPES) module procedure csr2coo_${k1}$ @@ -80,8 +97,6 @@ contains #:for k1, t1 in (KINDS_TYPES) subroutine coo2csr_${k1}$(COO,CSR) - !! coo2csr: This function enables transferring data from a COO matrix to a CSR matrix - !! under the hypothesis that the COO is already ordered. type(COO_${k1}$), intent(in) :: COO type(CSR_${k1}$), intent(inout) :: CSR integer :: i @@ -112,8 +127,6 @@ contains #:for k1, t1 in (KINDS_TYPES) subroutine csr2coo_${k1}$(CSR,COO) - !! csr2coo: This function enables transferring data from a CSR matrix to a COO matrix - !! under the hypothesis that the CSR is already ordered. type(CSR_${k1}$), intent(in) :: CSR type(COO_${k1}$), intent(inout) :: COO integer :: i, j diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 5ec964de8..c19e1b044 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -11,30 +11,32 @@ module stdlib_sparse_kinds ! -- Global parameters enum, bind(C) - enumerator :: k_NOSYMMETRY !! Full Sparse matrix (no symmetry considerations) - enumerator :: k_SYMTRIINF !! Symmetric Sparse matrix with triangular inferior storage - enumerator :: k_SYMTRISUP !! Symmetric Sparse matrix with triangular supperior storage + enumerator :: k_NOSYMMETRY !> Full Sparse matrix (no symmetry considerations) + enumerator :: k_SYMTRIINF !> Symmetric Sparse matrix with triangular inferior storage + enumerator :: k_SYMTRISUP !> Symmetric Sparse matrix with triangular supperior storage end enum public :: k_NOSYMMETRY, k_SYMTRIINF, k_SYMTRISUP ! -- Classes - type, public, abstract :: sparse_t - integer :: nrows = 0 !! number of rows - integer :: ncols = 0 !! number of columns - integer :: nnz = 0 !! number of non-zero values - integer :: sym = k_NOSYMMETRY !! assumed storage symmetry - integer :: base = 1 !! index base = 0 for (C) or 1 (Fortran) + + !> Base sparse type holding the meta data related to the storage capacity of a matrix. + type, public, abstract :: sparse_type + integer :: nrows = 0 !> number of rows + integer :: ncols = 0 !> number of columns + integer :: nnz = 0 !> number of non-zero values + integer :: sym = k_NOSYMMETRY !> assumed storage symmetry + integer :: base = 1 !> index base = 0 for (C) or 1 (Fortran) end type - !! COO: COOrdinates compresed format - type, public, extends(sparse_t) :: COO_t - logical :: isOrdered = .false. !! wether the matrix is ordered or not - integer, allocatable :: index(:,:) !! Matrix coordinates index(2,nnz) + !> COO: COOrdinates compresed format + type, public, extends(sparse_type) :: COO_type + logical :: isOrdered = .false. !> wether the matrix is ordered or not + integer, allocatable :: index(:,:) !> Matrix coordinates index(2,nnz) contains procedure :: malloc => malloc_coo end type #:for k1, t1 in (KINDS_TYPES) - type, public, extends(COO_t) :: COO_${k1}$ + type, public, extends(COO_type) :: COO_${k1}$ ${t1}$, allocatable :: data(:) contains procedure :: get => get_value_coo_${k1}$ @@ -42,16 +44,16 @@ module stdlib_sparse_kinds end type #:endfor - !! CSR: Compressed sparse row or Yale format - type, extends(sparse_t) :: CSR_t - integer, allocatable :: col(:) !! matrix column pointer - integer, allocatable :: rowptr(:) !! matrix row pointer + !> CSR: Compressed sparse row or Yale format + type, extends(sparse_type) :: CSR_type + integer, allocatable :: col(:) !> matrix column pointer + integer, allocatable :: rowptr(:) !> matrix row pointer contains procedure :: malloc => malloc_csr end type #:for k1, t1 in (KINDS_TYPES) - type, public, extends(CSR_t) :: CSR_${k1}$ + type, public, extends(CSR_type) :: CSR_${k1}$ ${t1}$, allocatable :: data(:) contains procedure :: get => get_value_csr_${k1}$ @@ -59,16 +61,16 @@ module stdlib_sparse_kinds end type #:endfor - !! CSC: Compressed sparse column - type, extends(sparse_t) :: CSC_t - integer, allocatable :: colptr(:) !! matrix column pointer - integer, allocatable :: row(:) !! matrix row pointer + !> CSC: Compressed sparse column + type, extends(sparse_type) :: CSC_type + integer, allocatable :: colptr(:) !> matrix column pointer + integer, allocatable :: row(:) !> matrix row pointer contains procedure :: malloc => malloc_csc end type #:for k1, t1 in (KINDS_TYPES) - type, public, extends(CSC_t) :: CSC_${k1}$ + type, public, extends(CSC_type) :: CSC_${k1}$ ${t1}$, allocatable :: data(:) contains procedure :: get => get_value_csc_${k1}$ @@ -76,16 +78,16 @@ module stdlib_sparse_kinds end type #:endfor - !! Compressed ELLPACK - type, extends(sparse_t) :: ELL_t - integer :: K = 0 !! maximum number of nonzeros per row - integer, allocatable :: index(:,:) !! column indices + !> Compressed ELLPACK + type, extends(sparse_type) :: ELL_type + integer :: K = 0 !> maximum number of nonzeros per row + integer, allocatable :: index(:,:) !> column indices contains procedure :: malloc => malloc_ell end type #:for k1, t1 in (KINDS_TYPES) - type, public, extends(ELL_t) :: ELL_${k1}$ + type, public, extends(ELL_type) :: ELL_${k1}$ ${t1}$, allocatable :: data(:,:) contains procedure :: get => get_value_ell_${k1}$ @@ -95,11 +97,12 @@ module stdlib_sparse_kinds contains + !> (re)Allocate matrix memory for the COO type subroutine malloc_coo(self,num_rows,num_cols,nnz) - class(COO_t) :: self - integer, intent(in) :: num_rows - integer, intent(in) :: num_cols - integer, intent(in) :: nnz + class(COO_type) :: self + integer, intent(in) :: num_rows !> number of rows + integer, intent(in) :: num_cols !> number of columns + integer, intent(in) :: nnz !> number of non zeros integer, allocatable :: temp_idx(:,:) !----------------------------------------------------- @@ -131,11 +134,12 @@ contains end select end subroutine + !> (re)Allocate matrix memory for the CSR type subroutine malloc_csr(self,num_rows,num_cols,nnz) - class(CSR_t) :: self - integer, intent(in) :: num_rows - integer, intent(in) :: num_cols - integer, intent(in) :: nnz + class(CSR_type) :: self + integer, intent(in) :: num_rows !> number of rows + integer, intent(in) :: num_cols !> number of columns + integer, intent(in) :: nnz !> number of non zeros integer, allocatable :: temp_idx(:) !----------------------------------------------------- @@ -174,11 +178,12 @@ contains end select end subroutine + !> (re)Allocate matrix memory for the CSC type subroutine malloc_csc(self,num_rows,num_cols,nnz) - class(CSC_t) :: self - integer, intent(in) :: num_rows - integer, intent(in) :: num_cols - integer, intent(in) :: nnz + class(CSC_type) :: self + integer, intent(in) :: num_rows !> number of rows + integer, intent(in) :: num_cols !> number of columns + integer, intent(in) :: nnz !> number of non zeros integer, allocatable :: temp_idx(:) !----------------------------------------------------- @@ -217,11 +222,12 @@ contains end select end subroutine + !> (re)Allocate matrix memory for the ELLPACK type subroutine malloc_ell(self,num_rows,num_cols,num_nz_rows) - class(ELL_t) :: self - integer, intent(in) :: num_rows !! number of rows - integer, intent(in) :: num_cols !! number of columns - integer, intent(in) :: num_nz_rows !! number of non zeros per row + class(ELL_type) :: self + integer, intent(in) :: num_rows !> number of rows + integer, intent(in) :: num_cols !> number of columns + integer, intent(in) :: num_nz_rows !> number of non zeros per row integer, allocatable :: temp_idx(:,:) !----------------------------------------------------- diff --git a/src/stdlib_sparse_matvec.fypp b/src/stdlib_sparse_matvec.fypp index 6f01b3d25..57c05d0ca 100644 --- a/src/stdlib_sparse_matvec.fypp +++ b/src/stdlib_sparse_matvec.fypp @@ -29,7 +29,7 @@ module stdlib_sparse_matvec contains - !! matvec_coo + !> matvec_coo #:for k1, t1 in (KINDS_TYPES) #:for rank in RANKS subroutine matvec_coo_${rank}$d_${k1}$(vec_y,matrix,vec_x) @@ -62,7 +62,7 @@ contains #:endfor #:endfor - !! matvec_csr + !> matvec_csr #:for k1, t1 in (KINDS_TYPES) #:for rank in RANKS subroutine matvec_csr_${rank}$d_${k1}$(vec_y,matrix,vec_x) @@ -113,7 +113,7 @@ contains #:endfor #:endfor - !! matvec_csc + !> matvec_csc #:for k1, t1 in (KINDS_TYPES) #:for rank in RANKS subroutine matvec_csc_${rank}$d_${k1}$(vec_y,matrix,vec_x) @@ -166,7 +166,7 @@ contains #:endfor #:endfor - !! matvec_ell + !> matvec_ell #:for k1, t1 in (KINDS_TYPES) #:for rank in RANKS subroutine matvec_ell_${rank}$d_${k1}$(vec_y,matrix,vec_x) From d64a0454d67b31959315956caf50b14b5886a2f4 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Fri, 3 May 2024 19:18:24 +0200 Subject: [PATCH 08/78] revert matvec convention to (matrix,x,y) --- src/stdlib_sparse_matvec.fypp | 10 +++++----- test/linalg/test_sparse_matvec.fypp | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/stdlib_sparse_matvec.fypp b/src/stdlib_sparse_matvec.fypp index 57c05d0ca..d097750b4 100644 --- a/src/stdlib_sparse_matvec.fypp +++ b/src/stdlib_sparse_matvec.fypp @@ -15,7 +15,7 @@ module stdlib_sparse_matvec private public :: matvec - interface matvec ! call matvec(vec_y,matrix,vec_x) => Y = M * X + interface matvec ! call matvec(matrix,vec_x,vec_y) => Y = M * X #:for k1, t1 in (KINDS_TYPES) #:for rank in RANKS module procedure matvec_coo_${rank}$d_${k1}$ @@ -32,7 +32,7 @@ contains !> matvec_coo #:for k1, t1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_coo_${rank}$d_${k1}$(vec_y,matrix,vec_x) + subroutine matvec_coo_${rank}$d_${k1}$(matrix,vec_x,vec_y) type(COO_${k1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -65,7 +65,7 @@ contains !> matvec_csr #:for k1, t1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_csr_${rank}$d_${k1}$(vec_y,matrix,vec_x) + subroutine matvec_csr_${rank}$d_${k1}$(matrix,vec_x,vec_y) type(CSR_${k1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -116,7 +116,7 @@ contains !> matvec_csc #:for k1, t1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_csc_${rank}$d_${k1}$(vec_y,matrix,vec_x) + subroutine matvec_csc_${rank}$d_${k1}$(matrix,vec_x,vec_y) type(CSC_${k1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -169,7 +169,7 @@ contains !> matvec_ell #:for k1, t1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_ell_${rank}$d_${k1}$(vec_y,matrix,vec_x) + subroutine matvec_ell_${rank}$d_${k1}$(matrix,vec_x,vec_y) type(ELL_${k1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ diff --git a/test/linalg/test_sparse_matvec.fypp b/test/linalg/test_sparse_matvec.fypp index fc4c6a685..9a456a81d 100644 --- a/test/linalg/test_sparse_matvec.fypp +++ b/test/linalg/test_sparse_matvec.fypp @@ -60,7 +60,7 @@ contains allocate( vec_y2(4) , source = 0._${k1}$ ) vec_y1 = matmul( dense, vec_x ) - call matvec( vec_y2 , COO , vec_x ) + call matvec( COO , vec_x, vec_y2 ) call check(error, all(vec_y1 == [6._${k1}$,11._${k1}$,15._${k1}$,15._${k1}$]) ) if (allocated(error)) return From d165b8b87f0443e10b525438c52701c23bc18dc2 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 18 May 2024 19:50:50 +0200 Subject: [PATCH 09/78] upgrade sparse support with SELLC format and more tests add suffix for function naming --- include/common.fypp | 2 + src/stdlib_sparse_conversion.fypp | 127 +++++++++++++--- src/stdlib_sparse_kinds.fypp | 154 ++++++++++--------- src/stdlib_sparse_matvec.fypp | 117 ++++++++++++--- test/linalg/test_sparse_matvec.fypp | 219 +++++++++++++++++++++++----- 5 files changed, 474 insertions(+), 145 deletions(-) diff --git a/include/common.fypp b/include/common.fypp index 4339fde73..c818d0221 100644 --- a/include/common.fypp +++ b/include/common.fypp @@ -38,6 +38,7 @@ #! Real types to be considered during templating #:set REAL_TYPES = ["real({})".format(k) for k in REAL_KINDS] +#:set REAL_SUFFIX = REAL_KINDS #! Collected (kind, type) tuples for real types #:set REAL_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_INIT)) @@ -62,6 +63,7 @@ #! Complex types to be considered during templating #:set CMPLX_TYPES = ["complex({})".format(k) for k in CMPLX_KINDS] +#:set CMPLX_SUFFIX = ["c{}".format(k) for k in CMPLX_KINDS] #! Collected (kind, type, initial) tuples for complex types #:set CMPLX_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_INIT)) diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index bba51a233..15552a923 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -1,5 +1,7 @@ #:include "common.fypp" -#:set KINDS_TYPES = REAL_KINDS_TYPES +#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX)) +#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX)) +#:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES !> The `stdlib_sparse_conversion` module provides sparse to sparse matrix conversion utilities. !> !> This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose @@ -10,14 +12,15 @@ module sparse_stdlib_conversion private public :: dense2coo, coo2dense, coo2csr, csr2coo + public :: csr2sellc !> Conversion from dense to coo !> !> Enables extracting the non-zero elements of a dense 2D matrix and !> storing those values in a COO format. The coo matrix is (re)allocated on the fly. interface dense2coo - #:for k1, t1 in (KINDS_TYPES) - module procedure dense2coo_${k1}$ + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure dense2coo_${s1}$ #:endfor end interface @@ -26,8 +29,8 @@ module sparse_stdlib_conversion !> Enables creating a dense 2D matrix from the non-zero values tored in a COO format !> The dense matrix can be allocated on the fly if not pre-allocated by the user. interface coo2dense - #:for k1, t1 in (KINDS_TYPES) - module procedure coo2dense_${k1}$ + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure coo2dense_${s1}$ #:endfor end interface @@ -36,8 +39,8 @@ module sparse_stdlib_conversion !> Enables transferring data from a COO matrix to a CSR matrix !> under the hypothesis that the COO is already ordered. interface coo2csr - #:for k1, t1 in (KINDS_TYPES) - module procedure coo2csr_${k1}$ + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure coo2csr_${s1}$ #:endfor end interface @@ -46,17 +49,27 @@ module sparse_stdlib_conversion !> Enables transferring data from a CSR matrix to a COO matrix !> under the hypothesis that the CSR is already ordered. interface csr2coo - #:for k1, t1 in (KINDS_TYPES) - module procedure csr2coo_${k1}$ + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure csr2coo_${s1}$ #:endfor end interface + !> Conversion from csr to SELL-C + !> + !> Enables transferring data from a CSR matrix to a SELL-C matrix + !> It takes an optional parameter to decide the chunck size 4, 8 or 16 + interface csr2sellc + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure csr2sellc_${s1}$ + #:endfor + end interface + contains - #:for k1, t1 in (KINDS_TYPES) - subroutine dense2coo_${k1}$(dense,COO) + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine dense2coo_${s1}$(dense,COO) ${t1}$, intent(in) :: dense(:,:) - type(COO_${k1}$), intent(inout) :: COO + type(COO_${s1}$), intent(inout) :: COO integer :: num_rows, num_cols, nnz integer :: i, j, idx @@ -81,13 +94,13 @@ contains #:endfor - #:for k1, t1 in (KINDS_TYPES) - subroutine coo2dense_${k1}$(COO,dense) - type(COO_${k1}$), intent(in) :: COO + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine coo2dense_${s1}$(COO,dense) + type(COO_${s1}$), intent(in) :: COO ${t1}$, allocatable, intent(inout) :: dense(:,:) integer :: idx - if(.not.allocated(dense)) allocate(dense(COO%nrows,COO%nrows),source=0._${k1}$) + if(.not.allocated(dense)) allocate(dense(COO%nrows,COO%nrows),source=zero_${s1}$) do concurrent(idx = 1:COO%nnz) dense( COO%index(1,idx) , COO%index(2,idx) ) = COO%data(idx) end do @@ -95,10 +108,10 @@ contains #:endfor - #:for k1, t1 in (KINDS_TYPES) - subroutine coo2csr_${k1}$(COO,CSR) - type(COO_${k1}$), intent(in) :: COO - type(CSR_${k1}$), intent(inout) :: CSR + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine coo2csr_${s1}$(COO,CSR) + type(COO_${s1}$), intent(in) :: COO + type(CSR_${s1}$), intent(inout) :: CSR integer :: i CSR%nnz = COO%nnz; CSR%nrows = COO%nrows; CSR%ncols = COO%ncols @@ -125,10 +138,10 @@ contains #:endfor - #:for k1, t1 in (KINDS_TYPES) - subroutine csr2coo_${k1}$(CSR,COO) - type(CSR_${k1}$), intent(in) :: CSR - type(COO_${k1}$), intent(inout) :: COO + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine csr2coo_${s1}$(CSR,COO) + type(CSR_${s1}$), intent(in) :: CSR + type(COO_${s1}$), intent(inout) :: COO integer :: i, j COO%nnz = CSR%nnz; COO%nrows = CSR%nrows; COO%ncols = CSR%ncols @@ -150,5 +163,71 @@ contains end subroutine #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) + !> csr2sellc: This function enables transfering data from a CSR matrix to a SELL-C matrix + !> This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves + type(CSR_${s1}$), intent(in) :: CSR + type(SELLC_${s1}$), intent(inout) :: SELLC + integer, intent(in), optional :: chunk + ${t1}$, parameter :: zero = zero_${s1}$ + integer :: i, j, num_chunks + + if(present(chunk)) SELLC%chunk_size = chunk + + SELLC%nrows = CSR%nrows; SELLC%ncols = CSR%ncols + SELLC%base = CSR%base; SELLC%sym = CSR%sym + associate( nrows=>SELLC%nrows, ncols=>SELLC%ncols, nnz=>SELLC%nnz, & + & chunk_size=>SELLC%chunk_size ) + !------------------------------------------- + ! csr rowptr to SELL-C chunked rowptr + num_chunks = (nrows + chunk_size - 1)/chunk_size + allocate( SELLC%rowptr(num_chunks+1) ) + block + integer :: cidx, rownnz, chunknnz + SELLC%rowptr(1) = 1 + cidx = 1 + do i = 1, nrows, chunk_size + chunknnz = 0 + ! Iterate over rows in a given chunk + do j = i, min(i+chunk_size-1,nrows) + rownnz = CSR%rowptr(j+1) - CSR%rowptr(j) + chunknnz = max(chunknnz,rownnz) + end do + SELLC%rowptr(cidx+1) = SELLC%rowptr(cidx) + chunknnz + cidx = cidx + 1 + end do + nnz = SELLC%rowptr(num_chunks+1) - 1 + end block + !------------------------------------------- + ! copy values and colum index + allocate(SELLC%col(chunk_size,nnz), source = -1) + allocate(SELLC%data(chunk_size,nnz), source = zero ) + block + integer :: lb, ri, iaa, iab, rownnz + do i = 1, num_chunks + + lb = SELLC%rowptr(i) + + ! Loop over rows of a chunk + do j = (i-1)*chunk_size + 1, min(i*chunk_size,nrows) + + ri = j - (i - 1)*chunk_size + + rownnz = CSR%rowptr(j+1) - CSR%rowptr(j) - 1 + iaa = CSR%rowptr(j) + iab = CSR%rowptr(j+1) - 1 + + SELLC%col(ri,lb:lb+rownnz) = CSR%col(iaa:iab) + SELLC%data(ri,lb:lb+rownnz) = CSR%data(iaa:iab) + + end do + end do + end block + end associate + end subroutine + + #:endfor end module sparse_stdlib_conversion \ No newline at end of file diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index c19e1b044..7fd466873 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -1,5 +1,7 @@ #:include "common.fypp" -#:set KINDS_TYPES = REAL_KINDS_TYPES +#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX)) +#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX)) +#:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES !> The `stdlib_sparse_kinds` module provides derived type definitions for different sparse matrices !> !> This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose @@ -16,6 +18,14 @@ module stdlib_sparse_kinds enumerator :: k_SYMTRISUP !> Symmetric Sparse matrix with triangular supperior storage end enum public :: k_NOSYMMETRY, k_SYMTRIINF, k_SYMTRISUP + + #:for k1, t1, s1 in (R_KINDS_TYPES) + ${t1}$, parameter, public :: zero_${s1}$ = 0._${k1}$ + #:endfor + #:for k1, t1, s1 in (C_KINDS_TYPES) + ${t1}$, parameter, public :: zero_${s1}$ = (0._${k1}$,0._${k1}$) + #:endfor + ! -- Classes !> Base sparse type holding the meta data related to the storage capacity of a matrix. @@ -35,12 +45,12 @@ module stdlib_sparse_kinds procedure :: malloc => malloc_coo end type - #:for k1, t1 in (KINDS_TYPES) - type, public, extends(COO_type) :: COO_${k1}$ + #:for k1, t1, s1 in (KINDS_TYPES) + type, public, extends(COO_type) :: COO_${s1}$ ${t1}$, allocatable :: data(:) contains - procedure :: get => get_value_coo_${k1}$ - procedure :: set => set_value_coo_${k1}$ + procedure :: get => get_value_coo_${s1}$ + procedure :: set => set_value_coo_${s1}$ end type #:endfor @@ -52,12 +62,12 @@ module stdlib_sparse_kinds procedure :: malloc => malloc_csr end type - #:for k1, t1 in (KINDS_TYPES) - type, public, extends(CSR_type) :: CSR_${k1}$ + #:for k1, t1, s1 in (KINDS_TYPES) + type, public, extends(CSR_type) :: CSR_${s1}$ ${t1}$, allocatable :: data(:) contains - procedure :: get => get_value_csr_${k1}$ - procedure :: set => set_value_csr_${k1}$ + procedure :: get => get_value_csr_${s1}$ + procedure :: set => set_value_csr_${s1}$ end type #:endfor @@ -69,12 +79,12 @@ module stdlib_sparse_kinds procedure :: malloc => malloc_csc end type - #:for k1, t1 in (KINDS_TYPES) - type, public, extends(CSC_type) :: CSC_${k1}$ + #:for k1, t1, s1 in (KINDS_TYPES) + type, public, extends(CSC_type) :: CSC_${s1}$ ${t1}$, allocatable :: data(:) contains - procedure :: get => get_value_csc_${k1}$ - procedure :: set => set_value_csc_${k1}$ + procedure :: get => get_value_csc_${s1}$ + procedure :: set => set_value_csc_${s1}$ end type #:endfor @@ -86,12 +96,26 @@ module stdlib_sparse_kinds procedure :: malloc => malloc_ell end type - #:for k1, t1 in (KINDS_TYPES) - type, public, extends(ELL_type) :: ELL_${k1}$ + #:for k1, t1, s1 in (KINDS_TYPES) + type, public, extends(ELL_type) :: ELL_${s1}$ ${t1}$, allocatable :: data(:,:) contains - procedure :: get => get_value_ell_${k1}$ - procedure :: set => set_value_ell_${k1}$ + procedure :: get => get_value_ell_${s1}$ + procedure :: set => set_value_ell_${s1}$ + end type + #:endfor + + !> Compressed SELL-C + !> Reference : https://library.eecs.utk.edu/storage/files/ut-eecs-14-727.pdf + type, public, extends(sparse_type) :: SELLC_type + integer :: chunk_size = 8 !> default chunk size + integer, allocatable :: rowptr(:) !> row pointer + integer, allocatable :: col(:,:) !> column indices + end type + + #:for k1, t1, s1 in (KINDS_TYPES) + type, public, extends(SELLC_type) :: SELLC_${s1}$ + ${t1}$, allocatable :: data(:,:) end type #:endfor @@ -119,16 +143,16 @@ contains call move_alloc(from=temp_idx,to=self%index) select type(self) - #:for k1, t1 in (KINDS_TYPES) - type is(COO_${k1}$) + #:for k1, t1, s1 in (KINDS_TYPES) + type is(COO_${s1}$) block - ${t1}$, allocatable :: temp_data_${k1}$(:) + ${t1}$, allocatable :: temp_data_${s1}$(:) if(.not.allocated(self%data)) then - allocate(temp_data_${k1}$(nnz) , source = 0._${k1}$ ) + allocate(temp_data_${s1}$(nnz) , source = zero_${s1}$ ) else - allocate(temp_data_${k1}$(nnz) , source = self%data ) + allocate(temp_data_${s1}$(nnz) , source = self%data ) end if - call move_alloc(from=temp_data_${k1}$,to=self%data) + call move_alloc(from=temp_data_${s1}$,to=self%data) end block #:endfor end select @@ -163,16 +187,16 @@ contains call move_alloc(from=temp_idx,to=self%rowptr) select type(self) - #:for k1, t1 in (KINDS_TYPES) - type is(CSR_${k1}$) + #:for k1, t1, s1 in (KINDS_TYPES) + type is(CSR_${s1}$) block - ${t1}$, allocatable :: temp_data_${k1}$(:) + ${t1}$, allocatable :: temp_data_${s1}$(:) if(.not.allocated(self%data)) then - allocate(temp_data_${k1}$(nnz) , source = 0._${k1}$ ) + allocate(temp_data_${s1}$(nnz) , source = zero_${s1}$ ) else - allocate(temp_data_${k1}$(nnz) , source = self%data ) + allocate(temp_data_${s1}$(nnz) , source = self%data ) end if - call move_alloc(from=temp_data_${k1}$,to=self%data) + call move_alloc(from=temp_data_${s1}$,to=self%data) end block #:endfor end select @@ -207,16 +231,16 @@ contains call move_alloc(from=temp_idx,to=self%colptr) select type(self) - #:for k1, t1 in (KINDS_TYPES) - type is(CSC_${k1}$) + #:for k1, t1, s1 in (KINDS_TYPES) + type is(CSC_${s1}$) block - ${t1}$, allocatable :: temp_data_${k1}$(:) + ${t1}$, allocatable :: temp_data_${s1}$(:) if(.not.allocated(self%data)) then - allocate(temp_data_${k1}$(nnz) , source = 0._${k1}$ ) + allocate(temp_data_${s1}$(nnz) , source = zero_${s1}$ ) else - allocate(temp_data_${k1}$(nnz) , source = self%data ) + allocate(temp_data_${s1}$(nnz) , source = self%data ) end if - call move_alloc(from=temp_data_${k1}$,to=self%data) + call move_alloc(from=temp_data_${s1}$,to=self%data) end block #:endfor end select @@ -244,16 +268,16 @@ contains call move_alloc(from=temp_idx,to=self%index) select type(self) - #:for k1, t1 in (KINDS_TYPES) - type is(ELL_${k1}$) + #:for k1, t1, s1 in (KINDS_TYPES) + type is(ELL_${s1}$) block - ${t1}$, allocatable :: temp_data_${k1}$(:,:) + ${t1}$, allocatable :: temp_data_${s1}$(:,:) if(.not.allocated(self%data)) then - allocate(temp_data_${k1}$(num_rows,num_nz_rows) , source = 0._${k1}$ ) + allocate(temp_data_${s1}$(num_rows,num_nz_rows) , source = zero_${s1}$ ) else - allocate(temp_data_${k1}$(num_rows,num_nz_rows) , source = self%data ) + allocate(temp_data_${s1}$(num_rows,num_nz_rows) , source = self%data ) end if - call move_alloc(from=temp_data_${k1}$,to=self%data) + call move_alloc(from=temp_data_${s1}$,to=self%data) end block #:endfor end select @@ -263,9 +287,9 @@ contains ! data accessors !================================================================== - #:for k1, t1 in (KINDS_TYPES) - pure subroutine get_value_coo_${k1}$(self,val,ik,jk) - class(COO_${k1}$), intent(in) :: self + #:for k1, t1, s1 in (KINDS_TYPES) + pure subroutine get_value_coo_${s1}$(self,val,ik,jk) + class(COO_${s1}$), intent(in) :: self ${t1}$, intent(out) :: val integer, intent(in) :: ik, jk integer :: k @@ -276,11 +300,11 @@ contains return end if end do - val = 0._${k1}$ + val = zero_${s1}$ end subroutine - subroutine set_value_coo_${k1}$(self,val,ik,jk) - class(COO_${k1}$), intent(inout) :: self + subroutine set_value_coo_${s1}$(self,val,ik,jk) + class(COO_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk integer :: k @@ -295,9 +319,9 @@ contains #:endfor - #:for k1, t1 in (KINDS_TYPES) - pure subroutine get_value_csr_${k1}$(self,val,ik,jk) - class(CSR_${k1}$), intent(in) :: self + #:for k1, t1, s1 in (KINDS_TYPES) + pure subroutine get_value_csr_${s1}$(self,val,ik,jk) + class(CSR_${s1}$), intent(in) :: self ${t1}$, intent(out) :: val integer, intent(in) :: ik, jk integer :: k @@ -308,11 +332,11 @@ contains return end if end do - val = 0._${k1}$ + val = zero_${s1}$ end subroutine - subroutine set_value_csr_${k1}$(self,val,ik,jk) - class(CSR_${k1}$), intent(inout) :: self + subroutine set_value_csr_${s1}$(self,val,ik,jk) + class(CSR_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk integer :: k @@ -327,9 +351,9 @@ contains #:endfor - #:for k1, t1 in (KINDS_TYPES) - pure subroutine get_value_csc_${k1}$(self,val,ik,jk) - class(CSC_${k1}$), intent(in) :: self + #:for k1, t1, s1 in (KINDS_TYPES) + pure subroutine get_value_csc_${s1}$(self,val,ik,jk) + class(CSC_${s1}$), intent(in) :: self ${t1}$, intent(out) :: val integer, intent(in) :: ik, jk integer :: k @@ -340,11 +364,11 @@ contains return end if end do - val = 0._${k1}$ + val = zero_${s1}$ end subroutine - subroutine set_value_csc_${k1}$(self,val,ik,jk) - class(CSC_${k1}$), intent(inout) :: self + subroutine set_value_csc_${s1}$(self,val,ik,jk) + class(CSC_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk integer :: k @@ -359,9 +383,9 @@ contains #:endfor - #:for k1, t1 in (KINDS_TYPES) - pure subroutine get_value_ell_${k1}$(self,val,ik,jk) - class(ELL_${k1}$), intent(in) :: self + #:for k1, t1, s1 in (KINDS_TYPES) + pure subroutine get_value_ell_${s1}$(self,val,ik,jk) + class(ELL_${s1}$), intent(in) :: self ${t1}$, intent(out) :: val integer, intent(in) :: ik, jk integer :: k @@ -372,11 +396,11 @@ contains return end if end do - val = 0._${k1}$ + val = zero_${s1}$ end subroutine - subroutine set_value_ell_${k1}$(self,val,ik,jk) - class(ELL_${k1}$), intent(inout) :: self + subroutine set_value_ell_${s1}$(self,val,ik,jk) + class(ELL_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk integer :: k diff --git a/src/stdlib_sparse_matvec.fypp b/src/stdlib_sparse_matvec.fypp index d097750b4..2277a808a 100644 --- a/src/stdlib_sparse_matvec.fypp +++ b/src/stdlib_sparse_matvec.fypp @@ -1,6 +1,8 @@ #:include "common.fypp" #:set RANKS = range(1, 2+1) -#:set KINDS_TYPES = REAL_KINDS_TYPES +#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX)) +#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX)) +#:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES #! define ranks without parentheses #:def rksfx2(rank) #{if rank > 0}#${":," + ":," * (rank - 1)}$#{endif}# @@ -15,25 +17,25 @@ module stdlib_sparse_matvec private public :: matvec - interface matvec ! call matvec(matrix,vec_x,vec_y) => Y = M * X - #:for k1, t1 in (KINDS_TYPES) + interface matvec ! call matvec(matrix,vec_x,vec_y) => Y = Y + M * X + #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - module procedure matvec_coo_${rank}$d_${k1}$ - module procedure matvec_csr_${rank}$d_${k1}$ - module procedure matvec_csc_${rank}$d_${k1}$ - module procedure matvec_ell_${rank}$d_${k1}$ - + module procedure matvec_coo_${rank}$d_${s1}$ + module procedure matvec_csr_${rank}$d_${s1}$ + module procedure matvec_csc_${rank}$d_${s1}$ + module procedure matvec_ell_${rank}$d_${s1}$ #:endfor + module procedure matvec_sellc_${s1}$ #:endfor end interface contains !> matvec_coo - #:for k1, t1 in (KINDS_TYPES) + #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_coo_${rank}$d_${k1}$(matrix,vec_x,vec_y) - type(COO_${k1}$), intent(in) :: matrix + subroutine matvec_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y) + type(COO_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ integer :: k, ik, jk @@ -63,10 +65,10 @@ contains #:endfor !> matvec_csr - #:for k1, t1 in (KINDS_TYPES) + #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_csr_${rank}$d_${k1}$(matrix,vec_x,vec_y) - type(CSR_${k1}$), intent(in) :: matrix + subroutine matvec_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y) + type(CSR_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ integer :: i, j @@ -87,7 +89,7 @@ contains else if( sym == k_SYMTRIINF )then do i = 1 , nrows - aux = 0._${k1}$ + aux = zero_${s1}$ do j = rowptr(i), rowptr(i+1)-2 aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j)) vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * vec_x(${rksfx2(rank-1)}$i) @@ -114,10 +116,10 @@ contains #:endfor !> matvec_csc - #:for k1, t1 in (KINDS_TYPES) + #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_csc_${rank}$d_${k1}$(matrix,vec_x,vec_y) - type(CSC_${k1}$), intent(in) :: matrix + subroutine matvec_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y) + type(CSC_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ integer :: i, j @@ -150,7 +152,7 @@ contains else if( sym == k_SYMTRISUP )then ! NOT TESTED do j = 1 , ncols - aux = 0._${k1}$ + aux = zero_${s1}$ do i = colptr(j), colptr(i+1)-2 aux = aux + data(i) * vec_x(${rksfx2(rank-1)}$j) vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + data(i) * vec_x(${rksfx2(rank-1)}$row(i)) @@ -167,10 +169,10 @@ contains #:endfor !> matvec_ell - #:for k1, t1 in (KINDS_TYPES) + #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_ell_${rank}$d_${k1}$(matrix,vec_x,vec_y) - type(ELL_${k1}$), intent(in) :: matrix + subroutine matvec_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y) + type(ELL_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ integer :: i, j, k @@ -189,5 +191,76 @@ contains #:endfor #:endfor + + !> matvec_sellc + #:set CHUNKS = [4,8,16] + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine matvec_sellc_${s1}$(matrix,vec_x,vec_y) + !> This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves + type(SELLC_${s1}$), intent(in) :: matrix + ${t1}$, intent(in) :: vec_x(:) + ${t1}$, intent(inout) :: vec_y(:) + ${t1}$, parameter :: zero = zero_${s1}$ + integer :: i, nz, rowidx, num_chunks, rm + + associate( data => matrix%data, ia => matrix%rowptr , ja => matrix%col, cs => matrix%chunk_size, & + & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) + num_chunks = nrows / cs + rm = nrows - num_chunks * cs + if( sym == k_NOSYMMETRY) then + + select case(cs) + #:for chunk in CHUNKS + case(${chunk}$) + do i = 1, num_chunks + nz = ia(i+1) - ia(i) + rowidx = (i - 1)*${chunk}$ + 1 + call chunk_kernel_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x,vec_y(rowidx:)) + end do + #:endfor + case default + print *, "error: chunk size not supported." + return + end select + + ! remainder + if(rm>0)then + i = num_chunks + 1 + nz = ia(i+1) - ia(i) + rowidx = (i - 1)*cs + 1 + call chunk_kernel_remainder(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x,vec_y(rowidx:)) + end if + + end if + end associate + + contains + #:for chunk in CHUNKS + pure subroutine chunk_kernel_${chunk}$(nz,a,ja,x,y) + integer, value :: nz + ${t1}$, intent(in) :: a(${chunk}$,nz), x(*) + integer, intent(in) :: ja(${chunk}$,nz) + ${t1}$, intent(out) :: y(${chunk}$) + integer :: j + do j = 1, nz + where(ja(:,j) > 0) y = y + a(:,j) * x(ja(:,j)) + end do + end subroutine + #:endfor + + pure subroutine chunk_kernel_remainder(nz,cs,rm,a,ja,x,y) + integer, value :: nz, cs, rm + ${t1}$, intent(in) :: a(cs,nz), x(*) + integer, intent(in) :: ja(cs,nz) + ${t1}$, intent(out) :: y(rm) + integer :: j + do j = 1, nz + where(ja(1:rm,j) > 0) y = y + a(1:rm,j) * x(ja(1:rm,j)) + end do + end subroutine + + end subroutine + + #:endfor end module stdlib_sparse_matvec \ No newline at end of file diff --git a/test/linalg/test_sparse_matvec.fypp b/test/linalg/test_sparse_matvec.fypp index 9a456a81d..7d3dc8592 100644 --- a/test/linalg/test_sparse_matvec.fypp +++ b/test/linalg/test_sparse_matvec.fypp @@ -1,5 +1,6 @@ #:include "common.fypp" -#:set KINDS_TYPES = REAL_KINDS_TYPES +#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX)) +#:set KINDS_TYPES = R_KINDS_TYPES module test_sparse_matvec use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64 @@ -16,62 +17,212 @@ contains type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & - new_unittest("coo", test_coo) & - ] - - end subroutine collect_suite + new_unittest('coo', test_coo), & + new_unittest('csr', test_csr), & + new_unittest('csc', test_csc), & + new_unittest('ell', test_ell), & + new_unittest('sellc', test_sellc), & + new_unittest('symmetries', test_symmetries) & + ] + end subroutine subroutine test_coo(error) !> Error handling type(error_type), allocatable, intent(out) :: error - - #:for k1, t1 in (KINDS_TYPES) + #:for k1, t1, s1 in (KINDS_TYPES) block + integer, parameter :: wp = ${k1}$ + type(COO_${s1}$) :: COO ${t1}$, allocatable :: dense(:,:) - type(COO_${k1}$) :: COO ${t1}$, allocatable :: vec_x(:) ${t1}$, allocatable :: vec_y1(:), vec_y2(:) - ${t1}$ :: val, err - integer :: i, j - + allocate( dense(4,5) , source = & - reshape([9._${k1}$,4._${k1}$, 0._${k1}$,4._${k1}$, & - 0._${k1}$,7._${k1}$, 8._${k1}$,0._${k1}$, & - 0._${k1}$,0._${k1}$,-1._${k1}$,5._${k1}$, & - 0._${k1}$,0._${k1}$, 8._${k1}$,6._${k1}$, & - -3._${k1}$,0._${k1}$, 0._${k1}$,0._${k1}$],[4,5]) ) + reshape(real([9,4, 0,4, & + 0,7, 8,0, & + 0,0,-1,5, & + 0,0, 8,6, & + -3,0, 0,0],kind=wp),[4,5]) ) - call dense2coo(dense , COO) + call dense2coo( dense , COO ) - !> Test assigned values - err = 0._${k1}$ - do j = 1, size(dense,dim=2) - do i = 1, size(dense,dim=1) - call COO%get(val,i,j) - err = err + abs( val - dense(i,j) ) - end do - end do - call check(error, err <= epsilon(0._${k1}$) ) + allocate( vec_x(5) , source = 1._wp ) + allocate( vec_y1(4) , source = 0._wp ) + allocate( vec_y2(4) , source = 0._wp ) + + vec_y1 = matmul( dense, vec_x ) + + call check(error, all(vec_y1 == real([6,11,15,15],kind=wp)) ) if (allocated(error)) return - !> Test matvec - allocate( vec_x(5) , source = 1._${k1}$ ) - allocate( vec_y1(4) , source = 0._${k1}$ ) - allocate( vec_y2(4) , source = 0._${k1}$ ) + call matvec( COO, vec_x, vec_y2 ) + call check(error, all(vec_y1 == vec_y2) ) + if (allocated(error)) return + end block + #:endfor + end subroutine - vec_y1 = matmul( dense, vec_x ) - call matvec( COO , vec_x, vec_y2 ) + subroutine test_csr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + #:for k1, t1, s1 in (KINDS_TYPES) + block + integer, parameter :: wp = ${k1}$ + type(CSR_${s1}$) :: CSR + ${t1}$, allocatable :: vec_x(:) + ${t1}$, allocatable :: vec_y(:) + + call CSR%malloc(4,5,10) + CSR%data(:) = real([9,-3,4,7,8,-1,8,4,5,6],kind=wp) + CSR%col(:) = [1,5,1,2,2,3,4,1,3,4] + CSR%rowptr(:) = [1,3,5,8,11] + + allocate( vec_x(5) , source = 1._wp ) + allocate( vec_y(4) , source = 0._wp ) + call matvec( CSR, vec_x, vec_y ) - call check(error, all(vec_y1 == [6._${k1}$,11._${k1}$,15._${k1}$,15._${k1}$]) ) + call check(error, all(vec_y == real([6,11,15,15],kind=wp)) ) if (allocated(error)) return + end block + #:endfor + end subroutine + + subroutine test_csc(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + #:for k1, t1, s1 in (KINDS_TYPES) + block + integer, parameter :: wp = ${k1}$ + type(CSC_${s1}$) :: CSC + ${t1}$, allocatable :: vec_x(:) + ${t1}$, allocatable :: vec_y(:) + + call CSC%malloc(4,5,10) + CSC%data(:) = real([9,4,4,7,8,-1,5,8,6,-3],kind=wp) + CSC%row(:) = [1,2,4,2,3,3,4,3,4,1] + CSC%colptr(:) = [1,4,6,8,10,11] - call check(error, all(vec_y1 == vec_y2) ) + allocate( vec_x(5) , source = 1._wp ) + allocate( vec_y(4) , source = 0._wp ) + call matvec( CSC, vec_x, vec_y ) + + call check(error, all(vec_y == real([6,11,15,15],kind=wp)) ) + if (allocated(error)) return + end block + #:endfor + end subroutine + + subroutine test_ell(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + #:for k1, t1, s1 in (KINDS_TYPES) + block + integer, parameter :: wp = ${k1}$ + type(ELL_${s1}$) :: ELL + ${t1}$, allocatable :: vec_x(:) + ${t1}$, allocatable :: vec_y(:) + + call ELL%malloc(4,5,10) + ELL%data(1,1:3) = real([9,-3,0],kind=wp) + ELL%data(2,1:3) = real([4,7,0],kind=wp) + ELL%data(3,1:3) = real([8,-1,8],kind=wp) + ELL%data(4,1:3) = real([4,5,6],kind=wp) + + ELL%index(1,1:3) = [1,5,0] + ELL%index(2,1:3) = [1,2,0] + ELL%index(3,1:3) = [2,3,4] + ELL%index(4,1:3) = [1,3,4] + + allocate( vec_x(5) , source = 1._wp ) + allocate( vec_y(4) , source = 0._wp ) + call matvec( ELL, vec_x, vec_y ) + + call check(error, all(vec_y == real([6,11,15,15],kind=wp)) ) if (allocated(error)) return end block #:endfor end subroutine + subroutine test_sellc(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + #:for k1, t1, s1 in (KINDS_TYPES) + block + integer, parameter :: wp = ${k1}$ + type(SELLC_${s1}$) :: SELLC + type(CSR_${s1}$) :: CSR + ${t1}$, allocatable :: vec_x(:) + ${t1}$, allocatable :: vec_y(:) + integer :: i + + call CSR%malloc(6,6,17) + ! 1 2 3 4 5 6 + CSR%col = [ 1, 3, 4, & + 2, 3, 5, 6, & + 1, 2, 3, & + 5, 6, & + 4, 5, & + 2, 5, 6] + CSR%rowptr = [1,4,8,11,13,15,18] + CSR%data = [(real(i,kind=wp),i=1,CSR%nnz)] + + call csr2sellc(CSR,SELLC,4) + + allocate( vec_x(6) , source = 1._wp ) + allocate( vec_y(6) , source = 0._wp ) + + call matvec( SELLC, vec_x, vec_y ) + + call check(error, all(vec_y == real([6,22,27,23,27,48],kind=wp)) ) + if (allocated(error)) return + end block + #:endfor + end subroutine + + subroutine test_symmetries(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + #:for k1, t1, s1 in (KINDS_TYPES) + block + integer, parameter :: wp = ${k1}$ + type(COO_${s1}$) :: COO + type(CSR_${s1}$) :: CSR + ${t1}$, allocatable :: dense(:,:) + ${t1}$, allocatable :: vec_x(:) + ${t1}$, allocatable :: vec_y1(:), vec_y2(:), vec_y3(:) + + allocate( vec_x(4) , source = 1._wp ) + allocate( vec_y1(4) , source = 0._wp ) + allocate( vec_y2(4) , source = 0._wp ) + allocate( vec_y3(4) , source = 0._wp ) + + allocate( dense(4,4) , source = & + reshape(real([1,0,0,0, & + 2,1,0,0, & + 0,2,1,0,& + 0,0,2,1],kind=wp),[4,4]) ) + + call dense2coo( dense , COO ) + COO%sym = k_SYMTRISUP + call coo2csr(COO, CSR) + + dense(2,1) = 2._wp; dense(3,2) = 2._wp; dense(4,3) = 2._wp + vec_y1 = matmul( dense, vec_x ) + call check(error, all(vec_y1 == [3,5,5,3]) ) + if (allocated(error)) return + + call matvec( COO , vec_x, vec_y2 ) + call check(error, all(vec_y1 == vec_y2) ) + if (allocated(error)) return + + call matvec( CSR , vec_x, vec_y3 ) + call check(error, all(vec_y1 == vec_y3) ) + if (allocated(error)) return + end block + #:endfor + end subroutine + end module From 8f725592e636af9713cca710acffd07b83ef08f0 Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Tue, 21 May 2024 08:08:16 +0200 Subject: [PATCH 10/78] include alpha and beta parameters in sparse matvec --- src/stdlib_sparse_kinds.fypp | 2 + src/stdlib_sparse_matvec.fypp | 131 ++++++++++++++++++++++++++-------- 2 files changed, 102 insertions(+), 31 deletions(-) diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 7fd466873..b9b4ab177 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -21,9 +21,11 @@ module stdlib_sparse_kinds #:for k1, t1, s1 in (R_KINDS_TYPES) ${t1}$, parameter, public :: zero_${s1}$ = 0._${k1}$ + ${t1}$, parameter, public :: one_${s1}$ = 1._${k1}$ #:endfor #:for k1, t1, s1 in (C_KINDS_TYPES) ${t1}$, parameter, public :: zero_${s1}$ = (0._${k1}$,0._${k1}$) + ${t1}$, parameter, public :: one_${s1}$ = (1._${k1}$,1._${k1}$) #:endfor ! -- Classes diff --git a/src/stdlib_sparse_matvec.fypp b/src/stdlib_sparse_matvec.fypp index 2277a808a..07f0f8108 100644 --- a/src/stdlib_sparse_matvec.fypp +++ b/src/stdlib_sparse_matvec.fypp @@ -17,7 +17,7 @@ module stdlib_sparse_matvec private public :: matvec - interface matvec ! call matvec(matrix,vec_x,vec_y) => Y = Y + M * X + interface matvec ! call matvec(matrix,vec_x,vec_y [,alpha,beta]) => Y = beta * Y + alpha * M * X #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS module procedure matvec_coo_${rank}$d_${s1}$ @@ -34,27 +34,37 @@ contains !> matvec_coo #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y) + subroutine matvec_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(COO_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + ${t1}$, intent(in), optional :: alpha + ${t1}$, intent(in), optional :: beta + ${t1}$ :: alpha_, beta_ integer :: k, ik, jk + alpha_ = one_${k1}$ + if(present(alpha)) alpha_ = alpha + if(present(beta)) then + vec_y = beta * vec_y + else + vec_y = zero_${s1}$ + endif associate( data => matrix%data, index => matrix%index, sym => matrix%sym, nnz => matrix%nnz ) if( sym == k_NOSYMMETRY) then do concurrent (k = 1:nnz) ik = index(1,k) jk = index(2,k) - vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + data(k) * vec_x(${rksfx2(rank-1)}$jk) + vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$jk) end do else do concurrent (k = 1:nnz) ik = index(1,k) jk = index(2,k) - vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + data(k) * vec_x(${rksfx2(rank-1)}$jk) + vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$jk) if( ik==jk ) cycle - vec_y(${rksfx2(rank-1)}$jk) = vec_y(${rksfx2(rank-1)}$jk) + data(k) * vec_x(${rksfx2(rank-1)}$ik) + vec_y(${rksfx2(rank-1)}$jk) = vec_y(${rksfx2(rank-1)}$jk) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$ik) end do end if @@ -64,48 +74,77 @@ contains #:endfor #:endfor - !> matvec_csr + !! matvec_csr #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y) + subroutine matvec_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(CSR_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + ${t1}$, intent(in), optional :: alpha + ${t1}$, intent(in), optional :: beta + ${t1}$ :: alpha_, beta_ integer :: i, j #:if rank == 1 - ${t1}$ :: aux + ${t1}$ :: aux, aux2 #:else - ${t1}$ :: aux(size(vec_x,dim=1)) + ${t1}$ :: aux(size(vec_x,dim=1)), aux2(size(vec_x,dim=1)) #:endif + + alpha_ = one_${k1}$ + if(present(alpha)) alpha_ = alpha + beta_ = zero_${k1}$ + if(present(beta)) beta_ = beta associate( data => matrix%data, col => matrix%col, rowptr => matrix%rowptr, & & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) if( sym == k_NOSYMMETRY) then - do concurrent(i=1:nrows) + do i = 1, nrows + aux = zero_${k1}$ do j = rowptr(i), rowptr(i+1)-1 - vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + data(j) * vec_x(${rksfx2(rank-1)}$col(j)) + aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j)) end do + if(present(beta)) then + vec_y(${rksfx2(rank-1)}$i) = beta_ * vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux + else + vec_y(${rksfx2(rank-1)}$i) = alpha_ * aux + end if end do - + else if( sym == k_SYMTRIINF )then do i = 1 , nrows aux = zero_${s1}$ + aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i) do j = rowptr(i), rowptr(i+1)-2 aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j)) - vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * vec_x(${rksfx2(rank-1)}$i) + vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * aux2 end do - aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$i) - vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + aux + aux = alpha_ * aux + data(j) * aux2 + + if(present(beta)) then + vec_y(${rksfx2(rank-1)}$i) = beta_ * vec_y(${rksfx2(rank-1)}$i) + aux + else + vec_y(${rksfx2(rank-1)}$i) = aux + end if end do else if( sym == k_SYMTRISUP )then do i = 1 , nrows aux = vec_x(${rksfx2(rank-1)}$i) * data(rowptr(i)) + aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i) do j = rowptr(i)+1, rowptr(i+1)-1 aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j)) - vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * vec_x(${rksfx2(rank-1)}$i) end do - vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + aux + if(present(beta)) then + do j = rowptr(i)+1, rowptr(i+1)-1 + vec_y(${rksfx2(rank-1)}$col(j)) = beta_ * vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * aux2 + end do + else + do j = rowptr(i)+1, rowptr(i+1)-1 + vec_y(${rksfx2(rank-1)}$col(j)) = data(j) * aux2 + end do + end if + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux end do end if @@ -118,10 +157,13 @@ contains !> matvec_csc #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y) + subroutine matvec_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(CSC_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + ${t1}$, intent(in), optional :: alpha + ${t1}$, intent(in), optional :: beta + ${t1}$ :: alpha_, beta_ integer :: i, j #:if rank == 1 ${t1}$ :: aux @@ -129,12 +171,20 @@ contains ${t1}$ :: aux(size(vec_x,dim=1)) #:endif + alpha_ = one_${k1}$ + if(present(alpha)) alpha_ = alpha + if(present(beta)) then + vec_y = beta * vec_y + else + vec_y = zero_${s1}$ + endif + associate( data => matrix%data, colptr => matrix%colptr, row => matrix%row, & & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) if( sym == k_NOSYMMETRY) then do concurrent(j=1:ncols) do i = colptr(j), colptr(j+1)-1 - vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + data(i) * vec_x(${rksfx2(rank-1)}$j) + vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + alpha_ * data(i) * vec_x(${rksfx2(rank-1)}$j) end do end do @@ -144,9 +194,9 @@ contains aux = vec_x(${rksfx2(rank-1)}$j) * data(colptr(j)) do i = colptr(j)+1, colptr(j+1)-1 aux = aux + data(i) * vec_x(${rksfx2(rank-1)}$row(i)) - vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + data(i) * vec_x(${rksfx2(rank-1)}$j) + vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + alpha_ * data(i) * vec_x(${rksfx2(rank-1)}$j) end do - vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + aux + vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux end do else if( sym == k_SYMTRISUP )then @@ -155,10 +205,10 @@ contains aux = zero_${s1}$ do i = colptr(j), colptr(i+1)-2 aux = aux + data(i) * vec_x(${rksfx2(rank-1)}$j) - vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + data(i) * vec_x(${rksfx2(rank-1)}$row(i)) + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * data(i) * vec_x(${rksfx2(rank-1)}$row(i)) end do aux = aux + data(colptr(j)) * vec_x(${rksfx2(rank-1)}$j) - vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + aux + vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux end do end if @@ -171,18 +221,28 @@ contains !> matvec_ell #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y) + subroutine matvec_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(ELL_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + ${t1}$, intent(in), optional :: alpha + ${t1}$, intent(in), optional :: beta + ${t1}$ :: alpha_, beta_ integer :: i, j, k + alpha_ = one_${k1}$ + if(present(alpha)) alpha_ = alpha + if(present(beta)) then + vec_y = beta * vec_y + else + vec_y = zero_${s1}$ + endif associate( data => matrix%data, index => matrix%index, MNZ_P_ROW => matrix%K, & & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) if( sym == k_NOSYMMETRY) then do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW) j = index(i,k) - if(j>0) vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + data(i,k) * vec_x(${rksfx2(rank-1)}$j) + if(j>0) vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$j) end do end if @@ -195,14 +255,23 @@ contains !> matvec_sellc #:set CHUNKS = [4,8,16] #:for k1, t1, s1 in (KINDS_TYPES) - subroutine matvec_sellc_${s1}$(matrix,vec_x,vec_y) + subroutine matvec_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) !> This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves type(SELLC_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x(:) ${t1}$, intent(inout) :: vec_y(:) - ${t1}$, parameter :: zero = zero_${s1}$ + ${t1}$, intent(in), optional :: alpha + ${t1}$, intent(in), optional :: beta + ${t1}$ :: alpha_, beta_ integer :: i, nz, rowidx, num_chunks, rm + alpha_ = one_${s1}$ + if(present(alpha)) alpha_ = alpha + if(present(beta)) then + vec_y = beta * vec_y + else + vec_y = zero_${s1}$ + endif associate( data => matrix%data, ia => matrix%rowptr , ja => matrix%col, cs => matrix%chunk_size, & & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) num_chunks = nrows / cs @@ -240,10 +309,10 @@ contains integer, value :: nz ${t1}$, intent(in) :: a(${chunk}$,nz), x(*) integer, intent(in) :: ja(${chunk}$,nz) - ${t1}$, intent(out) :: y(${chunk}$) + ${t1}$, intent(inout) :: y(${chunk}$) integer :: j do j = 1, nz - where(ja(:,j) > 0) y = y + a(:,j) * x(ja(:,j)) + where(ja(:,j) > 0) y = y + alpha_ * a(:,j) * x(ja(:,j)) end do end subroutine #:endfor @@ -252,10 +321,10 @@ contains integer, value :: nz, cs, rm ${t1}$, intent(in) :: a(cs,nz), x(*) integer, intent(in) :: ja(cs,nz) - ${t1}$, intent(out) :: y(rm) + ${t1}$, intent(inout) :: y(rm) integer :: j do j = 1, nz - where(ja(1:rm,j) > 0) y = y + a(1:rm,j) * x(ja(1:rm,j)) + where(ja(1:rm,j) > 0) y = y + alpha_ * a(1:rm,j) * x(ja(1:rm,j)) end do end subroutine From 87c867a707e8b676855fc32e6b353ad31020fb0e Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 25 May 2024 13:31:48 +0200 Subject: [PATCH 11/78] wrong ellpack size --- test/linalg/test_sparse_matvec.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/linalg/test_sparse_matvec.fypp b/test/linalg/test_sparse_matvec.fypp index 7d3dc8592..91fd8907a 100644 --- a/test/linalg/test_sparse_matvec.fypp +++ b/test/linalg/test_sparse_matvec.fypp @@ -122,7 +122,7 @@ contains ${t1}$, allocatable :: vec_x(:) ${t1}$, allocatable :: vec_y(:) - call ELL%malloc(4,5,10) + call ELL%malloc(4,5,3) ELL%data(1,1:3) = real([9,-3,0],kind=wp) ELL%data(2,1:3) = real([4,7,0],kind=wp) ELL%data(3,1:3) = real([8,-1,8],kind=wp) From 59fe24ea33131642c79344e2af4c4e87694d3694 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 25 May 2024 13:33:49 +0200 Subject: [PATCH 12/78] start sparse specs --- doc/specs/stdlib_sparse_kinds.md | 137 +++++++++++++++++++++++++++++++ src/stdlib_sparse_kinds.fypp | 2 +- src/stdlib_sparse_matvec.fypp | 6 +- 3 files changed, 143 insertions(+), 2 deletions(-) create mode 100644 doc/specs/stdlib_sparse_kinds.md diff --git a/doc/specs/stdlib_sparse_kinds.md b/doc/specs/stdlib_sparse_kinds.md new file mode 100644 index 000000000..6df135a52 --- /dev/null +++ b/doc/specs/stdlib_sparse_kinds.md @@ -0,0 +1,137 @@ +--- +title: sparse_kinds +--- + +# The `stdlib_sparse_kinds` module + +[TOC] + +## Introduction + +The `stdlib_sparse_kinds` provides several derived types defining known sparse matrix data structures. + + +## Derived types provided + + +### The `sparse_type` abstract derived type +#### Status + +Experimental + +#### Description +The `sparse_type` is defined as an abstract derived type holding the basic common meta data needed to define a sparse matrix. All other sparse types falvors are derived from the `sparse_type`. + +```Fortran +type, public, abstract :: sparse_type + integer :: nrows !> number of rows + integer :: ncols !> number of columns + integer :: nnz !> number of non-zero values + integer :: sym !> assumed storage symmetry + integer :: base !> index base = 0 for (C) or 1 (Fortran) +end type +``` + +The symmetry integer laber should be assigned from the module's internal enumerator containing the following three enums: + +```Fortran +enum, bind(C) + enumerator :: k_NOSYMMETRY !> Full Sparse matrix (no symmetry considerations) + enumerator :: k_SYMTRIINF !> Symmetric Sparse matrix with triangular inferior storage + enumerator :: k_SYMTRISUP !> Symmetric Sparse matrix with triangular supperior storage +end enum +``` +In the following, all sparse kinds will be presented in two main flavors: a data-less type `_type` useful for topological graph operations. And real/complex valued types `_` containing the `data` buffer for the matrix values. + +$$ M = \begin{bmatrix} + 9 & 0 & 0 & 0 & -3 \\ + 4 & 7 & 0 & 0 & 0 \\ + 0 & 8 & -1 & 8 & 0 \\ + 4 & 0 & 5 & 6 & 0 \\ + \end{bmatrix} $$ + +### `COO`: The COOrdinates compressed sparse format +#### Status + +Experimental + +#### Description +The `COO`, triplet or `ijv` format defines all non-zero elements of the matrix by explicitly allocating the `i,j` index and the value of the matrix. + +```Fortran +type(COO_sp) :: COO +call COO%malloc(4,5,10) +COO%data(:) = real([9,-3,4,7,8,-1,8,4,5,6]) +COO%index(1:2,1) = [1,1] +COO%index(1:2,2) = [1,5] +COO%index(1:2,3) = [2,1] +COO%index(1:2,4) = [2,2] +COO%index(1:2,5) = [3,2] +COO%index(1:2,6) = [3,3] +COO%index(1:2,7) = [3,4] +COO%index(1:2,8) = [4,1] +COO%index(1:2,9) = [4,3] +COO%index(1:2,10) = [4,4] +``` + +### `CSR`: The Compressed Sparse Row or Yale format +#### Status + +Experimental + +#### Description +The Compressed Sparse Row or Yale format `CSR` stores the matrix index by compressing the row indeces with a counter pointer `rowptr` enabling to know the first and last non-zero colum index `col` of the given row. + +```Fortran +type(CSR_sp) :: CSR +call CSR%malloc(4,5,10) +CSR%data(:) = real([9,-3,4,7,8,-1,8,4,5,6]) +CSR%col(:) = [1,5,1,2,2,3,4,1,3,4] +CSR%rowptr(:) = [1,3,5,8,11] +``` + +### `CSC`: The Compressed Sparse Column format +#### Status + +Experimental + +#### Description +The Compressed Sparse Colum `CSC` is similar to the `CSR` format but values are accesed first by colum, thus an index counter is given by `colptr` which enables accessing the start and ending rows of a given colum in the `row` index table. + +```Fortran +type(CSC_sp) :: CSC +call CSC%malloc(4,5,10) +CSC%data(:) = real([9,4,4,7,8,-1,5,8,6,-3]) +CSC%row(:) = [1,2,4,2,3,3,4,3,4,1] +CSC%colptr(:) = [1,4,6,8,10,11] +``` + +### `ELLPACK`: ELL-pack storage format +#### Status + +Experimental + +#### Description +The `ELL` format stores the data in a dense matrix of $nrows \times K$ in column major order. By imposing a constant number of zeros per row $K$, this format will incure in additional zeros being stored, but it enables efficient vectorization as memory acces are carried out by constant sized strides. + +```Fortran +type(ELL_sp) :: ELL +call ELL%malloc(num_rows=4,num_cols=5,num_nz_row=3) +ELL%data(1,1:3) = real([9,-3,0]) +ELL%data(2,1:3) = real([4,7,0]) +ELL%data(3,1:3) = real([8,-1,8]) +ELL%data(4,1:3) = real([4,5,6]) + +ELL%index(1,1:3) = [1,5,0] +ELL%index(2,1:3) = [1,2,0] +ELL%index(3,1:3) = [2,3,4] +ELL%index(4,1:3) = [1,3,4] +``` + +### `SELL-C`: The Sliced ELLPACK with Constant blocks format +#### Status + +Experimental + +#### Description +The Sliced ELLPACK format `SELLC` is a variation of the `ELLPACK` format introducing the notion of blocks within which the number of columns is kept contant but can change from one block to the next. This modification reduces the storage size compared to the `ELLPACK` format but maintaining its efficient data access scheme. It can be seen as an intermediate format between `CSR` and `ELLPACK`. \ No newline at end of file diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index b9b4ab177..d55d1e3f6 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -4,7 +4,7 @@ #:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES !> The `stdlib_sparse_kinds` module provides derived type definitions for different sparse matrices !> -!> This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose +! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose module stdlib_sparse_kinds use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp implicit none diff --git a/src/stdlib_sparse_matvec.fypp b/src/stdlib_sparse_matvec.fypp index 07f0f8108..6348d7536 100644 --- a/src/stdlib_sparse_matvec.fypp +++ b/src/stdlib_sparse_matvec.fypp @@ -17,7 +17,11 @@ module stdlib_sparse_matvec private public :: matvec - interface matvec ! call matvec(matrix,vec_x,vec_y [,alpha,beta]) => Y = beta * Y + alpha * M * X + interface matvec + !! Version experimental + !! + !! Applay the sparse matrix-vector product $$y = \beta * y + \alpha * M * x $$ + !! #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS module procedure matvec_coo_${rank}$d_${s1}$ From 43ab25f74d16a00310e7aea3b111ab7ef422932f Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 25 May 2024 14:14:59 +0200 Subject: [PATCH 13/78] fix module name --- src/stdlib_sparse.f90 | 2 +- src/stdlib_sparse_conversion.fypp | 6 +++--- src/stdlib_sparse_matvec.fypp | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/stdlib_sparse.f90 b/src/stdlib_sparse.f90 index c9d866151..6f1847ea3 100644 --- a/src/stdlib_sparse.f90 +++ b/src/stdlib_sparse.f90 @@ -2,5 +2,5 @@ module stdlib_sparse use stdlib_sparse_kinds use stdlib_sparse_matvec - use sparse_stdlib_conversion + use stdlib_sparse_conversion end module stdlib_sparse \ No newline at end of file diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 15552a923..053c8d170 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -4,8 +4,8 @@ #:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES !> The `stdlib_sparse_conversion` module provides sparse to sparse matrix conversion utilities. !> -!> This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose -module sparse_stdlib_conversion +! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose +module stdlib_sparse_conversion use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp use stdlib_sparse_kinds implicit none @@ -230,4 +230,4 @@ contains #:endfor -end module sparse_stdlib_conversion \ No newline at end of file +end module stdlib_sparse_conversion \ No newline at end of file diff --git a/src/stdlib_sparse_matvec.fypp b/src/stdlib_sparse_matvec.fypp index 6348d7536..20a2b8ee1 100644 --- a/src/stdlib_sparse_matvec.fypp +++ b/src/stdlib_sparse_matvec.fypp @@ -9,7 +9,7 @@ #:enddef !> The `stdlib_sparse_matvec` module provides matrix-vector product kernels. !> -!> This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose +! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose module stdlib_sparse_matvec use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp use stdlib_sparse_kinds From 838b1596f916248bf01f47afa56e8cbc0487c70a Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 25 May 2024 15:18:47 +0200 Subject: [PATCH 14/78] include reference --- doc/specs/stdlib_sparse_kinds.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse_kinds.md b/doc/specs/stdlib_sparse_kinds.md index 6df135a52..bcd0c5eb5 100644 --- a/doc/specs/stdlib_sparse_kinds.md +++ b/doc/specs/stdlib_sparse_kinds.md @@ -134,4 +134,4 @@ ELL%index(4,1:3) = [1,3,4] Experimental #### Description -The Sliced ELLPACK format `SELLC` is a variation of the `ELLPACK` format introducing the notion of blocks within which the number of columns is kept contant but can change from one block to the next. This modification reduces the storage size compared to the `ELLPACK` format but maintaining its efficient data access scheme. It can be seen as an intermediate format between `CSR` and `ELLPACK`. \ No newline at end of file +The Sliced ELLPACK format `SELLC` is a variation of the `ELLPACK` format. This modification reduces the storage size compared to the `ELLPACK` format but maintaining its efficient data access scheme. It can be seen as an intermediate format between `CSR` and `ELLPACK`. For more details read [here](https://arxiv.org/pdf/1307.6209v1) \ No newline at end of file From c74ad09c28b74ed4a53712a6a09d8fb2e98f858a Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sun, 26 May 2024 21:42:39 +0200 Subject: [PATCH 15/78] add matvec specs --- ...tdlib_sparse_kinds.md => stdlib_sparse.md} | 37 ++++++++++++++++--- 1 file changed, 32 insertions(+), 5 deletions(-) rename doc/specs/{stdlib_sparse_kinds.md => stdlib_sparse.md} (80%) diff --git a/doc/specs/stdlib_sparse_kinds.md b/doc/specs/stdlib_sparse.md similarity index 80% rename from doc/specs/stdlib_sparse_kinds.md rename to doc/specs/stdlib_sparse.md index bcd0c5eb5..c0ddb2674 100644 --- a/doc/specs/stdlib_sparse_kinds.md +++ b/doc/specs/stdlib_sparse.md @@ -1,15 +1,14 @@ --- -title: sparse_kinds +title: sparse --- -# The `stdlib_sparse_kinds` module +# The `stdlib_sparse` module [TOC] ## Introduction -The `stdlib_sparse_kinds` provides several derived types defining known sparse matrix data structures. - +The `stdlib_sparse` module provides several derived types defining known sparse matrix data structures. It also provides basic sparse kernels such as sparse matrix vector and conversion between matrix types. ## Derived types provided @@ -134,4 +133,32 @@ ELL%index(4,1:3) = [1,3,4] Experimental #### Description -The Sliced ELLPACK format `SELLC` is a variation of the `ELLPACK` format. This modification reduces the storage size compared to the `ELLPACK` format but maintaining its efficient data access scheme. It can be seen as an intermediate format between `CSR` and `ELLPACK`. For more details read [here](https://arxiv.org/pdf/1307.6209v1) \ No newline at end of file +The Sliced ELLPACK format `SELLC` is a variation of the `ELLPACK` format. This modification reduces the storage size compared to the `ELLPACK` format but maintaining its efficient data access scheme. It can be seen as an intermediate format between `CSR` and `ELLPACK`. For more details read [here](https://arxiv.org/pdf/1307.6209v1) + +## `matvec` - Sparse Matrix-Vector product + +### Status + +Experimental + +### Description + +Provide sparse matrix-vector product kernels for the current supported sparse matrix types. + +$$y=\alpha*M*x+\beta*y$$ + +### Syntax + +`call ` [[stdlib_sparse_matvec(module):matvec(interface)]] `(matrix,vec_x,vec_y [,alpha,beta])` + +### Arguments + +`matrix`, `intent(in)`: Shall be a `real` or `complex` sparse type matrix. + +`vec_x`, `intent(in)`: Shall be a rank-1 or rank-2 array of `real` or `complex` type array. + +`vec_y`, `intent(inout)`: Shall be a rank-1 or rank-2 array of `real` or `complex` type array. + +`alpha`, `intent(in)`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `alpha=1`. + +`beta`, `intent(in)`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `beta=0`. \ No newline at end of file From 14bfef9d4a1f37c9b7bc143bbba23096513794d9 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sun, 26 May 2024 22:27:32 +0200 Subject: [PATCH 16/78] start adding conversions specs --- doc/specs/stdlib_sparse.md | 64 +++++++++++++++++++++++++++++++++++++- 1 file changed, 63 insertions(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index c0ddb2674..5c3d2c1b0 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -161,4 +161,66 @@ $$y=\alpha*M*x+\beta*y$$ `alpha`, `intent(in)`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `alpha=1`. -`beta`, `intent(in)`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `beta=0`. \ No newline at end of file +`beta`, `intent(in)`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `beta=0`. + +## `sparse_conversion` - Sparse matrix to matrix conversions + +### Status + +Experimental + +### Description + +This module provides facility functions for converting between storage formats. + +### Syntax + +`call ` [[stdlib_sparse_conversion(module):dense2coo(interface)]] `(dense,coo)` + +### Arguments + +`dense`, `intent(in)`: Shall be a rank-2 array of `real` or `complex` type. + +`coo`, `intent(inout)`: Shall be a `COO` type of `real` or `complex` type. + +### Syntax + +`call ` [[stdlib_sparse_conversion(module):coo2dense(interface)]] `(coo,dense)` + +### Arguments + +`coo`, `intent(in)`: Shall be a `COO` type of `real` or `complex` type. + +`dense`, `intent(inout)`: Shall be a rank-2 array of `real` or `complex` type. + +### Syntax + +`call ` [[stdlib_sparse_conversion(module):coo2csr(interface)]] `(coo,csr)` + +### Arguments + +`coo`, `intent(in)`: Shall be a `COO` type of `real` or `complex` type. + +`csr`, `intent(inout)`: Shall be a `CSR` type of `real` or `complex` type. + +### Syntax + +`call ` [[stdlib_sparse_conversion(module):csr2coo(interface)]] `(csr,coo)` + +### Arguments + +`csr`, `intent(in)`: Shall be a `CSR` type of `real` or `complex` type. + +`coo`, `intent(inout)`: Shall be a `COO` type of `real` or `complex` type. + +### Syntax + +`call ` [[stdlib_sparse_conversion(module):csr2sellc(interface)]] `(csr,sellc[,chunk])` + +### Arguments + +`csr`, `intent(in)`: Shall be a `CSR` type of `real` or `complex` type. + +`sellc`, `intent(inout)`: Shall be a `SELLC` type of `real` or `complex` type. + +`chunk`, `intent(in)`, `optional`: chunk size for the Sliced ELLPACK format. \ No newline at end of file From 23be6476aa000a1d5e6c58465881bc1f80d95c62 Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Mon, 27 May 2024 17:20:28 +0200 Subject: [PATCH 17/78] breaking change: rename matvec to spmv for consistency with stdlib blas gemv --- doc/specs/stdlib_sparse.md | 6 ++- src/CMakeLists.txt | 2 +- src/stdlib_sparse.f90 | 2 +- ...se_matvec.fypp => stdlib_sparse_spmv.fypp} | 40 +++++++++---------- test/linalg/CMakeLists.txt | 2 +- ...arse_matvec.fypp => test_sparse_spmv.fypp} | 18 ++++----- 6 files changed, 36 insertions(+), 34 deletions(-) rename src/{stdlib_sparse_matvec.fypp => stdlib_sparse_spmv.fypp} (93%) rename test/linalg/{test_sparse_matvec.fypp => test_sparse_spmv.fypp} (95%) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 5c3d2c1b0..03ae9ae7f 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -135,7 +135,8 @@ Experimental #### Description The Sliced ELLPACK format `SELLC` is a variation of the `ELLPACK` format. This modification reduces the storage size compared to the `ELLPACK` format but maintaining its efficient data access scheme. It can be seen as an intermediate format between `CSR` and `ELLPACK`. For more details read [here](https://arxiv.org/pdf/1307.6209v1) -## `matvec` - Sparse Matrix-Vector product + +## `spmv` - Sparse Matrix-Vector product ### Status @@ -149,7 +150,7 @@ $$y=\alpha*M*x+\beta*y$$ ### Syntax -`call ` [[stdlib_sparse_matvec(module):matvec(interface)]] `(matrix,vec_x,vec_y [,alpha,beta])` +`call ` [[stdlib_sparse_spmv(module):spmv(interface)]] `(matrix,vec_x,vec_y [,alpha,beta])` ### Arguments @@ -163,6 +164,7 @@ $$y=\alpha*M*x+\beta*y$$ `beta`, `intent(in)`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `beta=0`. + ## `sparse_conversion` - Sparse matrix to matrix conversions ### Status diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 19e23579c..ace3443b3 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -36,7 +36,7 @@ set(fppFiles stdlib_sorting_sort_index.fypp stdlib_sparse_conversion.fypp stdlib_sparse_kinds.fypp - stdlib_sparse_matvec.fypp + stdlib_sparse_spmv.fypp stdlib_specialfunctions_gamma.fypp stdlib_stats.fypp stdlib_stats_corr.fypp diff --git a/src/stdlib_sparse.f90 b/src/stdlib_sparse.f90 index 6f1847ea3..82e5d35de 100644 --- a/src/stdlib_sparse.f90 +++ b/src/stdlib_sparse.f90 @@ -1,6 +1,6 @@ !! public API module stdlib_sparse use stdlib_sparse_kinds - use stdlib_sparse_matvec + use stdlib_sparse_spmv use stdlib_sparse_conversion end module stdlib_sparse \ No newline at end of file diff --git a/src/stdlib_sparse_matvec.fypp b/src/stdlib_sparse_spmv.fypp similarity index 93% rename from src/stdlib_sparse_matvec.fypp rename to src/stdlib_sparse_spmv.fypp index 20a2b8ee1..a74adccb9 100644 --- a/src/stdlib_sparse_matvec.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -7,38 +7,38 @@ #:def rksfx2(rank) #{if rank > 0}#${":," + ":," * (rank - 1)}$#{endif}# #:enddef -!> The `stdlib_sparse_matvec` module provides matrix-vector product kernels. +!> The `stdlib_sparse_spmv` module provides matrix-vector product kernels. !> ! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose -module stdlib_sparse_matvec +module stdlib_sparse_spmv use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp use stdlib_sparse_kinds implicit none private - public :: matvec - interface matvec + public :: spmv + interface spmv !! Version experimental !! !! Applay the sparse matrix-vector product $$y = \beta * y + \alpha * M * x $$ !! #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - module procedure matvec_coo_${rank}$d_${s1}$ - module procedure matvec_csr_${rank}$d_${s1}$ - module procedure matvec_csc_${rank}$d_${s1}$ - module procedure matvec_ell_${rank}$d_${s1}$ + module procedure spmv_coo_${rank}$d_${s1}$ + module procedure spmv_csr_${rank}$d_${s1}$ + module procedure spmv_csc_${rank}$d_${s1}$ + module procedure spmv_ell_${rank}$d_${s1}$ #:endfor - module procedure matvec_sellc_${s1}$ + module procedure spmv_sellc_${s1}$ #:endfor end interface contains - !> matvec_coo + !> spmv_coo #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(COO_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -78,10 +78,10 @@ contains #:endfor #:endfor - !! matvec_csr + !! spmv_csr #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(CSR_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -158,10 +158,10 @@ contains #:endfor #:endfor - !> matvec_csc + !> spmv_csc #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(CSC_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -222,10 +222,10 @@ contains #:endfor #:endfor - !> matvec_ell + !> spmv_ell #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine matvec_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(ELL_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -256,10 +256,10 @@ contains #:endfor #:endfor - !> matvec_sellc + !> spmv_sellc #:set CHUNKS = [4,8,16] #:for k1, t1, s1 in (KINDS_TYPES) - subroutine matvec_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) !> This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves type(SELLC_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x(:) @@ -336,4 +336,4 @@ contains #:endfor -end module stdlib_sparse_matvec \ No newline at end of file +end module stdlib_sparse_spmv \ No newline at end of file diff --git a/test/linalg/CMakeLists.txt b/test/linalg/CMakeLists.txt index 9a76d4b9e..20b7ab790 100644 --- a/test/linalg/CMakeLists.txt +++ b/test/linalg/CMakeLists.txt @@ -6,7 +6,7 @@ set( "test_linalg_lstsq.fypp" "test_linalg_determinant.fypp" "test_linalg_matrix_property_checks.fypp" - "test_sparse_matvec.fypp" + "test_sparse_spmv.fypp" ) fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) diff --git a/test/linalg/test_sparse_matvec.fypp b/test/linalg/test_sparse_spmv.fypp similarity index 95% rename from test/linalg/test_sparse_matvec.fypp rename to test/linalg/test_sparse_spmv.fypp index 91fd8907a..542679861 100644 --- a/test/linalg/test_sparse_matvec.fypp +++ b/test/linalg/test_sparse_spmv.fypp @@ -1,7 +1,7 @@ #:include "common.fypp" #:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX)) #:set KINDS_TYPES = R_KINDS_TYPES -module test_sparse_matvec +module test_sparse_spmv use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64 use stdlib_sparse @@ -55,7 +55,7 @@ contains call check(error, all(vec_y1 == real([6,11,15,15],kind=wp)) ) if (allocated(error)) return - call matvec( COO, vec_x, vec_y2 ) + call spmv( COO, vec_x, vec_y2 ) call check(error, all(vec_y1 == vec_y2) ) if (allocated(error)) return end block @@ -79,7 +79,7 @@ contains allocate( vec_x(5) , source = 1._wp ) allocate( vec_y(4) , source = 0._wp ) - call matvec( CSR, vec_x, vec_y ) + call spmv( CSR, vec_x, vec_y ) call check(error, all(vec_y == real([6,11,15,15],kind=wp)) ) if (allocated(error)) return @@ -104,7 +104,7 @@ contains allocate( vec_x(5) , source = 1._wp ) allocate( vec_y(4) , source = 0._wp ) - call matvec( CSC, vec_x, vec_y ) + call spmv( CSC, vec_x, vec_y ) call check(error, all(vec_y == real([6,11,15,15],kind=wp)) ) if (allocated(error)) return @@ -135,7 +135,7 @@ contains allocate( vec_x(5) , source = 1._wp ) allocate( vec_y(4) , source = 0._wp ) - call matvec( ELL, vec_x, vec_y ) + call spmv( ELL, vec_x, vec_y ) call check(error, all(vec_y == real([6,11,15,15],kind=wp)) ) if (allocated(error)) return @@ -172,7 +172,7 @@ contains allocate( vec_x(6) , source = 1._wp ) allocate( vec_y(6) , source = 0._wp ) - call matvec( SELLC, vec_x, vec_y ) + call spmv( SELLC, vec_x, vec_y ) call check(error, all(vec_y == real([6,22,27,23,27,48],kind=wp)) ) if (allocated(error)) return @@ -212,11 +212,11 @@ contains call check(error, all(vec_y1 == [3,5,5,3]) ) if (allocated(error)) return - call matvec( COO , vec_x, vec_y2 ) + call spmv( COO , vec_x, vec_y2 ) call check(error, all(vec_y1 == vec_y2) ) if (allocated(error)) return - call matvec( CSR , vec_x, vec_y3 ) + call spmv( CSR , vec_x, vec_y3 ) call check(error, all(vec_y1 == vec_y3) ) if (allocated(error)) return end block @@ -229,7 +229,7 @@ end module program tester use, intrinsic :: iso_fortran_env, only : error_unit use testdrive, only : run_testsuite, new_testsuite, testsuite_type - use test_sparse_matvec, only : collect_suite + use test_sparse_spmv, only : collect_suite implicit none integer :: stat, is type(testsuite_type), allocatable :: testsuites(:) From 6e679f5681f8f897d029f76e877ae4bf0db2af7d Mon Sep 17 00:00:00 2001 From: jalvesz Date: Fri, 14 Jun 2024 21:31:07 +0200 Subject: [PATCH 18/78] change storage identifier names --- doc/specs/stdlib_sparse.md | 6 +++--- src/stdlib_sparse_conversion.fypp | 6 +++--- src/stdlib_sparse_kinds.fypp | 10 +++++----- src/stdlib_sparse_spmv.fypp | 28 ++++++++++++++-------------- test/linalg/test_sparse_spmv.fypp | 2 +- 5 files changed, 26 insertions(+), 26 deletions(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 03ae9ae7f..45d5d1c99 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -35,9 +35,9 @@ The symmetry integer laber should be assigned from the module's internal enumera ```Fortran enum, bind(C) - enumerator :: k_NOSYMMETRY !> Full Sparse matrix (no symmetry considerations) - enumerator :: k_SYMTRIINF !> Symmetric Sparse matrix with triangular inferior storage - enumerator :: k_SYMTRISUP !> Symmetric Sparse matrix with triangular supperior storage + enumerator :: sparse_full !> Full Sparse matrix (no symmetry considerations) + enumerator :: sparse_lower !> Symmetric Sparse matrix with triangular inferior storage + enumerator :: sparse_upper !> Symmetric Sparse matrix with triangular supperior storage end enum ``` In the following, all sparse kinds will be presented in two main flavors: a data-less type `_type` useful for topological graph operations. And real/complex valued types `_` containing the `data` buffer for the matrix values. diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 053c8d170..d587108d3 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -115,7 +115,7 @@ contains integer :: i CSR%nnz = COO%nnz; CSR%nrows = COO%nrows; CSR%ncols = COO%ncols - CSR%base = COO%base; CSR%sym = COO%sym + CSR%base = COO%base; CSR%storage = COO%storage if( allocated(CSR%col) ) then CSR%col(1:COO%nnz) = COO%index(2,1:COO%nnz) @@ -145,7 +145,7 @@ contains integer :: i, j COO%nnz = CSR%nnz; COO%nrows = CSR%nrows; COO%ncols = CSR%ncols - COO%base = CSR%base; COO%sym = CSR%sym + COO%base = CSR%base; COO%storage = CSR%storage if( .not.allocated(COO%data) ) then allocate( COO%data(CSR%nnz) , source = CSR%data(1:CSR%nnz) ) @@ -177,7 +177,7 @@ contains if(present(chunk)) SELLC%chunk_size = chunk SELLC%nrows = CSR%nrows; SELLC%ncols = CSR%ncols - SELLC%base = CSR%base; SELLC%sym = CSR%sym + SELLC%base = CSR%base; SELLC%storage = CSR%storage associate( nrows=>SELLC%nrows, ncols=>SELLC%ncols, nnz=>SELLC%nnz, & & chunk_size=>SELLC%chunk_size ) !------------------------------------------- diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index d55d1e3f6..8d3b59e6d 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -13,11 +13,11 @@ module stdlib_sparse_kinds ! -- Global parameters enum, bind(C) - enumerator :: k_NOSYMMETRY !> Full Sparse matrix (no symmetry considerations) - enumerator :: k_SYMTRIINF !> Symmetric Sparse matrix with triangular inferior storage - enumerator :: k_SYMTRISUP !> Symmetric Sparse matrix with triangular supperior storage + enumerator :: sparse_full !> Full Sparse matrix (no symmetry considerations) + enumerator :: sparse_lower !> Symmetric Sparse matrix with triangular inferior storage + enumerator :: sparse_upper !> Symmetric Sparse matrix with triangular supperior storage end enum - public :: k_NOSYMMETRY, k_SYMTRIINF, k_SYMTRISUP + public :: sparse_full, sparse_lower, sparse_upper #:for k1, t1, s1 in (R_KINDS_TYPES) ${t1}$, parameter, public :: zero_${s1}$ = 0._${k1}$ @@ -35,7 +35,7 @@ module stdlib_sparse_kinds integer :: nrows = 0 !> number of rows integer :: ncols = 0 !> number of columns integer :: nnz = 0 !> number of non-zero values - integer :: sym = k_NOSYMMETRY !> assumed storage symmetry + integer :: storage = sparse_full !> assumed storage symmetry integer :: base = 1 !> index base = 0 for (C) or 1 (Fortran) end type diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index a74adccb9..9cd1a9e5b 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -54,8 +54,8 @@ contains else vec_y = zero_${s1}$ endif - associate( data => matrix%data, index => matrix%index, sym => matrix%sym, nnz => matrix%nnz ) - if( sym == k_NOSYMMETRY) then + associate( data => matrix%data, index => matrix%index, storage => matrix%storage, nnz => matrix%nnz ) + if( storage == sparse_full) then do concurrent (k = 1:nnz) ik = index(1,k) jk = index(2,k) @@ -101,8 +101,8 @@ contains if(present(beta)) beta_ = beta associate( data => matrix%data, col => matrix%col, rowptr => matrix%rowptr, & - & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) - if( sym == k_NOSYMMETRY) then + & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage ) + if( storage == sparse_full) then do i = 1, nrows aux = zero_${k1}$ do j = rowptr(i), rowptr(i+1)-1 @@ -115,7 +115,7 @@ contains end if end do - else if( sym == k_SYMTRIINF )then + else if( storage == sparse_lower )then do i = 1 , nrows aux = zero_${s1}$ aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i) @@ -132,7 +132,7 @@ contains end if end do - else if( sym == k_SYMTRISUP )then + else if( storage == sparse_upper )then do i = 1 , nrows aux = vec_x(${rksfx2(rank-1)}$i) * data(rowptr(i)) aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i) @@ -184,15 +184,15 @@ contains endif associate( data => matrix%data, colptr => matrix%colptr, row => matrix%row, & - & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) - if( sym == k_NOSYMMETRY) then + & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage ) + if( storage == sparse_full) then do concurrent(j=1:ncols) do i = colptr(j), colptr(j+1)-1 vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + alpha_ * data(i) * vec_x(${rksfx2(rank-1)}$j) end do end do - else if( sym == k_SYMTRIINF )then + else if( storage == sparse_lower )then ! NOT TESTED do j = 1 , ncols aux = vec_x(${rksfx2(rank-1)}$j) * data(colptr(j)) @@ -203,7 +203,7 @@ contains vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux end do - else if( sym == k_SYMTRISUP )then + else if( storage == sparse_upper )then ! NOT TESTED do j = 1 , ncols aux = zero_${s1}$ @@ -242,8 +242,8 @@ contains vec_y = zero_${s1}$ endif associate( data => matrix%data, index => matrix%index, MNZ_P_ROW => matrix%K, & - & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) - if( sym == k_NOSYMMETRY) then + & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage ) + if( storage == sparse_full) then do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW) j = index(i,k) if(j>0) vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$j) @@ -277,10 +277,10 @@ contains vec_y = zero_${s1}$ endif associate( data => matrix%data, ia => matrix%rowptr , ja => matrix%col, cs => matrix%chunk_size, & - & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, sym => matrix%sym ) + & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage ) num_chunks = nrows / cs rm = nrows - num_chunks * cs - if( sym == k_NOSYMMETRY) then + if( storage == sparse_full) then select case(cs) #:for chunk in CHUNKS diff --git a/test/linalg/test_sparse_spmv.fypp b/test/linalg/test_sparse_spmv.fypp index 542679861..62c146ba1 100644 --- a/test/linalg/test_sparse_spmv.fypp +++ b/test/linalg/test_sparse_spmv.fypp @@ -204,7 +204,7 @@ contains 0,0,2,1],kind=wp),[4,4]) ) call dense2coo( dense , COO ) - COO%sym = k_SYMTRISUP + COO%storage = sparse_upper call coo2csr(COO, CSR) dense(2,1) = 2._wp; dense(3,2) = 2._wp; dense(4,3) = 2._wp From 91e619aff076b62a17bb648b4f009a89653cdb5c Mon Sep 17 00:00:00 2001 From: jalvesz Date: Fri, 14 Jun 2024 23:25:45 +0200 Subject: [PATCH 19/78] add example with conversion and spmv --- doc/specs/stdlib_sparse.md | 7 ++++- example/linalg/example_sparse_spmv.f90 | 36 ++++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 1 deletion(-) create mode 100644 example/linalg/example_sparse_spmv.f90 diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 45d5d1c99..69c192645 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -225,4 +225,9 @@ This module provides facility functions for converting between storage formats. `sellc`, `intent(inout)`: Shall be a `SELLC` type of `real` or `complex` type. -`chunk`, `intent(in)`, `optional`: chunk size for the Sliced ELLPACK format. \ No newline at end of file +`chunk`, `intent(in)`, `optional`: chunk size for the Sliced ELLPACK format. + +## Example +```fortran +{!example/strings/example_sparse_spmv.f90!} +``` \ No newline at end of file diff --git a/example/linalg/example_sparse_spmv.f90 b/example/linalg/example_sparse_spmv.f90 new file mode 100644 index 000000000..9b30b35e2 --- /dev/null +++ b/example/linalg/example_sparse_spmv.f90 @@ -0,0 +1,36 @@ +program example_sparse_spmv + use stdlib_linalg_constants, only: dp + use stdlib_sparse + implicit none + + integer, parameter :: m = 4, n = 2 + real(dp) :: A(m,n), x(n) + real(dp) :: y_dense(m), y_coo(m), y_csr(m) + real(dp) :: alpha, beta + type(COO_dp) :: COO + type(CSR_dp) :: CSR + + call random_number(A) + ! Convert from dense to COO and CSR matrices + call dense2coo( A , COO ) + call coo2csr( COO , CSR ) + + ! Initialize vectors + x = 1._dp + y_dense = 2._dp + y_coo = y_dense + y_csr = y_dense + + ! Perform matrix-vector product + alpha = 3._dp; beta = 2._dp + y_dense = alpha * matmul(A,x) + beta * y_dense + call spmv( COO , x , y_coo , alpha = alpha, beta = beta ) + call spmv( CSR , x , y_csr , alpha = alpha, beta = beta ) + + print *, 'dense :', y_dense + print *, 'coo :', y_coo + print *, 'csr :', y_csr + + end program example_sparse_spmv + + \ No newline at end of file From 7117d16ac496d03eeb59077a46aca55bcab215a5 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Fri, 14 Jun 2024 23:27:10 +0200 Subject: [PATCH 20/78] fix example path --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 69c192645..312b8ba38 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -229,5 +229,5 @@ This module provides facility functions for converting between storage formats. ## Example ```fortran -{!example/strings/example_sparse_spmv.f90!} +{!example/linalg/example_sparse_spmv.f90!} ``` \ No newline at end of file From 5b0aadf534c33037e0bc3da65e8c7aee79dd541a Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 15 Jun 2024 12:10:34 +0200 Subject: [PATCH 21/78] make example runnable with cmake --- example/linalg/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/example/linalg/CMakeLists.txt b/example/linalg/CMakeLists.txt index e9ad22a03..1ede8d326 100644 --- a/example/linalg/CMakeLists.txt +++ b/example/linalg/CMakeLists.txt @@ -23,6 +23,7 @@ ADD_EXAMPLE(lstsq2) ADD_EXAMPLE(solve1) ADD_EXAMPLE(solve2) ADD_EXAMPLE(solve3) +ADD_EXAMPLE(sparse_spmv) ADD_EXAMPLE(svd) ADD_EXAMPLE(svdvals) ADD_EXAMPLE(determinant) From c0438f083587a4c43ee3962449b8f0c4d8b20cf9 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 15 Jun 2024 12:29:09 +0200 Subject: [PATCH 22/78] update spec --- doc/specs/stdlib_sparse.md | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 312b8ba38..aac2e31bc 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -23,24 +23,24 @@ The `sparse_type` is defined as an abstract derived type holding the basic commo ```Fortran type, public, abstract :: sparse_type - integer :: nrows !> number of rows - integer :: ncols !> number of columns - integer :: nnz !> number of non-zero values - integer :: sym !> assumed storage symmetry - integer :: base !> index base = 0 for (C) or 1 (Fortran) + integer :: nrows !> number of rows + integer :: ncols !> number of columns + integer :: nnz !> number of non-zero values + integer :: storage !> assumed storage symmetry + integer :: base !> index base = 0 for (C) or 1 (Fortran) end type ``` -The symmetry integer laber should be assigned from the module's internal enumerator containing the following three enums: +The storage integer label should be assigned from the module's internal enumerator containing the following three enums: ```Fortran enum, bind(C) - enumerator :: sparse_full !> Full Sparse matrix (no symmetry considerations) - enumerator :: sparse_lower !> Symmetric Sparse matrix with triangular inferior storage - enumerator :: sparse_upper !> Symmetric Sparse matrix with triangular supperior storage + enumerator :: sparse_full !> Full Sparse matrix (no symmetry considerations) + enumerator :: sparse_lower !> Symmetric Sparse matrix with triangular inferior storage + enumerator :: sparse_upper !> Symmetric Sparse matrix with triangular supperior storage end enum ``` -In the following, all sparse kinds will be presented in two main flavors: a data-less type `_type` useful for topological graph operations. And real/complex valued types `_` containing the `data` buffer for the matrix values. +In the following, all sparse kinds will be presented in two main flavors: a data-less type `_type` useful for topological graph operations. And real/complex valued types `_` containing the `data` buffer for the matrix values. The following rectangular matrix will be used to showcase how each sparse matrix holds the data internally: $$ M = \begin{bmatrix} 9 & 0 & 0 & 0 & -3 \\ @@ -55,7 +55,7 @@ $$ M = \begin{bmatrix} Experimental #### Description -The `COO`, triplet or `ijv` format defines all non-zero elements of the matrix by explicitly allocating the `i,j` index and the value of the matrix. +The `COO`, triplet or `ijv` format defines all non-zero elements of the matrix by explicitly allocating the `i,j` index and the value of the matrix. While some implementations use separate `row` and `col` arrays for the index, here we use a 2D array in order to promote fast memory acces to `ij`. ```Fortran type(COO_sp) :: COO From e18b3fcd3557ea34ee452f796f547b90e609eb50 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 15 Jun 2024 13:37:36 +0200 Subject: [PATCH 23/78] add coo2ordered procedure --- doc/specs/stdlib_sparse.md | 10 ++ src/stdlib_sparse_conversion.fypp | 219 ++++++++++++++++++++++++++++++ test/linalg/test_sparse_spmv.fypp | 37 +++++ 3 files changed, 266 insertions(+) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index aac2e31bc..b49cfd89a 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -177,6 +177,16 @@ This module provides facility functions for converting between storage formats. ### Syntax +`call ` [[stdlib_sparse_conversion(module):coo2ordered(interface)]] `(coo)` + +### Arguments + +`COO`, `intent(inout)`: Shall be any `COO` type. The same object will be returned with the arrays reallocated to the correct size after removing duplicates. + +`sort_data`, `logical(in)`, `optional`:: Boolean optional to determine whether to sort the data in the COO graph while sorting the index array, defult `.false.`. + +### Syntax + `call ` [[stdlib_sparse_conversion(module):dense2coo(interface)]] `(dense,coo)` ### Arguments diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index d587108d3..72eee8b51 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -13,6 +13,7 @@ module stdlib_sparse_conversion public :: dense2coo, coo2dense, coo2csr, csr2coo public :: csr2sellc + public :: coo2ordered !> Conversion from dense to coo !> @@ -63,6 +64,15 @@ module stdlib_sparse_conversion module procedure csr2sellc_${s1}$ #:endfor end interface + + !> Sort arrays of a COO matrix + !> + interface sort_coo + module procedure sort_coo_unique + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure sort_coo_unique_${s1}$ + #:endfor + end interface contains @@ -229,5 +239,214 @@ contains end subroutine #:endfor + + recursive subroutine quicksort_i(a, first, last) + ! ref: https://gist.github.com/t-nissie/479f0f16966925fa29ea + integer, intent(inout) :: a(*) + integer, intent(in) :: first, last + integer :: i, j, x, t + + x = a( (first+last) / 2 ) + i = first + j = last + do + do while (a(i) < x) + i=i+1 + end do + do while (x < a(j)) + j=j-1 + end do + if (i >= j) exit + t = a(i); a(i) = a(j); a(j) = t + i=i+1 + j=j-1 + end do + if (first < i-1) call quicksort_i(a, first, i-1) + if (j+1 < last) call quicksort_i(a, j+1, last) + end subroutine + + #:for k1, t1, s1 in (KINDS_TYPES) + recursive subroutine quicksort_i_${s1}$(a, b, first, last) + integer, parameter :: wp = sp + integer, intent(inout) :: a(*) !! reference table to sort + ${t1}$, intent(inout) :: b(*) !! secondary real data to sort w.r.t. a + integer, intent(in) :: first, last + integer :: i, j, x, t + ${t1}$ :: d + + x = a( (first+last) / 2 ) + i = first + j = last + do + do while (a(i) < x) + i=i+1 + end do + do while (x < a(j)) + j=j-1 + end do + if (i >= j) exit + t = a(i); a(i) = a(j); a(j) = t + d = b(i); b(i) = b(j); b(j) = d + i=i+1 + j=j-1 + end do + if (first < i-1) call quicksort_i_${s1}$(a, b, first, i-1) + if (j+1 < last) call quicksort_i_${s1}$(a, b, j+1, last) + end subroutine + + #:endfor + + subroutine sort_coo_unique( a, n, num_rows, num_cols ) + !! Sort a 2d array in increasing order first by index 1 and then by index 2 + integer, intent(inout) :: a(2,*) + integer, intent(inout) :: n + integer, intent(in) :: num_rows + integer, intent(in) :: num_cols + + integer :: stride, adr0, adr1, dd + integer :: n_i, pos, ed + integer, allocatable :: count_i(:), count_i_aux(:), rows_(:), cols_(:) + !--------------------------------------------------------- + ! Sort a first time with respect to first index using count sort + allocate( count_i( 0:num_rows ) , source = 0 ) + do ed = 1, n + count_i( a(1,ed) ) = count_i( a(1,ed) ) + 1 + end do + do n_i = 2, num_rows + count_i(n_i) = count_i(n_i) + count_i(n_i-1) + end do + allocate( count_i_aux( 0:num_rows ) , source = count_i ) + + allocate( rows_(n), cols_(n) ) + do ed = n, 1, -1 + n_i = a(1,ed) + pos = count_i(n_i) + rows_(pos) = a(1,ed) + cols_(pos) = a(2,ed) + count_i(n_i) = count_i(n_i) - 1 + end do + !--------------------------------------------------------- + ! Sort with respect to second column + do n_i = 1, num_rows + adr0 = count_i_aux(n_i-1)+1 + adr1 = count_i_aux(n_i) + dd = adr1-adr0+1 + if(dd>0) call quicksort_i(cols_(adr0),1,dd) + end do + !--------------------------------------------------------- + ! Remove duplicates + do ed = 1,n + a(1:2,ed) = [rows_(ed),cols_(ed)] + end do + stride = 0 + do ed = 2, n + if( a(1,ed) == a(1,ed-1) .and. a(2,ed) == a(2,ed-1) ) then + stride = stride + 1 + else + a(1:2,ed-stride) = a(1:2,ed) + end if + end do + n = n - stride + end subroutine + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine sort_coo_unique_${s1}$( a, data, n, num_rows, num_cols ) + !! Sort a 2d array in increasing order first by index 1 and then by index 2 + integer, parameter :: wp = ${k1}$ + ${t1}$, intent(inout) :: data(*) + integer, intent(inout) :: a(2,*) + integer, intent(inout) :: n + integer, intent(in) :: num_rows + integer, intent(in) :: num_cols + + integer :: stride, adr0, adr1, dd + integer :: n_i, pos, ed + integer, allocatable :: count_i(:), count_i_aux(:), rows_(:), cols_(:) + ${t1}$, allocatable :: temp(:) + !--------------------------------------------------------- + ! Sort a first time with respect to first index using Count sort + allocate( count_i( 0:num_rows ) , source = 0 ) + do ed = 1, n + count_i( a(1,ed) ) = count_i( a(1,ed) ) + 1 + end do + do n_i = 2, num_rows + count_i(n_i) = count_i(n_i) + count_i(n_i-1) + end do + allocate( count_i_aux( 0:num_rows ) , source = count_i ) + + allocate( rows_(n), cols_(n), temp(n) ) + do ed = n, 1, -1 + n_i = a(1,ed) + pos = count_i(n_i) + rows_(pos) = a(1,ed) + cols_(pos) = a(2,ed) + temp(pos) = data(ed) + count_i(n_i) = count_i(n_i) - 1 + end do + !--------------------------------------------------------- + ! Sort with respect to second colum using a quicksort + do n_i = 1, num_rows + adr0 = count_i_aux(n_i-1)+1 + adr1 = count_i_aux(n_i) + dd = adr1-adr0+1 + if(dd>0) call quicksort_i_${s1}$(cols_(adr0),temp(adr0),1,dd) + end do + !--------------------------------------------------------- + ! Remove duplicates + do ed = 1,n + a(1:2,ed) = [rows_(ed),cols_(ed)] + end do + data(1:n) = temp(1:n) + stride = 0 + do ed = 2, n + if( a(1,ed) == a(1,ed-1) .and. a(2,ed) == a(2,ed-1) ) then + data(ed-1-stride) = data(ed-1-stride) + data(ed) + data(ed) = data(ed-1-stride) + stride = stride + 1 + else + a(1:2,ed-stride) = a(1:2,ed) + data(ed-stride) = data(ed) + end if + end do + n = n - stride + end subroutine + + #:endfor + + subroutine coo2ordered(COO,sort_data) + class(COO_type), intent(inout) :: COO + logical, intent(in), optional :: sort_data + integer, allocatable :: itemp(:,:) + logical :: sort_data_ + + if(COO%isOrdered) return + + sort_data_ = .false. + if(present(sort_data)) sort_data_ = sort_data + + select type (COO) + type is( COO_type ) + call sort_coo(COO%index, COO%nnz, COO%nrows, COO%ncols) + #:for k1, t1, s1 in (KINDS_TYPES) + type is( COO_${s1}$ ) + block + ${t1}$, allocatable :: temp(:) + if( sort_data_ ) then + call sort_coo(COO%index, COO%data, COO%nnz, COO%nrows, COO%ncols) + allocate( temp(COO%nnz) , source=COO%data(1:COO%nnz) ) + else + call sort_coo(COO%index, COO%nnz, COO%nrows, COO%ncols) + allocate( temp(COO%nnz) ) + end if + call move_alloc( temp , COO%data ) + end block + #:endfor + end select + + allocate( itemp(2,COO%nnz) , source=COO%index(1:2,1:COO%nnz) ) + call move_alloc( itemp , COO%index ) + + COO%isOrdered = .true. + end subroutine end module stdlib_sparse_conversion \ No newline at end of file diff --git a/test/linalg/test_sparse_spmv.fypp b/test/linalg/test_sparse_spmv.fypp index 62c146ba1..deda95fec 100644 --- a/test/linalg/test_sparse_spmv.fypp +++ b/test/linalg/test_sparse_spmv.fypp @@ -18,6 +18,7 @@ contains testsuite = [ & new_unittest('coo', test_coo), & + new_unittest('coo2ordered', test_coo2ordered), & new_unittest('csr', test_csr), & new_unittest('csc', test_csc), & new_unittest('ell', test_ell), & @@ -62,6 +63,42 @@ contains #:endfor end subroutine + subroutine test_coo2ordered(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(COO_sp) :: COO + + call COO%malloc(4,4,12) + COO%data(:) = 1 + COO%index(:,1) = [1,2] + COO%index(:,2) = [1,3] + COO%index(:,3) = [1,4] + COO%index(:,4) = [2,3] + COO%index(:,5) = [2,4] + COO%index(:,6) = [3,4] + + COO%index(:,7) = [2,3] + COO%index(:,8) = [2,4] + COO%index(:,9) = [2,5] + COO%index(:,10) = [3,4] + COO%index(:,11) = [3,5] + COO%index(:,12) = [4,5] + + call coo2ordered(COO,sort_data=.true.) + call check(error, COO%nnz < 12 .and. COO%nnz == 9 ) + if (allocated(error)) return + + call check(error, all(COO%data==[1,1,1,2,2,1,2,1,1]) ) + if (allocated(error)) return + + call check(error, all(COO%index(1,:)==[1,1,1,2,2,2,3,3,4]) ) + if (allocated(error)) return + + call check(error, all(COO%index(2,:)==[2,3,4,3,4,5,4,5,5]) ) + if (allocated(error)) return + + end subroutine + subroutine test_csr(error) !> Error handling type(error_type), allocatable, intent(out) :: error From 79534b35ec7839a563922d527e81efb30e105d41 Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Wed, 19 Jun 2024 12:52:44 +0200 Subject: [PATCH 24/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Federico Perini --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index b49cfd89a..89c169659 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -8,7 +8,7 @@ title: sparse ## Introduction -The `stdlib_sparse` module provides several derived types defining known sparse matrix data structures. It also provides basic sparse kernels such as sparse matrix vector and conversion between matrix types. +The `stdlib_sparse` module provides derived types for standard sparse matrix data structures. It also provides math kernels such as sparse matrix-vector product and conversion between matrix types. ## Derived types provided From 5f35174ac00fcd86be8068e35344447fab954dbc Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Wed, 19 Jun 2024 12:52:55 +0200 Subject: [PATCH 25/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Federico Perini --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 89c169659..d7c5705f0 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -10,7 +10,7 @@ title: sparse The `stdlib_sparse` module provides derived types for standard sparse matrix data structures. It also provides math kernels such as sparse matrix-vector product and conversion between matrix types. -## Derived types provided +## Sparse matrix derived types ### The `sparse_type` abstract derived type From b3de0160d2400db3304df2efa9fc0e6e5850f1f2 Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Wed, 19 Jun 2024 12:53:24 +0200 Subject: [PATCH 26/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Federico Perini --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index d7c5705f0..71be0334f 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -19,7 +19,7 @@ The `stdlib_sparse` module provides derived types for standard sparse matrix dat Experimental #### Description -The `sparse_type` is defined as an abstract derived type holding the basic common meta data needed to define a sparse matrix. All other sparse types falvors are derived from the `sparse_type`. +The parent `sparse_type` is as an abstract derived type holding the basic common meta data needed to define a sparse matrix, as well as shared APIs. All sparse matrix flavors are extended from the `sparse_type`. ```Fortran type, public, abstract :: sparse_type From 181760b7d34e93f099b7bb9bee19e21cbfa5826c Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Wed, 19 Jun 2024 12:53:51 +0200 Subject: [PATCH 27/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Federico Perini --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 71be0334f..9bc2dafe7 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -79,7 +79,7 @@ COO%index(1:2,10) = [4,4] Experimental #### Description -The Compressed Sparse Row or Yale format `CSR` stores the matrix index by compressing the row indeces with a counter pointer `rowptr` enabling to know the first and last non-zero colum index `col` of the given row. +The Compressed Sparse Row or Yale format `CSR` stores the matrix structure by compressing the row indices with a counter pointer `rowptr` enabling to know the first and last non-zero column index `col` of the given row. ```Fortran type(CSR_sp) :: CSR From 147a5c97478ab449267eaf7c78fe077f1698a898 Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Wed, 19 Jun 2024 12:54:11 +0200 Subject: [PATCH 28/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Federico Perini --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 9bc2dafe7..118d46107 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -95,7 +95,7 @@ CSR%rowptr(:) = [1,3,5,8,11] Experimental #### Description -The Compressed Sparse Colum `CSC` is similar to the `CSR` format but values are accesed first by colum, thus an index counter is given by `colptr` which enables accessing the start and ending rows of a given colum in the `row` index table. +The Compressed Sparse Colum `CSC` is similar to the `CSR` format but values are accesed first by column, thus an index counter is given by `colptr` which enables accessing the start and ending rows of a given colum in the `row` index table. ```Fortran type(CSC_sp) :: CSC From c832eebd010ab6bf2390048833b39d5f5d4d8731 Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Wed, 19 Jun 2024 12:54:32 +0200 Subject: [PATCH 29/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Federico Perini --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 118d46107..b31aa4e3d 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -111,7 +111,7 @@ CSC%colptr(:) = [1,4,6,8,10,11] Experimental #### Description -The `ELL` format stores the data in a dense matrix of $nrows \times K$ in column major order. By imposing a constant number of zeros per row $K$, this format will incure in additional zeros being stored, but it enables efficient vectorization as memory acces are carried out by constant sized strides. +The `ELL` format stores data in a dense matrix of $nrows \times K$ in column major order. By imposing a constant number of zeros per row $K$, this format will incur in additional zeros being stored, but it enables efficient vectorization as memory acces is carried out by constant sized strides. ```Fortran type(ELL_sp) :: ELL From 22a70b1912c3c368dcbb7dcf93b60621ac7918d3 Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Wed, 19 Jun 2024 12:54:48 +0200 Subject: [PATCH 30/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Federico Perini --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index b31aa4e3d..5f5cc33d3 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -133,7 +133,7 @@ ELL%index(4,1:3) = [1,3,4] Experimental #### Description -The Sliced ELLPACK format `SELLC` is a variation of the `ELLPACK` format. This modification reduces the storage size compared to the `ELLPACK` format but maintaining its efficient data access scheme. It can be seen as an intermediate format between `CSR` and `ELLPACK`. For more details read [here](https://arxiv.org/pdf/1307.6209v1) +The Sliced ELLPACK format `SELLC` is a variation of the `ELLPACK` format. This modification reduces the storage size compared to the `ELLPACK` format but maintaining its efficient data access scheme. It can be seen as an intermediate format between `CSR` and `ELLPACK`. For more details read [the reference](https://arxiv.org/pdf/1307.6209v1) ## `spmv` - Sparse Matrix-Vector product From 92233453e35e075c693d9beed294ffdd4cbdf6db Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Wed, 19 Jun 2024 12:56:38 +0200 Subject: [PATCH 31/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Federico Perini --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 5f5cc33d3..c103fd915 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -183,7 +183,7 @@ This module provides facility functions for converting between storage formats. `COO`, `intent(inout)`: Shall be any `COO` type. The same object will be returned with the arrays reallocated to the correct size after removing duplicates. -`sort_data`, `logical(in)`, `optional`:: Boolean optional to determine whether to sort the data in the COO graph while sorting the index array, defult `.false.`. +`sort_data`, `logical(in)`, `optional`:: Shall be an optional `logical` argument to determine whether data in the COO graph should be sorted while sorting the index array, defult `.false.`. ### Syntax From 827a1efe9b9fba743d7f93915dddb8d20f77dee2 Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Wed, 19 Jun 2024 13:11:31 +0200 Subject: [PATCH 32/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Ivan Pribec --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index c103fd915..092cc8be8 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -183,7 +183,7 @@ This module provides facility functions for converting between storage formats. `COO`, `intent(inout)`: Shall be any `COO` type. The same object will be returned with the arrays reallocated to the correct size after removing duplicates. -`sort_data`, `logical(in)`, `optional`:: Shall be an optional `logical` argument to determine whether data in the COO graph should be sorted while sorting the index array, defult `.false.`. +`sort_data`, `logical(in)`, `optional`:: Shall be an optional `logical` argument to determine whether data in the COO graph should be sorted while sorting the index array, default `.false.`. ### Syntax From 21a8547d2eec103fe04a6a825b8994a4cac71c5d Mon Sep 17 00:00:00 2001 From: jalvesz Date: Wed, 19 Jun 2024 21:24:09 +0200 Subject: [PATCH 33/78] change get_value to function and add NaN if out of bounds --- src/stdlib_sparse_kinds.fypp | 47 ++++++++++++++++++++++++------------ 1 file changed, 32 insertions(+), 15 deletions(-) diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 8d3b59e6d..0e271d0d4 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -6,6 +6,7 @@ !> ! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose module stdlib_sparse_kinds + use ieee_arithmetic use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp implicit none @@ -13,9 +14,9 @@ module stdlib_sparse_kinds ! -- Global parameters enum, bind(C) - enumerator :: sparse_full !> Full Sparse matrix (no symmetry considerations) - enumerator :: sparse_lower !> Symmetric Sparse matrix with triangular inferior storage - enumerator :: sparse_upper !> Symmetric Sparse matrix with triangular supperior storage + enumerator :: sparse_full !> Full Sparse matrix (no symmetry considerations) + enumerator :: sparse_lower !> Symmetric Sparse matrix with triangular inferior storage + enumerator :: sparse_upper !> Symmetric Sparse matrix with triangular supperior storage end enum public :: sparse_full, sparse_lower, sparse_upper @@ -290,12 +291,16 @@ contains !================================================================== #:for k1, t1, s1 in (KINDS_TYPES) - pure subroutine get_value_coo_${s1}$(self,val,ik,jk) + pure function get_value_coo_${s1}$(self,ik,jk) result(val) class(COO_${s1}$), intent(in) :: self - ${t1}$, intent(out) :: val + ${t1}$ :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation + if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then + val = ieee_value( 0._${k1}$ , ieee_quiet_nan) + return + end if do k = 1,self%nnz if( ik == self%index(1,k) .and. jk == self%index(2,k) ) then val = self%data(k) @@ -303,7 +308,7 @@ contains end if end do val = zero_${s1}$ - end subroutine + end function subroutine set_value_coo_${s1}$(self,val,ik,jk) class(COO_${s1}$), intent(inout) :: self @@ -322,12 +327,16 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - pure subroutine get_value_csr_${s1}$(self,val,ik,jk) + pure function get_value_csr_${s1}$(self,ik,jk) result(val) class(CSR_${s1}$), intent(in) :: self - ${t1}$, intent(out) :: val + ${t1}$ :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation + if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then + val = ieee_value( 0._${k1}$ , ieee_quiet_nan) + return + end if do k = self%rowptr(ik), self%rowptr(ik+1)-1 if( jk == self%col(k) ) then val = self%data(k) @@ -335,7 +344,7 @@ contains end if end do val = zero_${s1}$ - end subroutine + end function subroutine set_value_csr_${s1}$(self,val,ik,jk) class(CSR_${s1}$), intent(inout) :: self @@ -354,12 +363,16 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - pure subroutine get_value_csc_${s1}$(self,val,ik,jk) + pure function get_value_csc_${s1}$(self,ik,jk) result(val) class(CSC_${s1}$), intent(in) :: self - ${t1}$, intent(out) :: val + ${t1}$ :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation + if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then + val = ieee_value( 0._${k1}$ , ieee_quiet_nan) + return + end if do k = self%colptr(jk), self%colptr(jk+1)-1 if( ik == self%row(k) ) then val = self%data(k) @@ -367,7 +380,7 @@ contains end if end do val = zero_${s1}$ - end subroutine + end function subroutine set_value_csc_${s1}$(self,val,ik,jk) class(CSC_${s1}$), intent(inout) :: self @@ -386,12 +399,16 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - pure subroutine get_value_ell_${s1}$(self,val,ik,jk) + pure function get_value_ell_${s1}$(self,ik,jk) result(val) class(ELL_${s1}$), intent(in) :: self - ${t1}$, intent(out) :: val + ${t1}$ :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation + if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then + val = ieee_value( 0._${k1}$ , ieee_quiet_nan) + return + end if do k = 1 , self%K if( jk == self%index(ik,k) ) then val = self%data(ik,k) @@ -399,7 +416,7 @@ contains end if end do val = zero_${s1}$ - end subroutine + end function subroutine set_value_ell_${s1}$(self,val,ik,jk) class(ELL_${s1}$), intent(inout) :: self From da9f1714df743d4f82f3259e00f56c4761c8a18c Mon Sep 17 00:00:00 2001 From: jalvesz Date: Wed, 19 Jun 2024 21:42:34 +0200 Subject: [PATCH 34/78] change is ordered by is_sorted --- src/stdlib_sparse_conversion.fypp | 6 +++--- src/stdlib_sparse_kinds.fypp | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 72eee8b51..f3431bdbf 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -99,7 +99,7 @@ contains idx = idx + 1 end do end do - COO%isOrdered = .true. + COO%is_sorted = .true. end subroutine #:endfor @@ -419,7 +419,7 @@ contains integer, allocatable :: itemp(:,:) logical :: sort_data_ - if(COO%isOrdered) return + if(COO%is_sorted) return sort_data_ = .false. if(present(sort_data)) sort_data_ = sort_data @@ -446,7 +446,7 @@ contains allocate( itemp(2,COO%nnz) , source=COO%index(1:2,1:COO%nnz) ) call move_alloc( itemp , COO%index ) - COO%isOrdered = .true. + COO%is_sorted = .true. end subroutine end module stdlib_sparse_conversion \ No newline at end of file diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 0e271d0d4..759bcc27f 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -42,7 +42,7 @@ module stdlib_sparse_kinds !> COO: COOrdinates compresed format type, public, extends(sparse_type) :: COO_type - logical :: isOrdered = .false. !> wether the matrix is ordered or not + logical :: is_sorted = .false. !> wether the matrix is ordered or not integer, allocatable :: index(:,:) !> Matrix coordinates index(2,nnz) contains procedure :: malloc => malloc_coo From 1cbb982b0811b17dc6de7953cb818d4d032f4fff Mon Sep 17 00:00:00 2001 From: jalvesz Date: Wed, 19 Jun 2024 21:48:14 +0200 Subject: [PATCH 35/78] remove unused base attribute --- doc/specs/stdlib_sparse.md | 1 - src/stdlib_sparse_kinds.fypp | 1 - 2 files changed, 2 deletions(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 092cc8be8..e888ec1bf 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -27,7 +27,6 @@ type, public, abstract :: sparse_type integer :: ncols !> number of columns integer :: nnz !> number of non-zero values integer :: storage !> assumed storage symmetry - integer :: base !> index base = 0 for (C) or 1 (Fortran) end type ``` diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 759bcc27f..8d8ce7eb5 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -37,7 +37,6 @@ module stdlib_sparse_kinds integer :: ncols = 0 !> number of columns integer :: nnz = 0 !> number of non-zero values integer :: storage = sparse_full !> assumed storage symmetry - integer :: base = 1 !> index base = 0 for (C) or 1 (Fortran) end type !> COO: COOrdinates compresed format From a3c155a4021f0070f7622886169908d80db92319 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Thu, 20 Jun 2024 21:16:32 +0200 Subject: [PATCH 36/78] forgotten base attribute --- src/stdlib_sparse_conversion.fypp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index f3431bdbf..d089e7f87 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -125,7 +125,7 @@ contains integer :: i CSR%nnz = COO%nnz; CSR%nrows = COO%nrows; CSR%ncols = COO%ncols - CSR%base = COO%base; CSR%storage = COO%storage + CSR%storage = COO%storage if( allocated(CSR%col) ) then CSR%col(1:COO%nnz) = COO%index(2,1:COO%nnz) @@ -155,7 +155,7 @@ contains integer :: i, j COO%nnz = CSR%nnz; COO%nrows = CSR%nrows; COO%ncols = CSR%ncols - COO%base = CSR%base; COO%storage = CSR%storage + COO%storage = CSR%storage if( .not.allocated(COO%data) ) then allocate( COO%data(CSR%nnz) , source = CSR%data(1:CSR%nnz) ) @@ -187,7 +187,7 @@ contains if(present(chunk)) SELLC%chunk_size = chunk SELLC%nrows = CSR%nrows; SELLC%ncols = CSR%ncols - SELLC%base = CSR%base; SELLC%storage = CSR%storage + SELLC%storage = CSR%storage associate( nrows=>SELLC%nrows, ncols=>SELLC%ncols, nnz=>SELLC%nnz, & & chunk_size=>SELLC%chunk_size ) !------------------------------------------- From 2fb4e83c3835c4a2ef67c15dc0a6a7112c132c59 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Fri, 21 Jun 2024 20:09:38 +0200 Subject: [PATCH 37/78] make set/get non_overridable --- src/stdlib_sparse_kinds.fypp | 36 ++++++++++++++++-------------------- 1 file changed, 16 insertions(+), 20 deletions(-) diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 8d8ce7eb5..ea47f181f 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -51,8 +51,8 @@ module stdlib_sparse_kinds type, public, extends(COO_type) :: COO_${s1}$ ${t1}$, allocatable :: data(:) contains - procedure :: get => get_value_coo_${s1}$ - procedure :: set => set_value_coo_${s1}$ + procedure, non_overridable :: get => get_value_coo_${s1}$ + procedure, non_overridable :: set => set_value_coo_${s1}$ end type #:endfor @@ -68,8 +68,8 @@ module stdlib_sparse_kinds type, public, extends(CSR_type) :: CSR_${s1}$ ${t1}$, allocatable :: data(:) contains - procedure :: get => get_value_csr_${s1}$ - procedure :: set => set_value_csr_${s1}$ + procedure, non_overridable :: get => get_value_csr_${s1}$ + procedure, non_overridable :: set => set_value_csr_${s1}$ end type #:endfor @@ -85,8 +85,8 @@ module stdlib_sparse_kinds type, public, extends(CSC_type) :: CSC_${s1}$ ${t1}$, allocatable :: data(:) contains - procedure :: get => get_value_csc_${s1}$ - procedure :: set => set_value_csc_${s1}$ + procedure, non_overridable :: get => get_value_csc_${s1}$ + procedure, non_overridable :: set => set_value_csc_${s1}$ end type #:endfor @@ -102,8 +102,8 @@ module stdlib_sparse_kinds type, public, extends(ELL_type) :: ELL_${s1}$ ${t1}$, allocatable :: data(:,:) contains - procedure :: get => get_value_ell_${s1}$ - procedure :: set => set_value_ell_${s1}$ + procedure, non_overridable :: get => get_value_ell_${s1}$ + procedure, non_overridable :: set => set_value_ell_${s1}$ end type #:endfor @@ -290,9 +290,8 @@ contains !================================================================== #:for k1, t1, s1 in (KINDS_TYPES) - pure function get_value_coo_${s1}$(self,ik,jk) result(val) + pure ${t1}$ function get_value_coo_${s1}$(self,ik,jk) result(val) class(COO_${s1}$), intent(in) :: self - ${t1}$ :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation @@ -309,7 +308,7 @@ contains val = zero_${s1}$ end function - subroutine set_value_coo_${s1}$(self,val,ik,jk) + subroutine set_value_coo_${s1}$(self,ik,jk,val) class(COO_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk @@ -326,9 +325,8 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - pure function get_value_csr_${s1}$(self,ik,jk) result(val) + pure ${t1}$ function get_value_csr_${s1}$(self,ik,jk) result(val) class(CSR_${s1}$), intent(in) :: self - ${t1}$ :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation @@ -345,7 +343,7 @@ contains val = zero_${s1}$ end function - subroutine set_value_csr_${s1}$(self,val,ik,jk) + subroutine set_value_csr_${s1}$(self,ik,jk,val) class(CSR_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk @@ -362,9 +360,8 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - pure function get_value_csc_${s1}$(self,ik,jk) result(val) + pure ${t1}$ function get_value_csc_${s1}$(self,ik,jk) result(val) class(CSC_${s1}$), intent(in) :: self - ${t1}$ :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation @@ -381,7 +378,7 @@ contains val = zero_${s1}$ end function - subroutine set_value_csc_${s1}$(self,val,ik,jk) + subroutine set_value_csc_${s1}$(self,ik,jk,val) class(CSC_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk @@ -398,9 +395,8 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - pure function get_value_ell_${s1}$(self,ik,jk) result(val) + pure ${t1}$ function get_value_ell_${s1}$(self,ik,jk) result(val) class(ELL_${s1}$), intent(in) :: self - ${t1}$ :: val integer, intent(in) :: ik, jk integer :: k ! naive implementation @@ -417,7 +413,7 @@ contains val = zero_${s1}$ end function - subroutine set_value_ell_${s1}$(self,val,ik,jk) + subroutine set_value_ell_${s1}$(self,ik,jk,val) class(ELL_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk From e78c0269f26327f40478b8ca0550502eff27e67c Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sun, 23 Jun 2024 15:58:53 +0200 Subject: [PATCH 38/78] replace quicksort 1D by stdlib sort --- src/stdlib_sparse_conversion.fypp | 28 ++-------------------------- 1 file changed, 2 insertions(+), 26 deletions(-) diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index d089e7f87..8e87bb801 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -8,6 +8,7 @@ module stdlib_sparse_conversion use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp use stdlib_sparse_kinds + use stdlib_sorting, only: sort implicit none private @@ -240,31 +241,6 @@ contains #:endfor - recursive subroutine quicksort_i(a, first, last) - ! ref: https://gist.github.com/t-nissie/479f0f16966925fa29ea - integer, intent(inout) :: a(*) - integer, intent(in) :: first, last - integer :: i, j, x, t - - x = a( (first+last) / 2 ) - i = first - j = last - do - do while (a(i) < x) - i=i+1 - end do - do while (x < a(j)) - j=j-1 - end do - if (i >= j) exit - t = a(i); a(i) = a(j); a(j) = t - i=i+1 - j=j-1 - end do - if (first < i-1) call quicksort_i(a, first, i-1) - if (j+1 < last) call quicksort_i(a, j+1, last) - end subroutine - #:for k1, t1, s1 in (KINDS_TYPES) recursive subroutine quicksort_i_${s1}$(a, b, first, last) integer, parameter :: wp = sp @@ -331,7 +307,7 @@ contains adr0 = count_i_aux(n_i-1)+1 adr1 = count_i_aux(n_i) dd = adr1-adr0+1 - if(dd>0) call quicksort_i(cols_(adr0),1,dd) + if(dd>0) call sort(cols_(adr0:adr1)) end do !--------------------------------------------------------- ! Remove duplicates From f25e07ddd5fb982a03c49abaf8c05f74511ed6fe Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Thu, 27 Jun 2024 15:47:36 +0200 Subject: [PATCH 39/78] Setter procedure name change to 'add' covering scalar and array data --- src/stdlib_sparse_kinds.fypp | 150 +++++++++++++++++++++++++++++------ 1 file changed, 125 insertions(+), 25 deletions(-) diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index ea47f181f..b28c255a0 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -41,7 +41,7 @@ module stdlib_sparse_kinds !> COO: COOrdinates compresed format type, public, extends(sparse_type) :: COO_type - logical :: is_sorted = .false. !> wether the matrix is ordered or not + logical :: is_sorted = .false. !> whether the matrix is sorted or not integer, allocatable :: index(:,:) !> Matrix coordinates index(2,nnz) contains procedure :: malloc => malloc_coo @@ -52,7 +52,9 @@ module stdlib_sparse_kinds ${t1}$, allocatable :: data(:) contains procedure, non_overridable :: get => get_value_coo_${s1}$ - procedure, non_overridable :: set => set_value_coo_${s1}$ + procedure, non_overridable :: add_value => add_value_coo_${s1}$ + procedure, non_overridable :: add_block => add_block_coo_${s1}$ + generic :: add => add_value, add_block end type #:endfor @@ -69,7 +71,9 @@ module stdlib_sparse_kinds ${t1}$, allocatable :: data(:) contains procedure, non_overridable :: get => get_value_csr_${s1}$ - procedure, non_overridable :: set => set_value_csr_${s1}$ + procedure, non_overridable :: add_value => add_value_csr_${s1}$ + procedure, non_overridable :: add_block => add_block_csr_${s1}$ + generic :: add => add_value, add_block end type #:endfor @@ -86,7 +90,9 @@ module stdlib_sparse_kinds ${t1}$, allocatable :: data(:) contains procedure, non_overridable :: get => get_value_csc_${s1}$ - procedure, non_overridable :: set => set_value_csc_${s1}$ + procedure, non_overridable :: add_value => add_value_csc_${s1}$ + procedure, non_overridable :: add_block => add_block_csc_${s1}$ + generic :: add => add_value, add_block end type #:endfor @@ -103,7 +109,9 @@ module stdlib_sparse_kinds ${t1}$, allocatable :: data(:,:) contains procedure, non_overridable :: get => get_value_ell_${s1}$ - procedure, non_overridable :: set => set_value_ell_${s1}$ + procedure, non_overridable :: add_value => add_value_ell_${s1}$ + procedure, non_overridable :: add_block => add_block_ell_${s1}$ + generic :: add => add_value, add_block end type #:endfor @@ -293,14 +301,20 @@ contains pure ${t1}$ function get_value_coo_${s1}$(self,ik,jk) result(val) class(COO_${s1}$), intent(in) :: self integer, intent(in) :: ik, jk - integer :: k + integer :: k, ik_, jk_ + logical :: transpose ! naive implementation if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then val = ieee_value( 0._${k1}$ , ieee_quiet_nan) return end if - do k = 1,self%nnz - if( ik == self%index(1,k) .and. jk == self%index(2,k) ) then + ik_ = ik; jk_ = jk + transpose = (self%storage == sparse_lower .and. ik > jk) .or. (self%storage == sparse_upper .and. ik < jk) + if(transpose) then ! allow extraction of symmetric elements + ik_ = jk; jk_ = ik + end if + do k = 1, self%nnz + if( ik_ == self%index(1,k) .and. jk_ == self%index(2,k) ) then val = self%data(k) return end if @@ -308,7 +322,7 @@ contains val = zero_${s1}$ end function - subroutine set_value_coo_${s1}$(self,ik,jk,val) + subroutine add_value_coo_${s1}$(self,ik,jk,val) class(COO_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk @@ -316,26 +330,49 @@ contains ! naive implementation do k = 1,self%nnz if( ik == self%index(1,k) .and. jk == self%index(2,k) ) then - self%data(k) = val + self%data(k) = self%data(k) + val return end if end do end subroutine + subroutine add_block_coo_${s1}$(self,ik,jk,val) + class(COO_${s1}$), intent(inout) :: self + ${t1}$, intent(in) :: val(:,:) + integer, intent(in) :: ik(:), jk(:) + integer :: k, i, j + ! naive implementation + do k = 1, self%nnz + do i = 1, size(ik) + if( ik(i) /= self%index(1,k) ) cycle + do j = 1, size(jk) + if( jk(j) /= self%index(2,k) ) cycle + self%data(k) = self%data(k) + val(i,j) + end do + end do + end do + end subroutine + #:endfor #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function get_value_csr_${s1}$(self,ik,jk) result(val) class(CSR_${s1}$), intent(in) :: self integer, intent(in) :: ik, jk - integer :: k + integer :: k, ik_, jk_ + logical :: transpose ! naive implementation if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then val = ieee_value( 0._${k1}$ , ieee_quiet_nan) return end if - do k = self%rowptr(ik), self%rowptr(ik+1)-1 - if( jk == self%col(k) ) then + ik_ = ik; jk_ = jk + transpose = (self%storage == sparse_lower .and. ik > jk) .or. (self%storage == sparse_upper .and. ik < jk) + if(transpose) then ! allow extraction of symmetric elements + ik_ = jk; jk_ = ik + end if + do k = self%rowptr(ik_), self%rowptr(ik_+1)-1 + if( jk_ == self%col(k) ) then val = self%data(k) return end if @@ -343,7 +380,7 @@ contains val = zero_${s1}$ end function - subroutine set_value_csr_${s1}$(self,ik,jk,val) + subroutine add_value_csr_${s1}$(self,ik,jk,val) class(CSR_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk @@ -351,26 +388,49 @@ contains ! naive implementation do k = self%rowptr(ik), self%rowptr(ik+1)-1 if( jk == self%col(k) ) then - self%data(k) = val + self%data(k) = self%data(k) + val return end if end do end subroutine + subroutine add_block_csr_${s1}$(self,ik,jk,val) + class(CSR_${s1}$), intent(inout) :: self + ${t1}$, intent(in) :: val(:,:) + integer, intent(in) :: ik(:), jk(:) + integer :: k, i, j + ! naive implementation + do i = 1, size(ik) + do k = self%rowptr(ik(i)), self%rowptr(ik(i)+1)-1 + do j = 1, size(jk) + if( jk(j) == self%col(k) ) then + self%data(k) = self%data(k) + val(i,j) + end if + end do + end do + end do + end subroutine + #:endfor #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function get_value_csc_${s1}$(self,ik,jk) result(val) class(CSC_${s1}$), intent(in) :: self integer, intent(in) :: ik, jk - integer :: k + integer :: k, ik_, jk_ + logical :: transpose ! naive implementation if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then val = ieee_value( 0._${k1}$ , ieee_quiet_nan) return end if - do k = self%colptr(jk), self%colptr(jk+1)-1 - if( ik == self%row(k) ) then + ik_ = ik; jk_ = jk + transpose = (self%storage == sparse_lower .and. ik > jk) .or. (self%storage == sparse_upper .and. ik < jk) + if(transpose) then ! allow extraction of symmetric elements + ik_ = jk; jk_ = ik + end if + do k = self%colptr(jk_), self%colptr(jk_+1)-1 + if( ik_ == self%row(k) ) then val = self%data(k) return end if @@ -378,7 +438,7 @@ contains val = zero_${s1}$ end function - subroutine set_value_csc_${s1}$(self,ik,jk,val) + subroutine add_value_csc_${s1}$(self,ik,jk,val) class(CSC_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk @@ -386,34 +446,57 @@ contains ! naive implementation do k = self%colptr(jk), self%colptr(jk+1)-1 if( ik == self%row(k) ) then - self%data(k) = val + self%data(k) = self%data(k) + val return end if end do end subroutine + subroutine add_block_csc_${s1}$(self,ik,jk,val) + class(CSC_${s1}$), intent(inout) :: self + ${t1}$, intent(in) :: val(:,:) + integer, intent(in) :: ik(:), jk(:) + integer :: k, i, j + ! naive implementation + do j = 1, size(jk) + do k = self%colptr(jk(j)), self%colptr(jk(j)+1)-1 + do i = 1, size(ik) + if( ik(i) == self%row(k) ) then + self%data(k) = self%data(k) + val(i,j) + end if + end do + end do + end do + end subroutine + #:endfor #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function get_value_ell_${s1}$(self,ik,jk) result(val) class(ELL_${s1}$), intent(in) :: self integer, intent(in) :: ik, jk - integer :: k + integer :: k, ik_, jk_ + logical :: transpose ! naive implementation if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then val = ieee_value( 0._${k1}$ , ieee_quiet_nan) return end if + ik_ = ik; jk_ = jk + transpose = (self%storage == sparse_lower .and. ik > jk) .or. (self%storage == sparse_upper .and. ik < jk) + if(transpose) then ! allow extraction of symmetric elements + ik_ = jk; jk_ = ik + end if do k = 1 , self%K - if( jk == self%index(ik,k) ) then - val = self%data(ik,k) + if( jk_ == self%index(ik_,k) ) then + val = self%data(ik_,k) return end if end do val = zero_${s1}$ end function - subroutine set_value_ell_${s1}$(self,ik,jk,val) + subroutine add_value_ell_${s1}$(self,ik,jk,val) class(ELL_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val integer, intent(in) :: ik, jk @@ -421,12 +504,29 @@ contains ! naive implementation do k = 1 , self%K if( jk == self%index(ik,k) ) then - self%data(ik,k) = val + self%data(ik,k) = self%data(ik,k) + val return end if end do end subroutine + subroutine add_block_ell_${s1}$(self,ik,jk,val) + class(ELL_${s1}$), intent(inout) :: self + ${t1}$, intent(in) :: val(:,:) + integer, intent(in) :: ik(:), jk(:) + integer :: k, i, j + ! naive implementation + do k = 1 , self%K + do j = 1, size(jk) + do i = 1, size(ik) + if( jk(j) == self%index(ik(i),k) ) then + self%data(ik(i),k) = self%data(ik(i),k) + val(i,j) + end if + end do + end do + end do + end subroutine + #:endfor end module stdlib_sparse_kinds \ No newline at end of file From c7035c90a23e96aa6e4554403b8d94a0cc77059b Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Fri, 28 Jun 2024 00:02:43 +0200 Subject: [PATCH 40/78] add sparse test for add or getting values --- test/linalg/test_sparse_spmv.fypp | 47 ++++++++++++++++++++++++++++++- 1 file changed, 46 insertions(+), 1 deletion(-) diff --git a/test/linalg/test_sparse_spmv.fypp b/test/linalg/test_sparse_spmv.fypp index deda95fec..a3092229c 100644 --- a/test/linalg/test_sparse_spmv.fypp +++ b/test/linalg/test_sparse_spmv.fypp @@ -23,7 +23,8 @@ contains new_unittest('csc', test_csc), & new_unittest('ell', test_ell), & new_unittest('sellc', test_sellc), & - new_unittest('symmetries', test_symmetries) & + new_unittest('symmetries', test_symmetries), & + new_unittest('add_get_values', test_add_get_values) & ] end subroutine @@ -260,6 +261,50 @@ contains #:endfor end subroutine + subroutine test_add_get_values(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + #:for k1, t1, s1 in (KINDS_TYPES) + block + integer, parameter :: wp = ${k1}$ + real(wp) :: dense(5,5), mat(2,2) + type(COO_${s1}$) :: COO + type(CSR_${s1}$) :: CSR + ${t1}$:: err + integer :: i, j, locdof(2) + + mat(:,1) = [1,2]; mat(:,2) = [2,1] + dense = 0._wp + do i = 0, 3 + dense(1+i:2+i,1+i:2+i) = dense(1+i:2+i,1+i:2+i) + mat + end do + + call dense2coo(dense,COO) + call coo2csr(COO,CSR) + + CSR%data = 0._wp + + do i = 0, 3 + locdof(1:2) = [1+i,2+i] + call CSR%add(locdof,locdof,mat) + end do + + call check(error, all(CSR%data == COO%data) ) + if (allocated(error)) return + + do i = 1, 5 + do j = 1, 5 + err = err + abs(dense(i,j) - CSR%get(i,j)) + end do + end do + err = err / 5*5 + + call check(error, err <= epsilon(0._wp) ) + if (allocated(error)) return + end block + #:endfor + end subroutine + end module From 82950e00218f509ca0e2eb5c3e494073aaab5aa9 Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Fri, 28 Jun 2024 00:17:42 +0200 Subject: [PATCH 41/78] change name of value retrival function to at --- src/stdlib_sparse_kinds.fypp | 16 ++++++++-------- test/linalg/test_sparse_spmv.fypp | 3 ++- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index b28c255a0..fd04ea410 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -51,7 +51,7 @@ module stdlib_sparse_kinds type, public, extends(COO_type) :: COO_${s1}$ ${t1}$, allocatable :: data(:) contains - procedure, non_overridable :: get => get_value_coo_${s1}$ + procedure, non_overridable :: at => at_value_coo_${s1}$ procedure, non_overridable :: add_value => add_value_coo_${s1}$ procedure, non_overridable :: add_block => add_block_coo_${s1}$ generic :: add => add_value, add_block @@ -70,7 +70,7 @@ module stdlib_sparse_kinds type, public, extends(CSR_type) :: CSR_${s1}$ ${t1}$, allocatable :: data(:) contains - procedure, non_overridable :: get => get_value_csr_${s1}$ + procedure, non_overridable :: at => at_value_csr_${s1}$ procedure, non_overridable :: add_value => add_value_csr_${s1}$ procedure, non_overridable :: add_block => add_block_csr_${s1}$ generic :: add => add_value, add_block @@ -89,7 +89,7 @@ module stdlib_sparse_kinds type, public, extends(CSC_type) :: CSC_${s1}$ ${t1}$, allocatable :: data(:) contains - procedure, non_overridable :: get => get_value_csc_${s1}$ + procedure, non_overridable :: at => at_value_csc_${s1}$ procedure, non_overridable :: add_value => add_value_csc_${s1}$ procedure, non_overridable :: add_block => add_block_csc_${s1}$ generic :: add => add_value, add_block @@ -108,7 +108,7 @@ module stdlib_sparse_kinds type, public, extends(ELL_type) :: ELL_${s1}$ ${t1}$, allocatable :: data(:,:) contains - procedure, non_overridable :: get => get_value_ell_${s1}$ + procedure, non_overridable :: at => at_value_ell_${s1}$ procedure, non_overridable :: add_value => add_value_ell_${s1}$ procedure, non_overridable :: add_block => add_block_ell_${s1}$ generic :: add => add_value, add_block @@ -298,7 +298,7 @@ contains !================================================================== #:for k1, t1, s1 in (KINDS_TYPES) - pure ${t1}$ function get_value_coo_${s1}$(self,ik,jk) result(val) + pure ${t1}$ function at_value_coo_${s1}$(self,ik,jk) result(val) class(COO_${s1}$), intent(in) :: self integer, intent(in) :: ik, jk integer :: k, ik_, jk_ @@ -356,7 +356,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - pure ${t1}$ function get_value_csr_${s1}$(self,ik,jk) result(val) + pure ${t1}$ function at_value_csr_${s1}$(self,ik,jk) result(val) class(CSR_${s1}$), intent(in) :: self integer, intent(in) :: ik, jk integer :: k, ik_, jk_ @@ -414,7 +414,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - pure ${t1}$ function get_value_csc_${s1}$(self,ik,jk) result(val) + pure ${t1}$ function at_value_csc_${s1}$(self,ik,jk) result(val) class(CSC_${s1}$), intent(in) :: self integer, intent(in) :: ik, jk integer :: k, ik_, jk_ @@ -472,7 +472,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - pure ${t1}$ function get_value_ell_${s1}$(self,ik,jk) result(val) + pure ${t1}$ function at_value_ell_${s1}$(self,ik,jk) result(val) class(ELL_${s1}$), intent(in) :: self integer, intent(in) :: ik, jk integer :: k, ik_, jk_ diff --git a/test/linalg/test_sparse_spmv.fypp b/test/linalg/test_sparse_spmv.fypp index a3092229c..82a6471e6 100644 --- a/test/linalg/test_sparse_spmv.fypp +++ b/test/linalg/test_sparse_spmv.fypp @@ -292,9 +292,10 @@ contains call check(error, all(CSR%data == COO%data) ) if (allocated(error)) return + err = 0._wp do i = 1, 5 do j = 1, 5 - err = err + abs(dense(i,j) - CSR%get(i,j)) + err = err + abs(dense(i,j) - CSR%at(i,j)) end do end do err = err / 5*5 From 93c1e55411724adb3da9770555288bf1095419ec Mon Sep 17 00:00:00 2001 From: jalvesz Date: Fri, 28 Jun 2024 23:19:26 +0200 Subject: [PATCH 42/78] sellc add/at --- src/stdlib_sparse_conversion.fypp | 1 - src/stdlib_sparse_kinds.fypp | 69 ++++++++++++++++++++++++++++++- 2 files changed, 68 insertions(+), 2 deletions(-) diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 8e87bb801..6686d7fbb 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -328,7 +328,6 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) subroutine sort_coo_unique_${s1}$( a, data, n, num_rows, num_cols ) !! Sort a 2d array in increasing order first by index 1 and then by index 2 - integer, parameter :: wp = ${k1}$ ${t1}$, intent(inout) :: data(*) integer, intent(inout) :: a(2,*) integer, intent(inout) :: n diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index fd04ea410..9be4df0a6 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -125,7 +125,12 @@ module stdlib_sparse_kinds #:for k1, t1, s1 in (KINDS_TYPES) type, public, extends(SELLC_type) :: SELLC_${s1}$ - ${t1}$, allocatable :: data(:,:) + ${t1}$, allocatable :: data(:,:) + contains + procedure, non_overridable :: at => at_value_sellc_${s1}$ + procedure, non_overridable :: add_value => add_value_sellc_${s1}$ + procedure, non_overridable :: add_block => add_block_sellc_${s1}$ + generic :: add => add_value, add_block end type #:endfor @@ -528,5 +533,67 @@ contains end subroutine #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + pure ${t1}$ function at_value_sellc_${s1}$(self,ik,jk) result(val) + class(SELLC_${s1}$), intent(in) :: self + integer, intent(in) :: ik, jk + integer :: k, ik_, jk_, idx + logical :: transpose + ! naive implementation + if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then + val = ieee_value( 0._${k1}$ , ieee_quiet_nan) + return + end if + ik_ = ik; jk_ = jk + transpose = (self%storage == sparse_lower .and. ik > jk) .or. (self%storage == sparse_upper .and. ik < jk) + if(transpose) then ! allow extraction of symmetric elements + ik_ = jk; jk_ = ik + end if + + idx = self%rowptr((ik_ - 1)/self%chunk_size + 1) + do k = 1, self%chunk_size + if ( jk_ == self%col(k,idx) )then + val = self%data(k,idx) + return + endif + end do + val = zero_${s1}$ + end function + + subroutine add_value_sellc_${s1}$(self,ik,jk,val) + class(SELLC_${s1}$), intent(inout) :: self + ${t1}$, intent(in) :: val + integer, intent(in) :: ik, jk + integer :: k, idx + ! naive implementation + idx = self%rowptr((ik - 1)/self%chunk_size + 1) + do k = 1, self%chunk_size + if ( jk == self%col(k,idx) )then + self%data(k,idx) = self%data(k,idx) + val + return + endif + end do + end subroutine + + subroutine add_block_sellc_${s1}$(self,ik,jk,val) + class(SELLC_${s1}$), intent(inout) :: self + ${t1}$, intent(in) :: val(:,:) + integer, intent(in) :: ik(:), jk(:) + integer :: k, i, j, idx + ! naive implementation + do k = 1 , self%chunk_size + do j = 1, size(jk) + do i = 1, size(ik) + idx = self%rowptr((ik(i) - 1)/self%chunk_size + 1) + if( jk(j) == self%col(k,idx) ) then + self%data(k,idx) = self%data(k,idx) + val(i,j) + end if + end do + end do + end do + end subroutine + + #:endfor end module stdlib_sparse_kinds \ No newline at end of file From c1f30f66aa2c2e76c0dc036558994e5a73a7fcce Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 29 Jun 2024 13:09:30 +0200 Subject: [PATCH 43/78] refactoring to enable a from_ijv initialization interface --- doc/specs/stdlib_sparse.md | 19 ++++ src/stdlib_sparse.f90 | 1 - src/stdlib_sparse_conversion.fypp | 77 ++-------------- src/stdlib_sparse_kinds.fypp | 148 +++++++++++++++++++++++++++++- test/linalg/test_sparse_spmv.fypp | 22 ++--- 5 files changed, 183 insertions(+), 84 deletions(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index e888ec1bf..6b20764a7 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -184,6 +184,25 @@ This module provides facility functions for converting between storage formats. `sort_data`, `logical(in)`, `optional`:: Shall be an optional `logical` argument to determine whether data in the COO graph should be sorted while sorting the index array, default `.false.`. +### Syntax + +`call ` [[stdlib_sparse_conversion(module):from_ijv(interface)]] `(coo,row,col,data,nrows,ncols)` + +### Arguments + +`COO`, `intent(inout)`: Shall be any `COO` type. The graph object will be returned with a canonical shape after sorting and removing duplicates from the `(row,col,data)` triplet. If the graph is `COO_type` no data buffer is allowed. + +`row`, `integer(in)`:: rows index array. + +`col`, `integer(in)`:: columns index array. + +`data`, `real/complex(in)`, `optional`:: data array. + +`nrows`, `integer(in)`, `optional`:: number of rows, if not given it will be computed from the `row` array. + +`ncols`, `integer(in)`, `optional`:: number of columns, if not given it will be computed from the `col` array. + + ### Syntax `call ` [[stdlib_sparse_conversion(module):dense2coo(interface)]] `(dense,coo)` diff --git a/src/stdlib_sparse.f90 b/src/stdlib_sparse.f90 index 82e5d35de..58e7663d3 100644 --- a/src/stdlib_sparse.f90 +++ b/src/stdlib_sparse.f90 @@ -2,5 +2,4 @@ module stdlib_sparse use stdlib_sparse_kinds use stdlib_sparse_spmv - use stdlib_sparse_conversion end module stdlib_sparse \ No newline at end of file diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 6686d7fbb..ea1a5c774 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -5,67 +5,10 @@ !> The `stdlib_sparse_conversion` module provides sparse to sparse matrix conversion utilities. !> ! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose -module stdlib_sparse_conversion - use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp - use stdlib_sparse_kinds +submodule(stdlib_sparse_kinds) stdlib_sparse_conversion use stdlib_sorting, only: sort implicit none - private - public :: dense2coo, coo2dense, coo2csr, csr2coo - public :: csr2sellc - public :: coo2ordered - - !> Conversion from dense to coo - !> - !> Enables extracting the non-zero elements of a dense 2D matrix and - !> storing those values in a COO format. The coo matrix is (re)allocated on the fly. - interface dense2coo - #:for k1, t1, s1 in (KINDS_TYPES) - module procedure dense2coo_${s1}$ - #:endfor - end interface - - !> Conversion from coo to dense - !> - !> Enables creating a dense 2D matrix from the non-zero values tored in a COO format - !> The dense matrix can be allocated on the fly if not pre-allocated by the user. - interface coo2dense - #:for k1, t1, s1 in (KINDS_TYPES) - module procedure coo2dense_${s1}$ - #:endfor - end interface - - !> Conversion from coo to csr - !> - !> Enables transferring data from a COO matrix to a CSR matrix - !> under the hypothesis that the COO is already ordered. - interface coo2csr - #:for k1, t1, s1 in (KINDS_TYPES) - module procedure coo2csr_${s1}$ - #:endfor - end interface - - !> Conversion from csr to coo - !> - !> Enables transferring data from a CSR matrix to a COO matrix - !> under the hypothesis that the CSR is already ordered. - interface csr2coo - #:for k1, t1, s1 in (KINDS_TYPES) - module procedure csr2coo_${s1}$ - #:endfor - end interface - - !> Conversion from csr to SELL-C - !> - !> Enables transferring data from a CSR matrix to a SELL-C matrix - !> It takes an optional parameter to decide the chunck size 4, 8 or 16 - interface csr2sellc - #:for k1, t1, s1 in (KINDS_TYPES) - module procedure csr2sellc_${s1}$ - #:endfor - end interface - !> Sort arrays of a COO matrix !> interface sort_coo @@ -78,7 +21,7 @@ module stdlib_sparse_conversion contains #:for k1, t1, s1 in (KINDS_TYPES) - subroutine dense2coo_${s1}$(dense,COO) + module subroutine dense2coo_${s1}$(dense,COO) ${t1}$, intent(in) :: dense(:,:) type(COO_${s1}$), intent(inout) :: COO integer :: num_rows, num_cols, nnz @@ -106,7 +49,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - subroutine coo2dense_${s1}$(COO,dense) + module subroutine coo2dense_${s1}$(COO,dense) type(COO_${s1}$), intent(in) :: COO ${t1}$, allocatable, intent(inout) :: dense(:,:) integer :: idx @@ -120,7 +63,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - subroutine coo2csr_${s1}$(COO,CSR) + module subroutine coo2csr_${s1}$(COO,CSR) type(COO_${s1}$), intent(in) :: COO type(CSR_${s1}$), intent(inout) :: CSR integer :: i @@ -150,7 +93,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - subroutine csr2coo_${s1}$(CSR,COO) + module subroutine csr2coo_${s1}$(CSR,COO) type(CSR_${s1}$), intent(in) :: CSR type(COO_${s1}$), intent(inout) :: COO integer :: i, j @@ -176,7 +119,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) + module subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) !> csr2sellc: This function enables transfering data from a CSR matrix to a SELL-C matrix !> This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves type(CSR_${s1}$), intent(in) :: CSR @@ -326,7 +269,7 @@ contains end subroutine #:for k1, t1, s1 in (KINDS_TYPES) - subroutine sort_coo_unique_${s1}$( a, data, n, num_rows, num_cols ) + module subroutine sort_coo_unique_${s1}$( a, data, n, num_rows, num_cols ) !! Sort a 2d array in increasing order first by index 1 and then by index 2 ${t1}$, intent(inout) :: data(*) integer, intent(inout) :: a(2,*) @@ -388,7 +331,7 @@ contains #:endfor - subroutine coo2ordered(COO,sort_data) + module subroutine coo2ordered(COO,sort_data) class(COO_type), intent(inout) :: COO logical, intent(in), optional :: sort_data integer, allocatable :: itemp(:,:) @@ -423,5 +366,5 @@ contains COO%is_sorted = .true. end subroutine - -end module stdlib_sparse_conversion \ No newline at end of file + +end submodule \ No newline at end of file diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 9be4df0a6..51e1685fd 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -11,7 +11,9 @@ module stdlib_sparse_kinds implicit none private - + public :: dense2coo, coo2dense, csr2coo, coo2csr + public :: csr2sellc + public :: coo2ordered, from_ijv ! -- Global parameters enum, bind(C) enumerator :: sparse_full !> Full Sparse matrix (no symmetry considerations) @@ -134,6 +136,88 @@ module stdlib_sparse_kinds end type #:endfor + !> Conversion from dense to coo + !> + !> Enables extracting the non-zero elements of a dense 2D matrix and + !> storing those values in a COO format. The coo matrix is (re)allocated on the fly. + interface dense2coo + #:for k1, t1, s1 in (KINDS_TYPES) + module subroutine dense2coo_${s1}$(dense,COO) + ${t1}$, intent(in) :: dense(:,:) + type(COO_${s1}$), intent(inout) :: COO + end subroutine + #:endfor + end interface + + !> Conversion from coo to dense + !> + !> Enables creating a dense 2D matrix from the non-zero values tored in a COO format + !> The dense matrix can be allocated on the fly if not pre-allocated by the user. + interface coo2dense + #:for k1, t1, s1 in (KINDS_TYPES) + module subroutine coo2dense_${s1}$(COO,dense) + type(COO_${s1}$), intent(in) :: COO + ${t1}$, allocatable, intent(inout) :: dense(:,:) + end subroutine + #:endfor + end interface + + !> Conversion from coo to csr + !> + !> Enables transferring data from a COO matrix to a CSR matrix + !> under the hypothesis that the COO is already ordered. + interface coo2csr + #:for k1, t1, s1 in (KINDS_TYPES) + module subroutine coo2csr_${s1}$(COO,CSR) + type(COO_${s1}$), intent(in) :: COO + type(CSR_${s1}$), intent(inout) :: CSR + end subroutine + #:endfor + end interface + + !> Conversion from csr to coo + !> + !> Enables transferring data from a CSR matrix to a COO matrix + !> under the hypothesis that the CSR is already ordered. + interface csr2coo + #:for k1, t1, s1 in (KINDS_TYPES) + module subroutine csr2coo_${s1}$(CSR,COO) + type(CSR_${s1}$), intent(in) :: CSR + type(COO_${s1}$), intent(inout) :: COO + end subroutine + #:endfor + end interface + + !> Conversion from csr to SELL-C + !> + !> Enables transferring data from a CSR matrix to a SELL-C matrix + !> It takes an optional parameter to decide the chunck size 4, 8 or 16 + interface csr2sellc + #:for k1, t1, s1 in (KINDS_TYPES) + module subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) + type(CSR_${s1}$), intent(in) :: CSR + type(SELLC_${s1}$), intent(inout) :: SELLC + integer, intent(in), optional :: chunk + end subroutine + #:endfor + end interface + + !> Transform COO matrix to canonical form with ordered and unique entries + interface coo2ordered + module subroutine coo2ordered(COO,sort_data) + class(COO_type), intent(inout) :: COO + logical, intent(in), optional :: sort_data + end subroutine + end interface + + !> Enable creating a sparse matrix from ijv (row,col,data) triplet + interface from_ijv + module procedure :: coo_from_ijv_type + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: coo_from_ijv_${s1}$ + #:endfor + end interface + contains !> (re)Allocate matrix memory for the COO type @@ -298,6 +382,68 @@ contains end select end subroutine + subroutine coo_from_ijv_type(COO,row,col,nrows,ncols) + type(COO_type), intent(inout) :: COO + integer, intent(in) :: row(:) + integer, intent(in) :: col(:) + integer, intent(in), optional :: nrows + integer, intent(in), optional :: ncols + + integer :: nrows_, ncols_, nnz, ed + !--------------------------------------------------------- + if(present(nrows)) then + nrows_ = nrows + else + nrows_ = size(row) + end if + if(present(ncols)) then + ncols_ = ncols + else + ncols_ = size(col) + end if + nnz = size(row) + !--------------------------------------------------------- + call COO%malloc(nrows_,ncols_,nnz) + do ed = 1, nnz + COO%index(1:2,ed) = [row(ed),col(ed)] + end do + + call coo2ordered(COO,.true.) + end subroutine + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine coo_from_ijv_${s1}$(COO,row,col,data,nrows,ncols) + type(COO_${s1}$), intent(inout) :: COO + integer, intent(in) :: row(:) + integer, intent(in) :: col(:) + ${t1}$, intent(in), optional :: data(:) + integer, intent(in), optional :: nrows + integer, intent(in), optional :: ncols + + integer :: nrows_, ncols_, nnz, ed + !--------------------------------------------------------- + if(present(nrows)) then + nrows_ = nrows + else + nrows_ = maxval(row) + end if + if(present(ncols)) then + ncols_ = ncols + else + ncols_ = maxval(col) + end if + nnz = size(row) + !--------------------------------------------------------- + call COO%malloc(nrows_,ncols_,nnz) + do ed = 1, nnz + COO%index(1:2,ed) = [row(ed),col(ed)] + end do + if(present(data)) COO%data = data + + call coo2ordered(COO,.true.) + end subroutine + #:endfor + !================================================================== ! data accessors !================================================================== diff --git a/test/linalg/test_sparse_spmv.fypp b/test/linalg/test_sparse_spmv.fypp index 82a6471e6..8638ef2cd 100644 --- a/test/linalg/test_sparse_spmv.fypp +++ b/test/linalg/test_sparse_spmv.fypp @@ -68,22 +68,14 @@ contains !> Error handling type(error_type), allocatable, intent(out) :: error type(COO_sp) :: COO + integer :: row(12), col(12) + real :: data(12) - call COO%malloc(4,4,12) - COO%data(:) = 1 - COO%index(:,1) = [1,2] - COO%index(:,2) = [1,3] - COO%index(:,3) = [1,4] - COO%index(:,4) = [2,3] - COO%index(:,5) = [2,4] - COO%index(:,6) = [3,4] - - COO%index(:,7) = [2,3] - COO%index(:,8) = [2,4] - COO%index(:,9) = [2,5] - COO%index(:,10) = [3,4] - COO%index(:,11) = [3,5] - COO%index(:,12) = [4,5] + row = [1,1,1,2,2,3,2,2,2,3,3,4] + col = [2,3,4,3,4,4,3,4,5,4,5,5] + data = 1.0 + + call from_ijv(COO,row,col,data) call coo2ordered(COO,sort_data=.true.) call check(error, COO%nnz < 12 .and. COO%nnz == 9 ) From 4c16f4aa42234ddd428bf2cc403c7aa176a8ca34 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 29 Jun 2024 13:19:22 +0200 Subject: [PATCH 44/78] fix module procedure attribute --- src/stdlib_sparse_conversion.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index ea1a5c774..5801d5a4d 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -269,7 +269,7 @@ contains end subroutine #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine sort_coo_unique_${s1}$( a, data, n, num_rows, num_cols ) + subroutine sort_coo_unique_${s1}$( a, data, n, num_rows, num_cols ) !! Sort a 2d array in increasing order first by index 1 and then by index 2 ${t1}$, intent(inout) :: data(*) integer, intent(inout) :: a(2,*) From 944212da2c0e8f88b8a46ad066d2925bdd6e1b07 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 29 Jun 2024 14:17:58 +0200 Subject: [PATCH 45/78] enable creating CSR, ELL and SELLC using the from_ijv interface --- doc/specs/stdlib_sparse.md | 8 +- src/stdlib_sparse_conversion.fypp | 30 +++++++ src/stdlib_sparse_kinds.fypp | 126 ++++++++++++++++++++++++++++++ 3 files changed, 162 insertions(+), 2 deletions(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 6b20764a7..dfa663b2e 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -186,11 +186,11 @@ This module provides facility functions for converting between storage formats. ### Syntax -`call ` [[stdlib_sparse_conversion(module):from_ijv(interface)]] `(coo,row,col,data,nrows,ncols)` +`call ` [[stdlib_sparse_conversion(module):from_ijv(interface)]] `(sparse,row,col[,data,nrows,ncols,num_nz_rows,chunk])` ### Arguments -`COO`, `intent(inout)`: Shall be any `COO` type. The graph object will be returned with a canonical shape after sorting and removing duplicates from the `(row,col,data)` triplet. If the graph is `COO_type` no data buffer is allowed. +`sparse`, `intent(inout)`: Shall be a `COO`, `CSR`, `ELL` or `SELLC` type. The graph object will be returned with a canonical shape after sorting and removing duplicates from the `(row,col,data)` triplet. If the graph is `COO_type` no data buffer is allowed. `row`, `integer(in)`:: rows index array. @@ -202,6 +202,10 @@ This module provides facility functions for converting between storage formats. `ncols`, `integer(in)`, `optional`:: number of columns, if not given it will be computed from the `col` array. +`num_nz_rows`, `integer(in)`, `optional`:: number of non zeros per row, only valid in the case of an `ELL` matrix, by default it will computed from the largest row. + +`chunk`, `integer(in)`, `optional`:: chunk size, only valid in the case of a `SELLC` matrix, by default it will be taken from the `SELLC` default attribute chunk size. + ### Syntax diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 5801d5a4d..5b8b017ec 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -118,6 +118,36 @@ contains #:endfor + #:for k1, t1, s1 in (KINDS_TYPES) + module subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows) + type(CSR_${s1}$), intent(in) :: CSR + type(ELL_${s1}$), intent(inout) :: ELL + integer, intent(in), optional :: num_nz_rows !> number of non zeros per row + + integer :: i, j, num_nz_rows_, adr1, adr2 + !------------------------------------------- + num_nz_rows_ = 0 + if(present(num_nz_rows)) then + num_nz_rows_ = num_nz_rows + else + do i = 1, CSR%nrows + num_nz_rows_ = max(num_nz_rows_, CSR%rowptr( i+1 ) - CSR%rowptr( i ) ) + end do + end if + call ELL%malloc(CSR%nrows,CSR%ncols,num_nz_rows_) + !------------------------------------------- + do i = 1, CSR%nrows + adr1 = CSR%rowptr(i) + adr2 = min( adr1+num_nz_rows_ , CSR%rowptr(i+1)-1) + do j = adr1, adr2 + ELL%index(i,j-adr1+1) = CSR%col(j) + ELL%data(i,j-adr1+1) = CSR%data(j) + end do + end do + end subroutine + + #:endfor + #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) !> csr2sellc: This function enables transfering data from a CSR matrix to a SELL-C matrix diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 51e1685fd..103a32314 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -188,6 +188,20 @@ module stdlib_sparse_kinds #:endfor end interface + !> Conversion from csr to ell + !> + !> Enables transferring data from a CSR matrix to a ELL matrix + !> under the hypothesis that the CSR is already ordered. + interface csr2ell + #:for k1, t1, s1 in (KINDS_TYPES) + module subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows) + type(CSR_${s1}$), intent(in) :: CSR + type(ELL_${s1}$), intent(inout) :: ELL + integer, intent(in), optional :: num_nz_rows + end subroutine + #:endfor + end interface + !> Conversion from csr to SELL-C !> !> Enables transferring data from a CSR matrix to a SELL-C matrix @@ -215,6 +229,9 @@ module stdlib_sparse_kinds module procedure :: coo_from_ijv_type #:for k1, t1, s1 in (KINDS_TYPES) module procedure :: coo_from_ijv_${s1}$ + module procedure :: csr_from_ijv_${s1}$ + module procedure :: ell_from_ijv_${s1}$ + module procedure :: sellc_from_ijv_${s1}$ #:endfor end interface @@ -444,6 +461,115 @@ contains end subroutine #:endfor + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine csr_from_ijv_${s1}$(CSR,row,col,data,nrows,ncols) + type(CSR_${s1}$), intent(inout) :: CSR + integer, intent(in) :: row(:) + integer, intent(in) :: col(:) + ${t1}$, intent(in), optional :: data(:) + integer, intent(in), optional :: nrows + integer, intent(in), optional :: ncols + + integer :: nrows_, ncols_ + !--------------------------------------------------------- + if(present(nrows)) then + nrows_ = nrows + else + nrows_ = maxval(row) + end if + if(present(ncols)) then + ncols_ = ncols + else + ncols_ = maxval(col) + end if + !--------------------------------------------------------- + block + type(COO_${s1}$) :: COO + if(present(data)) then + call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) + else + call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_) + end if + call coo2csr(COO,CSR) + end block + end subroutine + #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine ell_from_ijv_${s1}$(ELL,row,col,data,nrows,ncols,num_nz_rows) + type(ELL_${s1}$), intent(inout) :: ELL + integer, intent(in) :: row(:) + integer, intent(in) :: col(:) + ${t1}$, intent(in), optional :: data(:) + integer, intent(in), optional :: nrows + integer, intent(in), optional :: ncols + integer, intent(in), optional :: num_nz_rows + + integer :: nrows_, ncols_, num_nz_rows_ + !--------------------------------------------------------- + if(present(nrows)) then + nrows_ = nrows + else + nrows_ = maxval(row) + end if + if(present(ncols)) then + ncols_ = ncols + else + ncols_ = maxval(col) + end if + !--------------------------------------------------------- + block + type(COO_${s1}$) :: COO + type(CSR_${s1}$) :: CSR + if(present(data)) then + call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) + else + call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_) + end if + call coo2csr(COO,CSR) + call csr2ell(CSR,ELL,num_nz_rows_) + end block + end subroutine + #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine sellc_from_ijv_${s1}$(SELLC,row,col,data,nrows,ncols,chunk) + type(SELLC_${s1}$), intent(inout) :: SELLC + integer, intent(in) :: row(:) + integer, intent(in) :: col(:) + ${t1}$, intent(in), optional :: data(:) + integer, intent(in), optional :: nrows + integer, intent(in), optional :: ncols + integer, intent(in), optional :: chunk + + integer :: nrows_, ncols_ + !--------------------------------------------------------- + if(present(nrows)) then + nrows_ = nrows + else + nrows_ = maxval(row) + end if + if(present(ncols)) then + ncols_ = ncols + else + ncols_ = maxval(col) + end if + if(present(chunk)) SELLC%chunk_size = chunk + !--------------------------------------------------------- + block + type(COO_${s1}$) :: COO + type(CSR_${s1}$) :: CSR + if(present(data)) then + call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) + else + call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_) + end if + call coo2csr(COO,CSR) + call csr2sellc(CSR,SELLC) + end block + end subroutine + #:endfor + !================================================================== ! data accessors !================================================================== From dd4dbd8f02a542f129ba184d40d5dd5b0d28b79a Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 29 Jun 2024 18:17:25 +0200 Subject: [PATCH 46/78] add example from_ijv --- doc/specs/stdlib_sparse.md | 4 +++ example/linalg/CMakeLists.txt | 1 + example/linalg/example_sparse_from_ijv.f90 | 42 ++++++++++++++++++++++ example/linalg/example_sparse_spmv.f90 | 4 +-- src/stdlib_sparse_kinds.fypp | 8 +++-- 5 files changed, 54 insertions(+), 5 deletions(-) create mode 100644 example/linalg/example_sparse_from_ijv.f90 diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index dfa663b2e..845e64924 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -206,6 +206,10 @@ This module provides facility functions for converting between storage formats. `chunk`, `integer(in)`, `optional`:: chunk size, only valid in the case of a `SELLC` matrix, by default it will be taken from the `SELLC` default attribute chunk size. +## Example +```fortran +{!example/linalg/example_sparse_from_ijv.f90!} +``` ### Syntax diff --git a/example/linalg/CMakeLists.txt b/example/linalg/CMakeLists.txt index 1ede8d326..6f25f2f2a 100644 --- a/example/linalg/CMakeLists.txt +++ b/example/linalg/CMakeLists.txt @@ -23,6 +23,7 @@ ADD_EXAMPLE(lstsq2) ADD_EXAMPLE(solve1) ADD_EXAMPLE(solve2) ADD_EXAMPLE(solve3) +ADD_EXAMPLE(sparse_from_ijv) ADD_EXAMPLE(sparse_spmv) ADD_EXAMPLE(svd) ADD_EXAMPLE(svdvals) diff --git a/example/linalg/example_sparse_from_ijv.f90 b/example/linalg/example_sparse_from_ijv.f90 new file mode 100644 index 000000000..da3b259dc --- /dev/null +++ b/example/linalg/example_sparse_from_ijv.f90 @@ -0,0 +1,42 @@ +program example_sparse_from_ijv + use stdlib_linalg_constants, only: dp + use stdlib_sparse + implicit none + + integer :: row(10), col(10) + real(dp) :: data(10) + type(COO_dp) :: COO + type(CSR_dp) :: CSR + type(ELL_dp) :: ELL + type(SELLC_dp) :: SELLC + integer :: i, j + + ! Initial data + row = [1,1,2,2,3,3,3,4,4,4] + col = [1,5,1,2,2,3,4,1,3,4] + data = real([9,-3,4,7,8,-1,8,4,5,6] , kind = dp ) + + ! Create a COO matrix from triplet + call from_ijv(COO,row,col,data) + print *, 'COO' + print *, ' i, j, v' + do i = 1, COO%nnz + print '(2I4,f8.1)', COO%index(:,i), COO%data(i) + end do + + ! Create a CSR matrix from triplet + call from_ijv(CSR,row,col,data) + print *, 'CSR' + print '(A,5I8)', 'rowptr :', CSR%rowptr + print '(A,10I8)', 'col :', CSR%col + print '(A,10f8.1)', 'data :', CSR%data + + ! Create an ELL matrix from triplet + call from_ijv(ELL,row,col,data) + print *, 'ELL' + print *, ' index | data' + do i = 1, ELL%nrows + print '(3I4,x,3f8.1)', ELL%index(i,:) , ELL%data(i,:) + end do + +end program example_sparse_from_ijv \ No newline at end of file diff --git a/example/linalg/example_sparse_spmv.f90 b/example/linalg/example_sparse_spmv.f90 index 9b30b35e2..25052710c 100644 --- a/example/linalg/example_sparse_spmv.f90 +++ b/example/linalg/example_sparse_spmv.f90 @@ -31,6 +31,4 @@ program example_sparse_spmv print *, 'coo :', y_coo print *, 'csr :', y_csr - end program example_sparse_spmv - - \ No newline at end of file +end program example_sparse_spmv \ No newline at end of file diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 103a32314..413eadcc5 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -505,7 +505,7 @@ contains integer, intent(in), optional :: ncols integer, intent(in), optional :: num_nz_rows - integer :: nrows_, ncols_, num_nz_rows_ + integer :: nrows_, ncols_ !--------------------------------------------------------- if(present(nrows)) then nrows_ = nrows @@ -527,7 +527,11 @@ contains call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_) end if call coo2csr(COO,CSR) - call csr2ell(CSR,ELL,num_nz_rows_) + if(present(num_nz_rows)) then + call csr2ell(CSR,ELL,num_nz_rows) + else + call csr2ell(CSR,ELL) + end if end block end subroutine #:endfor From 2d7701e88c01a78bd7dd421508e60d3ab67f60e0 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 29 Jun 2024 18:20:48 +0200 Subject: [PATCH 47/78] unused matrix --- example/linalg/example_sparse_from_ijv.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/example/linalg/example_sparse_from_ijv.f90 b/example/linalg/example_sparse_from_ijv.f90 index da3b259dc..1382cd3dd 100644 --- a/example/linalg/example_sparse_from_ijv.f90 +++ b/example/linalg/example_sparse_from_ijv.f90 @@ -8,7 +8,6 @@ program example_sparse_from_ijv type(COO_dp) :: COO type(CSR_dp) :: CSR type(ELL_dp) :: ELL - type(SELLC_dp) :: SELLC integer :: i, j ! Initial data From 98a564bf764c1bfc09b8c15e33c5d285a2de38b4 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 29 Jun 2024 19:15:25 +0200 Subject: [PATCH 48/78] add example and spec for add/at --- doc/specs/stdlib_sparse.md | 36 +++++++++++++ example/linalg/CMakeLists.txt | 1 + .../linalg/example_sparse_data_accessors.f90 | 50 +++++++++++++++++++ 3 files changed, 87 insertions(+) create mode 100644 example/linalg/example_sparse_data_accessors.f90 diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 845e64924..b785a7c0d 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -134,6 +134,42 @@ Experimental #### Description The Sliced ELLPACK format `SELLC` is a variation of the `ELLPACK` format. This modification reduces the storage size compared to the `ELLPACK` format but maintaining its efficient data access scheme. It can be seen as an intermediate format between `CSR` and `ELLPACK`. For more details read [the reference](https://arxiv.org/pdf/1307.6209v1) + +## `add`/`at` - Sparse Matrix data accessors + +### Status + +Experimental + +### Description +Type-bound procedures to enable adding or requesting data in/from a sparse matrix. + +### Syntax + +`call matrix%add(i,j,v)` or +`call matrix%add(i(:),j(:),v(:,:))` + +### Arguments + +`i`, `intent(in)`: Shall be an integer value or rank-1 array. +`j`, `intent(in)`: Shall be an integer value or rank-1 array. +`v`, `intent(in)`: Shall be a `real` or `complex` value or rank-2 array. The type shall be in accordance to the declared sparse matrix object. + +### Syntax + +`v = matrix%at(i,j)` + +### Arguments + +`i`, `intent(in)` : Shall be an integer value. +`j`, `intent(in)` : Shall be an integer value. +`v`, `result` : Shall be a `real` or `complex` value in accordance to the declared sparse matrix object. If the `ij` tuple is within the sparse pattern, `v` returns the value in the data buffer. If the `ij` tuple is outside the sparse pattern, `v` returns `0`. If the `ij` tuple is outside the matrix pattern `(nrows,ncols)`, `v` returns `NaN`. + +## Example +```fortran +{!example/linalg/example_sparse_data_accessors.f90!} +``` + ## `spmv` - Sparse Matrix-Vector product diff --git a/example/linalg/CMakeLists.txt b/example/linalg/CMakeLists.txt index 6f25f2f2a..36117886d 100644 --- a/example/linalg/CMakeLists.txt +++ b/example/linalg/CMakeLists.txt @@ -24,6 +24,7 @@ ADD_EXAMPLE(solve1) ADD_EXAMPLE(solve2) ADD_EXAMPLE(solve3) ADD_EXAMPLE(sparse_from_ijv) +ADD_EXAMPLE(sparse_data_accessors) ADD_EXAMPLE(sparse_spmv) ADD_EXAMPLE(svd) ADD_EXAMPLE(svdvals) diff --git a/example/linalg/example_sparse_data_accessors.f90 b/example/linalg/example_sparse_data_accessors.f90 new file mode 100644 index 000000000..b3be5eb55 --- /dev/null +++ b/example/linalg/example_sparse_data_accessors.f90 @@ -0,0 +1,50 @@ +program example_sparse_data_accessors + use stdlib_linalg_constants, only: dp + use stdlib_sparse + implicit none + + real(dp) :: mat(2,2) + real(dp), allocatable :: dense(:,:) + type(CSR_dp) :: CSR + type(COO_dp) :: COO + integer :: i, j, locdof(2) + + ! Initial data + mat(:,1) = [1._dp,2._dp] + mat(:,2) = [2._dp,1._dp] + allocate(dense(5,5) , source = 0._dp) + do i = 0, 3 + dense(1+i:2+i,1+i:2+i) = dense(1+i:2+i,1+i:2+i) + mat + end do + + print *, 'Original Matrix' + do j = 1 , 5 + print '(5f8.1)',dense(j,:) + end do + + ! Initialize CSR data and reset dense reference matrix + call dense2coo(dense,COO) + call coo2csr(COO,CSR) + CSR%data = 0._dp + dense = 0._dp + + ! Iteratively add blocks of data + do i = 0, 3 + locdof(1:2) = [1+i,2+i] + call CSR%add(locdof,locdof,mat) + ! lets print a dense view of every step + call csr2coo(CSR,COO) + call coo2dense(COO,dense) + print '(A,I2)', 'Add block :', i + do j = 1 , 5 + print '(5f8.1)',dense(j,:) + end do + end do + + ! Request values from the matrix + print *, '' + print *, 'within sparse pattern :',CSR%at(2,1) + print *, 'outside sparse pattern :',CSR%at(5,2) + print *, 'outside matrix pattern :',CSR%at(7,7) + +end program example_sparse_data_accessors \ No newline at end of file From b65d933e390fbe0e7dce520d29558b9f17d139fa Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 29 Jun 2024 19:22:12 +0200 Subject: [PATCH 49/78] example print index --- example/linalg/example_sparse_data_accessors.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/example/linalg/example_sparse_data_accessors.f90 b/example/linalg/example_sparse_data_accessors.f90 index b3be5eb55..4076dd898 100644 --- a/example/linalg/example_sparse_data_accessors.f90 +++ b/example/linalg/example_sparse_data_accessors.f90 @@ -35,7 +35,7 @@ program example_sparse_data_accessors ! lets print a dense view of every step call csr2coo(CSR,COO) call coo2dense(COO,dense) - print '(A,I2)', 'Add block :', i + print '(A,I2)', 'Add block :', i+1 do j = 1 , 5 print '(5f8.1)',dense(j,:) end do From a94272e9d712d38b478bb7fc86b58780f8273aa0 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 29 Jun 2024 20:07:16 +0200 Subject: [PATCH 50/78] add csr2dense direct conversion --- .../linalg/example_sparse_data_accessors.f90 | 3 +- src/stdlib_sparse_conversion.fypp | 26 ++++++++++++++ src/stdlib_sparse_kinds.fypp | 35 ++++++++++++++----- 3 files changed, 54 insertions(+), 10 deletions(-) diff --git a/example/linalg/example_sparse_data_accessors.f90 b/example/linalg/example_sparse_data_accessors.f90 index 4076dd898..e4de820f3 100644 --- a/example/linalg/example_sparse_data_accessors.f90 +++ b/example/linalg/example_sparse_data_accessors.f90 @@ -33,8 +33,7 @@ program example_sparse_data_accessors locdof(1:2) = [1+i,2+i] call CSR%add(locdof,locdof,mat) ! lets print a dense view of every step - call csr2coo(CSR,COO) - call coo2dense(COO,dense) + call csr2dense(CSR,dense) print '(A,I2)', 'Add block :', i+1 do j = 1 , 5 print '(5f8.1)',dense(j,:) diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 5b8b017ec..605daa5fc 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -92,6 +92,32 @@ contains #:endfor + #:for k1, t1, s1 in (KINDS_TYPES) + module subroutine csr2dense_${s1}$(CSR,dense) + type(CSR_${s1}$), intent(in) :: CSR + ${t1}$, allocatable, intent(inout) :: dense(:,:) + integer :: i, j + + if(.not.allocated(dense)) allocate(dense(CSR%nrows,CSR%nrows),source=zero_${s1}$) + if( CSR%storage == sparse_full) then + do i = 1, CSR%nrows + do j = CSR%rowptr(i), CSR%rowptr(i+1)-1 + dense(i,CSR%col(j)) = CSR%data(j) + end do + end do + else + do i = 1, CSR%nrows + do j = CSR%rowptr(i), CSR%rowptr(i+1)-1 + dense(i,CSR%col(j)) = CSR%data(j) + if( i == CSR%col(j) ) cycle + dense(CSR%col(j),i) = CSR%data(j) + end do + end do + end if + end subroutine + + #:endfor + #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2coo_${s1}$(CSR,COO) type(CSR_${s1}$), intent(in) :: CSR diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 413eadcc5..72d62c9fc 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -9,11 +9,8 @@ module stdlib_sparse_kinds use ieee_arithmetic use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp implicit none - private - public :: dense2coo, coo2dense, csr2coo, coo2csr - public :: csr2sellc - public :: coo2ordered, from_ijv + ! -- Global parameters enum, bind(C) enumerator :: sparse_full !> Full Sparse matrix (no symmetry considerations) @@ -61,7 +58,7 @@ module stdlib_sparse_kinds #:endfor !> CSR: Compressed sparse row or Yale format - type, extends(sparse_type) :: CSR_type + type, public, extends(sparse_type) :: CSR_type integer, allocatable :: col(:) !> matrix column pointer integer, allocatable :: rowptr(:) !> matrix row pointer contains @@ -80,7 +77,7 @@ module stdlib_sparse_kinds #:endfor !> CSC: Compressed sparse column - type, extends(sparse_type) :: CSC_type + type, public, extends(sparse_type) :: CSC_type integer, allocatable :: colptr(:) !> matrix column pointer integer, allocatable :: row(:) !> matrix row pointer contains @@ -99,7 +96,7 @@ module stdlib_sparse_kinds #:endfor !> Compressed ELLPACK - type, extends(sparse_type) :: ELL_type + type, public, extends(sparse_type) :: ELL_type integer :: K = 0 !> maximum number of nonzeros per row integer, allocatable :: index(:,:) !> column indices contains @@ -148,10 +145,11 @@ module stdlib_sparse_kinds end subroutine #:endfor end interface + public :: dense2coo !> Conversion from coo to dense !> - !> Enables creating a dense 2D matrix from the non-zero values tored in a COO format + !> Enables creating a dense 2D matrix from the non-zero values stored in a COO format !> The dense matrix can be allocated on the fly if not pre-allocated by the user. interface coo2dense #:for k1, t1, s1 in (KINDS_TYPES) @@ -161,6 +159,7 @@ module stdlib_sparse_kinds end subroutine #:endfor end interface + public :: coo2dense !> Conversion from coo to csr !> @@ -174,6 +173,21 @@ module stdlib_sparse_kinds end subroutine #:endfor end interface + public :: coo2csr + + !> Conversion from csr to dense + !> + !> Enables creating a dense 2D matrix from the non-zero values stored in a CSR format + !> The dense matrix can be allocated on the fly if not pre-allocated by the user. + interface csr2dense + #:for k1, t1, s1 in (KINDS_TYPES) + module subroutine csr2dense_${s1}$(CSR,dense) + type(CSR_${s1}$), intent(in) :: CSR + ${t1}$, allocatable, intent(inout) :: dense(:,:) + end subroutine + #:endfor + end interface + public :: csr2dense !> Conversion from csr to coo !> @@ -187,6 +201,7 @@ module stdlib_sparse_kinds end subroutine #:endfor end interface + public :: csr2coo !> Conversion from csr to ell !> @@ -201,6 +216,7 @@ module stdlib_sparse_kinds end subroutine #:endfor end interface + public :: csr2ell !> Conversion from csr to SELL-C !> @@ -215,6 +231,7 @@ module stdlib_sparse_kinds end subroutine #:endfor end interface + public :: csr2sellc !> Transform COO matrix to canonical form with ordered and unique entries interface coo2ordered @@ -223,6 +240,7 @@ module stdlib_sparse_kinds logical, intent(in), optional :: sort_data end subroutine end interface + public :: coo2ordered !> Enable creating a sparse matrix from ijv (row,col,data) triplet interface from_ijv @@ -234,6 +252,7 @@ module stdlib_sparse_kinds module procedure :: sellc_from_ijv_${s1}$ #:endfor end interface + public :: from_ijv contains From b53eca29a81ce2115537307c222d395f2cafd32b Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Tue, 9 Jul 2024 07:09:13 +0200 Subject: [PATCH 51/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Jeremie Vandenplas --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index b785a7c0d..cf57c0c57 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -23,7 +23,7 @@ The parent `sparse_type` is as an abstract derived type holding the basic common ```Fortran type, public, abstract :: sparse_type - integer :: nrows !> number of rows + integer :: nrows !! number of rows integer :: ncols !> number of columns integer :: nnz !> number of non-zero values integer :: storage !> assumed storage symmetry From 65e3fcbe090332553b3d2f44b3350b42c7da0e0c Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Tue, 9 Jul 2024 07:09:50 +0200 Subject: [PATCH 52/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Jeremie Vandenplas --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index cf57c0c57..21413195c 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -94,7 +94,7 @@ CSR%rowptr(:) = [1,3,5,8,11] Experimental #### Description -The Compressed Sparse Colum `CSC` is similar to the `CSR` format but values are accesed first by column, thus an index counter is given by `colptr` which enables accessing the start and ending rows of a given colum in the `row` index table. +The Compressed Sparse Colum `CSC` is similar to the `CSR` format but values are accesed first by column, thus an index counter is given by `colptr` which enables to know the first and last non-zero row index of a given colum. ```Fortran type(CSC_sp) :: CSC From 2f56cd40a09d7f0ac60ae3a91aaa1d94308e4144 Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Tue, 9 Jul 2024 07:10:48 +0200 Subject: [PATCH 53/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Jeremie Vandenplas --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 21413195c..2f77f2232 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -110,7 +110,7 @@ CSC%colptr(:) = [1,4,6,8,10,11] Experimental #### Description -The `ELL` format stores data in a dense matrix of $nrows \times K$ in column major order. By imposing a constant number of zeros per row $K$, this format will incur in additional zeros being stored, but it enables efficient vectorization as memory acces is carried out by constant sized strides. +The `ELL` format stores data in a dense matrix of $nrows \times K$ in column major order. By imposing a constant number of elements per row $K$, this format will incur in additional zeros being stored, but it enables efficient vectorization as memory acces is carried out by constant sized strides. ```Fortran type(ELL_sp) :: ELL From 941de3a17e79cb17bef3d3fd040bdd8f00a384a5 Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Tue, 9 Jul 2024 07:13:58 +0200 Subject: [PATCH 54/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Jeremie Vandenplas --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 2f77f2232..4888a4532 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -163,7 +163,7 @@ Type-bound procedures to enable adding or requesting data in/from a sparse matri `i`, `intent(in)` : Shall be an integer value. `j`, `intent(in)` : Shall be an integer value. -`v`, `result` : Shall be a `real` or `complex` value in accordance to the declared sparse matrix object. If the `ij` tuple is within the sparse pattern, `v` returns the value in the data buffer. If the `ij` tuple is outside the sparse pattern, `v` returns `0`. If the `ij` tuple is outside the matrix pattern `(nrows,ncols)`, `v` returns `NaN`. +`v`, `result` : Shall be a `real` or `complex` value in accordance to the declared sparse matrix object. If the `ij` tuple is within the sparse pattern, `v` contains the value in the data buffer. If the `ij` tuple is outside the sparse pattern, `v` is equal `0`. If the `ij` tuple is outside the matrix pattern `(nrows,ncols)`, `v` is `NaN`. ## Example ```fortran From 575c426b109a9294c17b6426fff9dd3ff461ceea Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Tue, 9 Jul 2024 07:15:22 +0200 Subject: [PATCH 55/78] Update doc/specs/stdlib_sparse.md Co-authored-by: Jeremie Vandenplas --- doc/specs/stdlib_sparse.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 4888a4532..8f39b0922 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -232,7 +232,7 @@ This module provides facility functions for converting between storage formats. `col`, `integer(in)`:: columns index array. -`data`, `real/complex(in)`, `optional`:: data array. +`data`, `real/complex(in)`, `optional`:: `real` or `complex` data array. `nrows`, `integer(in)`, `optional`:: number of rows, if not given it will be computed from the `row` array. From db73fdc2d8900b930f19b4251bff8890a06b3008 Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Tue, 9 Jul 2024 07:15:42 +0200 Subject: [PATCH 56/78] Update src/stdlib_sparse_kinds.fypp Co-authored-by: Jeremie Vandenplas --- src/stdlib_sparse_kinds.fypp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 72d62c9fc..16f337210 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -59,8 +59,8 @@ module stdlib_sparse_kinds !> CSR: Compressed sparse row or Yale format type, public, extends(sparse_type) :: CSR_type - integer, allocatable :: col(:) !> matrix column pointer - integer, allocatable :: rowptr(:) !> matrix row pointer + integer, allocatable :: col(:) !! matrix column pointer + integer, allocatable :: rowptr(:) !! matrix row pointer contains procedure :: malloc => malloc_csr end type From 697afa248d3388a7ff322be698cee9ea8bc8e9b2 Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Tue, 9 Jul 2024 07:16:49 +0200 Subject: [PATCH 57/78] Update src/stdlib_sparse_kinds.fypp Co-authored-by: Jeremie Vandenplas --- src/stdlib_sparse_kinds.fypp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 16f337210..8502c3236 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -32,10 +32,10 @@ module stdlib_sparse_kinds !> Base sparse type holding the meta data related to the storage capacity of a matrix. type, public, abstract :: sparse_type - integer :: nrows = 0 !> number of rows - integer :: ncols = 0 !> number of columns - integer :: nnz = 0 !> number of non-zero values - integer :: storage = sparse_full !> assumed storage symmetry + integer :: nrows = 0 !! number of rows + integer :: ncols = 0 !! number of columns + integer :: nnz = 0 !! number of non-zero values + integer :: storage = sparse_full !! assumed storage symmetry end type !> COO: COOrdinates compresed format From c97e665bfe24fcf4bbabf2a46d9dc61c583e776a Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Tue, 9 Jul 2024 07:17:24 +0200 Subject: [PATCH 58/78] Update src/stdlib_sparse_kinds.fypp Co-authored-by: Jeremie Vandenplas --- src/stdlib_sparse_kinds.fypp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 8502c3236..bcaf9f84e 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -40,8 +40,8 @@ module stdlib_sparse_kinds !> COO: COOrdinates compresed format type, public, extends(sparse_type) :: COO_type - logical :: is_sorted = .false. !> whether the matrix is sorted or not - integer, allocatable :: index(:,:) !> Matrix coordinates index(2,nnz) + logical :: is_sorted = .false. !! whether the matrix is sorted or not + integer, allocatable :: index(:,:) !! Matrix coordinates index(2,nnz) contains procedure :: malloc => malloc_coo end type From dde88a732d67a0b0bd4425d7734ffeccc53e28d0 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Wed, 10 Jul 2024 21:00:05 +0200 Subject: [PATCH 59/78] refactor spmv as submodule to keep parameters private, rework specs --- doc/specs/stdlib_sparse.md | 97 +++++++----- src/stdlib_sparse.f90 | 1 - src/stdlib_sparse_conversion.fypp | 36 ++--- src/stdlib_sparse_kinds.fypp | 244 ++++++++++++++++++++---------- src/stdlib_sparse_spmv.fypp | 48 ++---- 5 files changed, 248 insertions(+), 178 deletions(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 8f39b0922..2e8e6ceb5 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -24,9 +24,9 @@ The parent `sparse_type` is as an abstract derived type holding the basic common ```Fortran type, public, abstract :: sparse_type integer :: nrows !! number of rows - integer :: ncols !> number of columns - integer :: nnz !> number of non-zero values - integer :: storage !> assumed storage symmetry + integer :: ncols !! number of columns + integer :: nnz !! number of non-zero values + integer :: storage !! assumed storage symmetry end type ``` @@ -34,9 +34,9 @@ The storage integer label should be assigned from the module's internal enumerat ```Fortran enum, bind(C) - enumerator :: sparse_full !> Full Sparse matrix (no symmetry considerations) - enumerator :: sparse_lower !> Symmetric Sparse matrix with triangular inferior storage - enumerator :: sparse_upper !> Symmetric Sparse matrix with triangular supperior storage + enumerator :: sparse_full !! Full Sparse matrix (no symmetry considerations) + enumerator :: sparse_lower !! Symmetric Sparse matrix with triangular inferior storage + enumerator :: sparse_upper !! Symmetric Sparse matrix with triangular supperior storage end enum ``` In the following, all sparse kinds will be presented in two main flavors: a data-less type `_type` useful for topological graph operations. And real/complex valued types `_` containing the `data` buffer for the matrix values. The following rectangular matrix will be used to showcase how each sparse matrix holds the data internally: @@ -135,14 +135,14 @@ Experimental The Sliced ELLPACK format `SELLC` is a variation of the `ELLPACK` format. This modification reduces the storage size compared to the `ELLPACK` format but maintaining its efficient data access scheme. It can be seen as an intermediate format between `CSR` and `ELLPACK`. For more details read [the reference](https://arxiv.org/pdf/1307.6209v1) -## `add`/`at` - Sparse Matrix data accessors +## `add`- sparse matrix data accessors ### Status Experimental ### Description -Type-bound procedures to enable adding or requesting data in/from a sparse matrix. +Type-bound procedures to enable adding data in a sparse matrix. ### Syntax @@ -151,9 +151,20 @@ Type-bound procedures to enable adding or requesting data in/from a sparse matri ### Arguments -`i`, `intent(in)`: Shall be an integer value or rank-1 array. -`j`, `intent(in)`: Shall be an integer value or rank-1 array. -`v`, `intent(in)`: Shall be a `real` or `complex` value or rank-2 array. The type shall be in accordance to the declared sparse matrix object. +`i`: Shall be an integer value or rank-1 array. It is an `intent(in)` argument. + +`j`: Shall be an integer value or rank-1 array. It is an `intent(in)` argument. + +`v`: Shall be a `real` or `complex` value or rank-2 array. The type shall be in accordance to the declared sparse matrix object. It is an `intent(in)` argument. + +## `at`- sparse matrix data accessors + +### Status + +Experimental + +### Description +Type-bound procedures to enable requesting data from a sparse matrix. ### Syntax @@ -161,9 +172,11 @@ Type-bound procedures to enable adding or requesting data in/from a sparse matri ### Arguments -`i`, `intent(in)` : Shall be an integer value. -`j`, `intent(in)` : Shall be an integer value. -`v`, `result` : Shall be a `real` or `complex` value in accordance to the declared sparse matrix object. If the `ij` tuple is within the sparse pattern, `v` contains the value in the data buffer. If the `ij` tuple is outside the sparse pattern, `v` is equal `0`. If the `ij` tuple is outside the matrix pattern `(nrows,ncols)`, `v` is `NaN`. +`i` : Shall be an integer value. It is an `intent(in)` argument. + +`j` : Shall be an integer value. It is an `intent(in)` argument. + +`v` : Shall be a `real` or `complex` value in accordance to the declared sparse matrix object. If the `ij` tuple is within the sparse pattern, `v` contains the value in the data buffer. If the `ij` tuple is outside the sparse pattern, `v` is equal `0`. If the `ij` tuple is outside the matrix pattern `(nrows,ncols)`, `v` is `NaN`. ## Example ```fortran @@ -189,18 +202,18 @@ $$y=\alpha*M*x+\beta*y$$ ### Arguments -`matrix`, `intent(in)`: Shall be a `real` or `complex` sparse type matrix. +`matrix`: Shall be a `real` or `complex` sparse type matrix. It is an `intent(in)` argument. -`vec_x`, `intent(in)`: Shall be a rank-1 or rank-2 array of `real` or `complex` type array. +`vec_x`: Shall be a rank-1 or rank-2 array of `real` or `complex` type array. It is an `intent(in)` argument. -`vec_y`, `intent(inout)`: Shall be a rank-1 or rank-2 array of `real` or `complex` type array. +`vec_y`: Shall be a rank-1 or rank-2 array of `real` or `complex` type array. . It is an `intent(inout)` argument. -`alpha`, `intent(in)`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `alpha=1`. +`alpha`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `alpha=1`. It is an `intent(in)` argument. -`beta`, `intent(in)`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `beta=0`. +`beta`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `beta=0`. It is an `intent(in)` argument. -## `sparse_conversion` - Sparse matrix to matrix conversions +## Sparse matrix to matrix conversions ### Status @@ -212,13 +225,13 @@ This module provides facility functions for converting between storage formats. ### Syntax -`call ` [[stdlib_sparse_conversion(module):coo2ordered(interface)]] `(coo)` +`call ` [[stdlib_sparse_conversion(module):coo2ordered(interface)]] `(coo[,sort_data])` ### Arguments -`COO`, `intent(inout)`: Shall be any `COO` type. The same object will be returned with the arrays reallocated to the correct size after removing duplicates. +`COO` : Shall be any `COO` type. The same object will be returned with the arrays reallocated to the correct size after removing duplicates. It is an `intent(inout)` argument. -`sort_data`, `logical(in)`, `optional`:: Shall be an optional `logical` argument to determine whether data in the COO graph should be sorted while sorting the index array, default `.false.`. +`sort_data`, `optional` : Shall be a `logical` argument to determine whether data in the COO graph should be sorted while sorting the index array, default `.false.`. It is an `intent(in)` argument. ### Syntax @@ -226,21 +239,21 @@ This module provides facility functions for converting between storage formats. ### Arguments -`sparse`, `intent(inout)`: Shall be a `COO`, `CSR`, `ELL` or `SELLC` type. The graph object will be returned with a canonical shape after sorting and removing duplicates from the `(row,col,data)` triplet. If the graph is `COO_type` no data buffer is allowed. +`sparse` : Shall be a `COO`, `CSR`, `ELL` or `SELLC` type. The graph object will be returned with a canonical shape after sorting and removing duplicates from the `(row,col,data)` triplet. If the graph is `COO_type` no data buffer is allowed. It is an `intent(inout)` argument. -`row`, `integer(in)`:: rows index array. +`row` : rows index array. It is an `intent(in)` argument. -`col`, `integer(in)`:: columns index array. +`col` : columns index array. It is an `intent(in)` argument. -`data`, `real/complex(in)`, `optional`:: `real` or `complex` data array. +`data`, `optional`: `real` or `complex` data array. It is an `intent(in)` argument. -`nrows`, `integer(in)`, `optional`:: number of rows, if not given it will be computed from the `row` array. +`nrows`, `optional`: number of rows, if not given it will be computed from the `row` array. It is an `intent(in)` argument. -`ncols`, `integer(in)`, `optional`:: number of columns, if not given it will be computed from the `col` array. +`ncols`, `optional`: number of columns, if not given it will be computed from the `col` array. It is an `intent(in)` argument. -`num_nz_rows`, `integer(in)`, `optional`:: number of non zeros per row, only valid in the case of an `ELL` matrix, by default it will computed from the largest row. +`num_nz_rows`, `optional`: number of non zeros per row, only valid in the case of an `ELL` matrix, by default it will computed from the largest row. It is an `intent(in)` argument. -`chunk`, `integer(in)`, `optional`:: chunk size, only valid in the case of a `SELLC` matrix, by default it will be taken from the `SELLC` default attribute chunk size. +`chunk`, `optional`: chunk size, only valid in the case of a `SELLC` matrix, by default it will be taken from the `SELLC` default attribute chunk size. It is an `intent(in)` argument. ## Example ```fortran @@ -253,9 +266,9 @@ This module provides facility functions for converting between storage formats. ### Arguments -`dense`, `intent(in)`: Shall be a rank-2 array of `real` or `complex` type. +`dense` : Shall be a rank-2 array of `real` or `complex` type. It is an `intent(in)` argument. -`coo`, `intent(inout)`: Shall be a `COO` type of `real` or `complex` type. +`coo` : Shall be a `COO` type of `real` or `complex` type. It is an `intent(out)` argument. ### Syntax @@ -263,9 +276,9 @@ This module provides facility functions for converting between storage formats. ### Arguments -`coo`, `intent(in)`: Shall be a `COO` type of `real` or `complex` type. +`coo` : Shall be a `COO` type of `real` or `complex` type. It is an `intent(in)` argument. -`dense`, `intent(inout)`: Shall be a rank-2 array of `real` or `complex` type. +`dense` : Shall be a rank-2 array of `real` or `complex` type. It is an `intent(out)` argument. ### Syntax @@ -273,9 +286,9 @@ This module provides facility functions for converting between storage formats. ### Arguments -`coo`, `intent(in)`: Shall be a `COO` type of `real` or `complex` type. +`coo` : Shall be a `COO` type of `real` or `complex` type. It is an `intent(in)` argument. -`csr`, `intent(inout)`: Shall be a `CSR` type of `real` or `complex` type. +`csr` : Shall be a `CSR` type of `real` or `complex` type. It is an `intent(out)` argument. ### Syntax @@ -283,9 +296,9 @@ This module provides facility functions for converting between storage formats. ### Arguments -`csr`, `intent(in)`: Shall be a `CSR` type of `real` or `complex` type. +`csr` : Shall be a `CSR` type of `real` or `complex` type. It is an `intent(in)` argument. -`coo`, `intent(inout)`: Shall be a `COO` type of `real` or `complex` type. +`coo` : Shall be a `COO` type of `real` or `complex` type. It is an `intent(out)` argument. ### Syntax @@ -293,11 +306,11 @@ This module provides facility functions for converting between storage formats. ### Arguments -`csr`, `intent(in)`: Shall be a `CSR` type of `real` or `complex` type. +`csr` : Shall be a `CSR` type of `real` or `complex` type. It is an `intent(in)` argument. -`sellc`, `intent(inout)`: Shall be a `SELLC` type of `real` or `complex` type. +`sellc` : Shall be a `SELLC` type of `real` or `complex` type. It is an `intent(out)` argument. -`chunk`, `intent(in)`, `optional`: chunk size for the Sliced ELLPACK format. +`chunk`, `optional`: chunk size for the Sliced ELLPACK format. It is an `intent(in)` argument. ## Example ```fortran diff --git a/src/stdlib_sparse.f90 b/src/stdlib_sparse.f90 index 58e7663d3..6465d68d5 100644 --- a/src/stdlib_sparse.f90 +++ b/src/stdlib_sparse.f90 @@ -1,5 +1,4 @@ !! public API module stdlib_sparse use stdlib_sparse_kinds - use stdlib_sparse_spmv end module stdlib_sparse \ No newline at end of file diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 605daa5fc..9df336359 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -2,15 +2,15 @@ #:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX)) #:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX)) #:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES -!> The `stdlib_sparse_conversion` module provides sparse to sparse matrix conversion utilities. -!> +!! The `stdlib_sparse_conversion` submodule provides sparse to sparse matrix conversion utilities. +!! ! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose submodule(stdlib_sparse_kinds) stdlib_sparse_conversion use stdlib_sorting, only: sort implicit none - !> Sort arrays of a COO matrix - !> + !! Sort arrays of a COO matrix + !! interface sort_coo module procedure sort_coo_unique #:for k1, t1, s1 in (KINDS_TYPES) @@ -23,7 +23,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine dense2coo_${s1}$(dense,COO) ${t1}$, intent(in) :: dense(:,:) - type(COO_${s1}$), intent(inout) :: COO + type(COO_${s1}$), intent(out) :: COO integer :: num_rows, num_cols, nnz integer :: i, j, idx @@ -51,7 +51,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine coo2dense_${s1}$(COO,dense) type(COO_${s1}$), intent(in) :: COO - ${t1}$, allocatable, intent(inout) :: dense(:,:) + ${t1}$, allocatable, intent(out) :: dense(:,:) integer :: idx if(.not.allocated(dense)) allocate(dense(COO%nrows,COO%nrows),source=zero_${s1}$) @@ -64,8 +64,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine coo2csr_${s1}$(COO,CSR) - type(COO_${s1}$), intent(in) :: COO - type(CSR_${s1}$), intent(inout) :: CSR + type(COO_${s1}$), intent(in) :: COO + type(CSR_${s1}$), intent(out) :: CSR integer :: i CSR%nnz = COO%nnz; CSR%nrows = COO%nrows; CSR%ncols = COO%ncols @@ -95,7 +95,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2dense_${s1}$(CSR,dense) type(CSR_${s1}$), intent(in) :: CSR - ${t1}$, allocatable, intent(inout) :: dense(:,:) + ${t1}$, allocatable, intent(out) :: dense(:,:) integer :: i, j if(.not.allocated(dense)) allocate(dense(CSR%nrows,CSR%nrows),source=zero_${s1}$) @@ -120,8 +120,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2coo_${s1}$(CSR,COO) - type(CSR_${s1}$), intent(in) :: CSR - type(COO_${s1}$), intent(inout) :: COO + type(CSR_${s1}$), intent(in) :: CSR + type(COO_${s1}$), intent(out) :: COO integer :: i, j COO%nnz = CSR%nnz; COO%nrows = CSR%nrows; COO%ncols = CSR%ncols @@ -146,9 +146,9 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows) - type(CSR_${s1}$), intent(in) :: CSR - type(ELL_${s1}$), intent(inout) :: ELL - integer, intent(in), optional :: num_nz_rows !> number of non zeros per row + type(CSR_${s1}$), intent(in) :: CSR + type(ELL_${s1}$), intent(out) :: ELL + integer, intent(in), optional :: num_nz_rows !! number of non zeros per row integer :: i, j, num_nz_rows_, adr1, adr2 !------------------------------------------- @@ -176,10 +176,10 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) - !> csr2sellc: This function enables transfering data from a CSR matrix to a SELL-C matrix - !> This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves - type(CSR_${s1}$), intent(in) :: CSR - type(SELLC_${s1}$), intent(inout) :: SELLC + !! csr2sellc: This function enables transfering data from a CSR matrix to a SELL-C matrix + !! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves + type(CSR_${s1}$), intent(in) :: CSR + type(SELLC_${s1}$), intent(out) :: SELLC integer, intent(in), optional :: chunk ${t1}$, parameter :: zero = zero_${s1}$ integer :: i, j, num_chunks diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index bcaf9f84e..42180f8c9 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -1,9 +1,10 @@ #:include "common.fypp" +#:set RANKS = range(1, 2+1) #:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX)) #:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX)) #:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES -!> The `stdlib_sparse_kinds` module provides derived type definitions for different sparse matrices -!> +!! The `stdlib_sparse_kinds` module provides derived type definitions for different sparse matrices +!! ! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose module stdlib_sparse_kinds use ieee_arithmetic @@ -11,26 +12,25 @@ module stdlib_sparse_kinds implicit none private - ! -- Global parameters enum, bind(C) - enumerator :: sparse_full !> Full Sparse matrix (no symmetry considerations) - enumerator :: sparse_lower !> Symmetric Sparse matrix with triangular inferior storage - enumerator :: sparse_upper !> Symmetric Sparse matrix with triangular supperior storage + enumerator :: sparse_full !! Full Sparse matrix (no symmetry considerations) + enumerator :: sparse_lower !! Symmetric Sparse matrix with triangular inferior storage + enumerator :: sparse_upper !! Symmetric Sparse matrix with triangular supperior storage end enum public :: sparse_full, sparse_lower, sparse_upper #:for k1, t1, s1 in (R_KINDS_TYPES) - ${t1}$, parameter, public :: zero_${s1}$ = 0._${k1}$ - ${t1}$, parameter, public :: one_${s1}$ = 1._${k1}$ + ${t1}$, parameter :: zero_${s1}$ = 0._${k1}$ + ${t1}$, parameter :: one_${s1}$ = 1._${k1}$ #:endfor #:for k1, t1, s1 in (C_KINDS_TYPES) - ${t1}$, parameter, public :: zero_${s1}$ = (0._${k1}$,0._${k1}$) - ${t1}$, parameter, public :: one_${s1}$ = (1._${k1}$,1._${k1}$) + ${t1}$, parameter :: zero_${s1}$ = (0._${k1}$,0._${k1}$) + ${t1}$, parameter :: one_${s1}$ = (1._${k1}$,1._${k1}$) #:endfor - ! -- Classes - - !> Base sparse type holding the meta data related to the storage capacity of a matrix. + !! version: experimental + !! + !! Base sparse type holding the meta data related to the storage capacity of a matrix. type, public, abstract :: sparse_type integer :: nrows = 0 !! number of rows integer :: ncols = 0 !! number of columns @@ -38,7 +38,9 @@ module stdlib_sparse_kinds integer :: storage = sparse_full !! assumed storage symmetry end type - !> COO: COOrdinates compresed format + !! version: experimental + !! + !! COO: COOrdinates compresed format type, public, extends(sparse_type) :: COO_type logical :: is_sorted = .false. !! whether the matrix is sorted or not integer, allocatable :: index(:,:) !! Matrix coordinates index(2,nnz) @@ -57,7 +59,9 @@ module stdlib_sparse_kinds end type #:endfor - !> CSR: Compressed sparse row or Yale format + !! version: experimental + !! + !! CSR: Compressed sparse row or Yale format type, public, extends(sparse_type) :: CSR_type integer, allocatable :: col(:) !! matrix column pointer integer, allocatable :: rowptr(:) !! matrix row pointer @@ -76,10 +80,12 @@ module stdlib_sparse_kinds end type #:endfor - !> CSC: Compressed sparse column + !! version: experimental + !! + !! CSC: Compressed sparse column type, public, extends(sparse_type) :: CSC_type - integer, allocatable :: colptr(:) !> matrix column pointer - integer, allocatable :: row(:) !> matrix row pointer + integer, allocatable :: colptr(:) !! matrix column pointer + integer, allocatable :: row(:) !! matrix row pointer contains procedure :: malloc => malloc_csc end type @@ -94,11 +100,13 @@ module stdlib_sparse_kinds generic :: add => add_value, add_block end type #:endfor - - !> Compressed ELLPACK + + !! version: experimental + !! + !! Compressed ELLPACK type, public, extends(sparse_type) :: ELL_type - integer :: K = 0 !> maximum number of nonzeros per row - integer, allocatable :: index(:,:) !> column indices + integer :: K = 0 !! maximum number of nonzeros per row + integer, allocatable :: index(:,:) !! column indices contains procedure :: malloc => malloc_ell end type @@ -114,12 +122,14 @@ module stdlib_sparse_kinds end type #:endfor - !> Compressed SELL-C - !> Reference : https://library.eecs.utk.edu/storage/files/ut-eecs-14-727.pdf + !! version: experimental + !! + !! Compressed SELL-C + !! Reference : https://library.eecs.utk.edu/storage/files/ut-eecs-14-727.pdf type, public, extends(sparse_type) :: SELLC_type - integer :: chunk_size = 8 !> default chunk size - integer, allocatable :: rowptr(:) !> row pointer - integer, allocatable :: col(:,:) !> column indices + integer :: chunk_size = 8 !! default chunk size + integer, allocatable :: rowptr(:) !! row pointer + integer, allocatable :: col(:,:) !! column indices end type #:for k1, t1, s1 in (KINDS_TYPES) @@ -133,107 +143,124 @@ module stdlib_sparse_kinds end type #:endfor - !> Conversion from dense to coo - !> - !> Enables extracting the non-zero elements of a dense 2D matrix and - !> storing those values in a COO format. The coo matrix is (re)allocated on the fly. + !! version: experimental + !! + !! Conversion from dense to coo + !! Enables extracting the non-zero elements of a dense 2D matrix and + !! storing those values in a COO format. The coo matrix is (re)allocated on the fly. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) interface dense2coo #:for k1, t1, s1 in (KINDS_TYPES) module subroutine dense2coo_${s1}$(dense,COO) ${t1}$, intent(in) :: dense(:,:) - type(COO_${s1}$), intent(inout) :: COO + type(COO_${s1}$), intent(out) :: COO end subroutine #:endfor end interface public :: dense2coo - !> Conversion from coo to dense - !> - !> Enables creating a dense 2D matrix from the non-zero values stored in a COO format - !> The dense matrix can be allocated on the fly if not pre-allocated by the user. + !! version: experimental + !! + !! Conversion from coo to dense + !! Enables creating a dense 2D matrix from the non-zero values stored in a COO format + !! The dense matrix can be allocated on the fly if not pre-allocated by the user. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) interface coo2dense #:for k1, t1, s1 in (KINDS_TYPES) module subroutine coo2dense_${s1}$(COO,dense) type(COO_${s1}$), intent(in) :: COO - ${t1}$, allocatable, intent(inout) :: dense(:,:) + ${t1}$, allocatable, intent(out) :: dense(:,:) end subroutine #:endfor end interface public :: coo2dense - !> Conversion from coo to csr - !> - !> Enables transferring data from a COO matrix to a CSR matrix - !> under the hypothesis that the COO is already ordered. + !! version: experimental + !! + !! Conversion from coo to csr + !! Enables transferring data from a COO matrix to a CSR matrix + !! under the hypothesis that the COO is already ordered. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) interface coo2csr #:for k1, t1, s1 in (KINDS_TYPES) module subroutine coo2csr_${s1}$(COO,CSR) type(COO_${s1}$), intent(in) :: COO - type(CSR_${s1}$), intent(inout) :: CSR + type(CSR_${s1}$), intent(out) :: CSR end subroutine #:endfor end interface public :: coo2csr - !> Conversion from csr to dense - !> - !> Enables creating a dense 2D matrix from the non-zero values stored in a CSR format - !> The dense matrix can be allocated on the fly if not pre-allocated by the user. + !! version: experimental + !! + !! Conversion from csr to dense + !! Enables creating a dense 2D matrix from the non-zero values stored in a CSR format + !! The dense matrix can be allocated on the fly if not pre-allocated by the user. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) interface csr2dense #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2dense_${s1}$(CSR,dense) type(CSR_${s1}$), intent(in) :: CSR - ${t1}$, allocatable, intent(inout) :: dense(:,:) + ${t1}$, allocatable, intent(out) :: dense(:,:) end subroutine #:endfor end interface public :: csr2dense - !> Conversion from csr to coo - !> - !> Enables transferring data from a CSR matrix to a COO matrix - !> under the hypothesis that the CSR is already ordered. + !! version: experimental + !! + !! Conversion from csr to coo + !! Enables transferring data from a CSR matrix to a COO matrix + !! under the hypothesis that the CSR is already ordered. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) interface csr2coo #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2coo_${s1}$(CSR,COO) type(CSR_${s1}$), intent(in) :: CSR - type(COO_${s1}$), intent(inout) :: COO + type(COO_${s1}$), intent(out) :: COO end subroutine #:endfor end interface public :: csr2coo - !> Conversion from csr to ell - !> - !> Enables transferring data from a CSR matrix to a ELL matrix - !> under the hypothesis that the CSR is already ordered. + !! version: experimental + !! + !! Conversion from csr to ell + !! Enables transferring data from a CSR matrix to a ELL matrix + !! under the hypothesis that the CSR is already ordered. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) interface csr2ell #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows) - type(CSR_${s1}$), intent(in) :: CSR - type(ELL_${s1}$), intent(inout) :: ELL - integer, intent(in), optional :: num_nz_rows + type(CSR_${s1}$), intent(in) :: CSR + type(ELL_${s1}$), intent(out) :: ELL + integer, intent(in), optional :: num_nz_rows end subroutine #:endfor end interface public :: csr2ell - !> Conversion from csr to SELL-C - !> - !> Enables transferring data from a CSR matrix to a SELL-C matrix - !> It takes an optional parameter to decide the chunck size 4, 8 or 16 + !! version: experimental + !! + !! Conversion from csr to SELL-C + !! Enables transferring data from a CSR matrix to a SELL-C matrix + !! It takes an optional parameter to decide the chunck size 4, 8 or 16 + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) interface csr2sellc #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) - type(CSR_${s1}$), intent(in) :: CSR - type(SELLC_${s1}$), intent(inout) :: SELLC + type(CSR_${s1}$), intent(in) :: CSR + type(SELLC_${s1}$), intent(out) :: SELLC integer, intent(in), optional :: chunk end subroutine #:endfor end interface public :: csr2sellc - !> Transform COO matrix to canonical form with ordered and unique entries + !! version: experimental + !! + !! Transform COO matrix to canonical form with ordered and unique entries + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) interface coo2ordered module subroutine coo2ordered(COO,sort_data) class(COO_type), intent(inout) :: COO @@ -242,7 +269,10 @@ module stdlib_sparse_kinds end interface public :: coo2ordered - !> Enable creating a sparse matrix from ijv (row,col,data) triplet + !! version: experimental + !! + !! Enable creating a sparse matrix from ijv (row,col,data) triplet + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) interface from_ijv module procedure :: coo_from_ijv_type #:for k1, t1, s1 in (KINDS_TYPES) @@ -254,14 +284,62 @@ module stdlib_sparse_kinds end interface public :: from_ijv + !! Version experimental + !! + !! Applay the sparse matrix-vector product $$y = \alpha * M * x + \beta * y $$ + !! [Specifications](../page/specs/stdlib_sparse.html#spmv) + interface spmv + #:for k1, t1, s1 in (KINDS_TYPES) + #:for rank in RANKS + module subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + type(COO_${s1}$), intent(in) :: matrix + ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ + ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + ${t1}$, intent(in), optional :: alpha + ${t1}$, intent(in), optional :: beta + end subroutine + module subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + type(CSR_${s1}$), intent(in) :: matrix + ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ + ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + ${t1}$, intent(in), optional :: alpha + ${t1}$, intent(in), optional :: beta + end subroutine + module subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + type(CSC_${s1}$), intent(in) :: matrix + ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ + ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + ${t1}$, intent(in), optional :: alpha + ${t1}$, intent(in), optional :: beta + end subroutine + module subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + type(ELL_${s1}$), intent(in) :: matrix + ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ + ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ + ${t1}$, intent(in), optional :: alpha + ${t1}$, intent(in), optional :: beta + end subroutine + #:endfor + module subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) + !! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves + type(SELLC_${s1}$), intent(in) :: matrix + ${t1}$, intent(in) :: vec_x(:) + ${t1}$, intent(inout) :: vec_y(:) + ${t1}$, intent(in), optional :: alpha + ${t1}$, intent(in), optional :: beta + end subroutine + #:endfor + end interface + public :: spmv + contains - !> (re)Allocate matrix memory for the COO type + !! (re)Allocate matrix memory for the COO type subroutine malloc_coo(self,num_rows,num_cols,nnz) class(COO_type) :: self - integer, intent(in) :: num_rows !> number of rows - integer, intent(in) :: num_cols !> number of columns - integer, intent(in) :: nnz !> number of non zeros + integer, intent(in) :: num_rows !! number of rows + integer, intent(in) :: num_cols !! number of columns + integer, intent(in) :: nnz !! number of non zeros integer, allocatable :: temp_idx(:,:) !----------------------------------------------------- @@ -293,12 +371,12 @@ contains end select end subroutine - !> (re)Allocate matrix memory for the CSR type + !! (re)Allocate matrix memory for the CSR type subroutine malloc_csr(self,num_rows,num_cols,nnz) class(CSR_type) :: self - integer, intent(in) :: num_rows !> number of rows - integer, intent(in) :: num_cols !> number of columns - integer, intent(in) :: nnz !> number of non zeros + integer, intent(in) :: num_rows !! number of rows + integer, intent(in) :: num_cols !! number of columns + integer, intent(in) :: nnz !! number of non zeros integer, allocatable :: temp_idx(:) !----------------------------------------------------- @@ -337,12 +415,12 @@ contains end select end subroutine - !> (re)Allocate matrix memory for the CSC type + !! (re)Allocate matrix memory for the CSC type subroutine malloc_csc(self,num_rows,num_cols,nnz) class(CSC_type) :: self - integer, intent(in) :: num_rows !> number of rows - integer, intent(in) :: num_cols !> number of columns - integer, intent(in) :: nnz !> number of non zeros + integer, intent(in) :: num_rows !! number of rows + integer, intent(in) :: num_cols !! number of columns + integer, intent(in) :: nnz !! number of non zeros integer, allocatable :: temp_idx(:) !----------------------------------------------------- @@ -381,12 +459,12 @@ contains end select end subroutine - !> (re)Allocate matrix memory for the ELLPACK type + !! (re)Allocate matrix memory for the ELLPACK type subroutine malloc_ell(self,num_rows,num_cols,num_nz_rows) class(ELL_type) :: self - integer, intent(in) :: num_rows !> number of rows - integer, intent(in) :: num_cols !> number of columns - integer, intent(in) :: num_nz_rows !> number of non zeros per row + integer, intent(in) :: num_rows !! number of rows + integer, intent(in) :: num_cols !! number of columns + integer, intent(in) :: num_nz_rows !! number of non zeros per row integer, allocatable :: temp_idx(:,:) !----------------------------------------------------- diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index 9cd1a9e5b..b569aafb6 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -7,38 +7,18 @@ #:def rksfx2(rank) #{if rank > 0}#${":," + ":," * (rank - 1)}$#{endif}# #:enddef -!> The `stdlib_sparse_spmv` module provides matrix-vector product kernels. -!> +!! The `stdlib_sparse_spmv` submodule provides matrix-vector product kernels. +!! ! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose -module stdlib_sparse_spmv - use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp - use stdlib_sparse_kinds +submodule(stdlib_sparse_kinds) stdlib_sparse_spmv implicit none - private - - public :: spmv - interface spmv - !! Version experimental - !! - !! Applay the sparse matrix-vector product $$y = \beta * y + \alpha * M * x $$ - !! - #:for k1, t1, s1 in (KINDS_TYPES) - #:for rank in RANKS - module procedure spmv_coo_${rank}$d_${s1}$ - module procedure spmv_csr_${rank}$d_${s1}$ - module procedure spmv_csc_${rank}$d_${s1}$ - module procedure spmv_ell_${rank}$d_${s1}$ - #:endfor - module procedure spmv_sellc_${s1}$ - #:endfor - end interface contains - !> spmv_coo + !! spmv_coo #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + module subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(COO_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -81,7 +61,7 @@ contains !! spmv_csr #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + module subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(CSR_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -158,10 +138,10 @@ contains #:endfor #:endfor - !> spmv_csc + !! spmv_csc #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + module subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(CSC_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -222,10 +202,10 @@ contains #:endfor #:endfor - !> spmv_ell + !! spmv_ell #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + module subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(ELL_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -256,11 +236,11 @@ contains #:endfor #:endfor - !> spmv_sellc + !! spmv_sellc #:set CHUNKS = [4,8,16] #:for k1, t1, s1 in (KINDS_TYPES) - subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) - !> This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves + module subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) + !! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves type(SELLC_${s1}$), intent(in) :: matrix ${t1}$, intent(in) :: vec_x(:) ${t1}$, intent(inout) :: vec_y(:) @@ -336,4 +316,4 @@ contains #:endfor -end module stdlib_sparse_spmv \ No newline at end of file +end submodule \ No newline at end of file From 6ae038bd54ab9927aec20bb0787ba89fa5769c17 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Wed, 10 Jul 2024 22:06:43 +0200 Subject: [PATCH 60/78] add an ilp parameter to change in the future for int64 if needed for large arrays --- src/stdlib_sparse_conversion.fypp | 56 +++++----- src/stdlib_sparse_kinds.fypp | 167 +++++++++++++++--------------- src/stdlib_sparse_spmv.fypp | 14 +-- 3 files changed, 120 insertions(+), 117 deletions(-) diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 9df336359..7918f5ade 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -24,8 +24,8 @@ contains module subroutine dense2coo_${s1}$(dense,COO) ${t1}$, intent(in) :: dense(:,:) type(COO_${s1}$), intent(out) :: COO - integer :: num_rows, num_cols, nnz - integer :: i, j, idx + integer(ilp) :: num_rows, num_cols, nnz + integer(ilp) :: i, j, idx num_rows = size(dense,dim=1) num_cols = size(dense,dim=2) @@ -52,7 +52,7 @@ contains module subroutine coo2dense_${s1}$(COO,dense) type(COO_${s1}$), intent(in) :: COO ${t1}$, allocatable, intent(out) :: dense(:,:) - integer :: idx + integer(ilp) :: idx if(.not.allocated(dense)) allocate(dense(COO%nrows,COO%nrows),source=zero_${s1}$) do concurrent(idx = 1:COO%nnz) @@ -66,7 +66,7 @@ contains module subroutine coo2csr_${s1}$(COO,CSR) type(COO_${s1}$), intent(in) :: COO type(CSR_${s1}$), intent(out) :: CSR - integer :: i + integer(ilp) :: i CSR%nnz = COO%nnz; CSR%nrows = COO%nrows; CSR%ncols = COO%ncols CSR%storage = COO%storage @@ -96,7 +96,7 @@ contains module subroutine csr2dense_${s1}$(CSR,dense) type(CSR_${s1}$), intent(in) :: CSR ${t1}$, allocatable, intent(out) :: dense(:,:) - integer :: i, j + integer(ilp) :: i, j if(.not.allocated(dense)) allocate(dense(CSR%nrows,CSR%nrows),source=zero_${s1}$) if( CSR%storage == sparse_full) then @@ -122,7 +122,7 @@ contains module subroutine csr2coo_${s1}$(CSR,COO) type(CSR_${s1}$), intent(in) :: CSR type(COO_${s1}$), intent(out) :: COO - integer :: i, j + integer(ilp) :: i, j COO%nnz = CSR%nnz; COO%nrows = CSR%nrows; COO%ncols = CSR%ncols COO%storage = CSR%storage @@ -150,7 +150,7 @@ contains type(ELL_${s1}$), intent(out) :: ELL integer, intent(in), optional :: num_nz_rows !! number of non zeros per row - integer :: i, j, num_nz_rows_, adr1, adr2 + integer(ilp) :: i, j, num_nz_rows_, adr1, adr2 !------------------------------------------- num_nz_rows_ = 0 if(present(num_nz_rows)) then @@ -182,7 +182,7 @@ contains type(SELLC_${s1}$), intent(out) :: SELLC integer, intent(in), optional :: chunk ${t1}$, parameter :: zero = zero_${s1}$ - integer :: i, j, num_chunks + integer(ilp) :: i, j, num_chunks if(present(chunk)) SELLC%chunk_size = chunk @@ -243,10 +243,10 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) recursive subroutine quicksort_i_${s1}$(a, b, first, last) integer, parameter :: wp = sp - integer, intent(inout) :: a(*) !! reference table to sort + integer(ilp), intent(inout) :: a(*) !! reference table to sort ${t1}$, intent(inout) :: b(*) !! secondary real data to sort w.r.t. a - integer, intent(in) :: first, last - integer :: i, j, x, t + integer(ilp), intent(in) :: first, last + integer(ilp) :: i, j, x, t ${t1}$ :: d x = a( (first+last) / 2 ) @@ -273,14 +273,14 @@ contains subroutine sort_coo_unique( a, n, num_rows, num_cols ) !! Sort a 2d array in increasing order first by index 1 and then by index 2 - integer, intent(inout) :: a(2,*) - integer, intent(inout) :: n - integer, intent(in) :: num_rows - integer, intent(in) :: num_cols - - integer :: stride, adr0, adr1, dd - integer :: n_i, pos, ed - integer, allocatable :: count_i(:), count_i_aux(:), rows_(:), cols_(:) + integer(ilp), intent(inout) :: a(2,*) + integer(ilp), intent(inout) :: n + integer(ilp), intent(in) :: num_rows + integer(ilp), intent(in) :: num_cols + + integer(ilp) :: stride, adr0, adr1, dd + integer(ilp) :: n_i, pos, ed + integer(ilp), allocatable :: count_i(:), count_i_aux(:), rows_(:), cols_(:) !--------------------------------------------------------- ! Sort a first time with respect to first index using count sort allocate( count_i( 0:num_rows ) , source = 0 ) @@ -328,14 +328,14 @@ contains subroutine sort_coo_unique_${s1}$( a, data, n, num_rows, num_cols ) !! Sort a 2d array in increasing order first by index 1 and then by index 2 ${t1}$, intent(inout) :: data(*) - integer, intent(inout) :: a(2,*) - integer, intent(inout) :: n - integer, intent(in) :: num_rows - integer, intent(in) :: num_cols - - integer :: stride, adr0, adr1, dd - integer :: n_i, pos, ed - integer, allocatable :: count_i(:), count_i_aux(:), rows_(:), cols_(:) + integer(ilp), intent(inout) :: a(2,*) + integer(ilp), intent(inout) :: n + integer(ilp), intent(in) :: num_rows + integer(ilp), intent(in) :: num_cols + + integer(ilp) :: stride, adr0, adr1, dd + integer(ilp) :: n_i, pos, ed + integer(ilp), allocatable :: count_i(:), count_i_aux(:), rows_(:), cols_(:) ${t1}$, allocatable :: temp(:) !--------------------------------------------------------- ! Sort a first time with respect to first index using Count sort @@ -390,7 +390,7 @@ contains module subroutine coo2ordered(COO,sort_data) class(COO_type), intent(inout) :: COO logical, intent(in), optional :: sort_data - integer, allocatable :: itemp(:,:) + integer(ilp), allocatable :: itemp(:,:) logical :: sort_data_ if(COO%is_sorted) return diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 42180f8c9..127dbee91 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -19,6 +19,9 @@ module stdlib_sparse_kinds end enum public :: sparse_full, sparse_lower, sparse_upper + ! Integer size support for ILP64 builds should be done here + integer, parameter :: ilp = int32 + #:for k1, t1, s1 in (R_KINDS_TYPES) ${t1}$, parameter :: zero_${s1}$ = 0._${k1}$ ${t1}$, parameter :: one_${s1}$ = 1._${k1}$ @@ -32,9 +35,9 @@ module stdlib_sparse_kinds !! !! Base sparse type holding the meta data related to the storage capacity of a matrix. type, public, abstract :: sparse_type - integer :: nrows = 0 !! number of rows - integer :: ncols = 0 !! number of columns - integer :: nnz = 0 !! number of non-zero values + integer(ilp) :: nrows = 0 !! number of rows + integer(ilp) :: ncols = 0 !! number of columns + integer(ilp) :: nnz = 0 !! number of non-zero values integer :: storage = sparse_full !! assumed storage symmetry end type @@ -43,7 +46,7 @@ module stdlib_sparse_kinds !! COO: COOrdinates compresed format type, public, extends(sparse_type) :: COO_type logical :: is_sorted = .false. !! whether the matrix is sorted or not - integer, allocatable :: index(:,:) !! Matrix coordinates index(2,nnz) + integer(ilp), allocatable :: index(:,:) !! Matrix coordinates index(2,nnz) contains procedure :: malloc => malloc_coo end type @@ -63,8 +66,8 @@ module stdlib_sparse_kinds !! !! CSR: Compressed sparse row or Yale format type, public, extends(sparse_type) :: CSR_type - integer, allocatable :: col(:) !! matrix column pointer - integer, allocatable :: rowptr(:) !! matrix row pointer + integer(ilp), allocatable :: col(:) !! matrix column pointer + integer(ilp), allocatable :: rowptr(:) !! matrix row pointer contains procedure :: malloc => malloc_csr end type @@ -84,8 +87,8 @@ module stdlib_sparse_kinds !! !! CSC: Compressed sparse column type, public, extends(sparse_type) :: CSC_type - integer, allocatable :: colptr(:) !! matrix column pointer - integer, allocatable :: row(:) !! matrix row pointer + integer(ilp), allocatable :: colptr(:) !! matrix column pointer + integer(ilp), allocatable :: row(:) !! matrix row pointer contains procedure :: malloc => malloc_csc end type @@ -106,7 +109,7 @@ module stdlib_sparse_kinds !! Compressed ELLPACK type, public, extends(sparse_type) :: ELL_type integer :: K = 0 !! maximum number of nonzeros per row - integer, allocatable :: index(:,:) !! column indices + integer(ilp), allocatable :: index(:,:) !! column indices contains procedure :: malloc => malloc_ell end type @@ -128,8 +131,8 @@ module stdlib_sparse_kinds !! Reference : https://library.eecs.utk.edu/storage/files/ut-eecs-14-727.pdf type, public, extends(sparse_type) :: SELLC_type integer :: chunk_size = 8 !! default chunk size - integer, allocatable :: rowptr(:) !! row pointer - integer, allocatable :: col(:,:) !! column indices + integer(ilp), allocatable :: rowptr(:) !! row pointer + integer(ilp), allocatable :: col(:,:) !! column indices end type #:for k1, t1, s1 in (KINDS_TYPES) @@ -337,11 +340,11 @@ contains !! (re)Allocate matrix memory for the COO type subroutine malloc_coo(self,num_rows,num_cols,nnz) class(COO_type) :: self - integer, intent(in) :: num_rows !! number of rows - integer, intent(in) :: num_cols !! number of columns - integer, intent(in) :: nnz !! number of non zeros + integer(ilp), intent(in) :: num_rows !! number of rows + integer(ilp), intent(in) :: num_cols !! number of columns + integer(ilp), intent(in) :: nnz !! number of non zeros - integer, allocatable :: temp_idx(:,:) + integer(ilp), allocatable :: temp_idx(:,:) !----------------------------------------------------- self%nrows = num_rows @@ -374,11 +377,11 @@ contains !! (re)Allocate matrix memory for the CSR type subroutine malloc_csr(self,num_rows,num_cols,nnz) class(CSR_type) :: self - integer, intent(in) :: num_rows !! number of rows - integer, intent(in) :: num_cols !! number of columns - integer, intent(in) :: nnz !! number of non zeros + integer(ilp), intent(in) :: num_rows !! number of rows + integer(ilp), intent(in) :: num_cols !! number of columns + integer(ilp), intent(in) :: nnz !! number of non zeros - integer, allocatable :: temp_idx(:) + integer(ilp), allocatable :: temp_idx(:) !----------------------------------------------------- self%nrows = num_rows @@ -418,11 +421,11 @@ contains !! (re)Allocate matrix memory for the CSC type subroutine malloc_csc(self,num_rows,num_cols,nnz) class(CSC_type) :: self - integer, intent(in) :: num_rows !! number of rows - integer, intent(in) :: num_cols !! number of columns - integer, intent(in) :: nnz !! number of non zeros + integer(ilp), intent(in) :: num_rows !! number of rows + integer(ilp), intent(in) :: num_cols !! number of columns + integer(ilp), intent(in) :: nnz !! number of non zeros - integer, allocatable :: temp_idx(:) + integer(ilp), allocatable :: temp_idx(:) !----------------------------------------------------- self%nrows = num_rows @@ -462,11 +465,11 @@ contains !! (re)Allocate matrix memory for the ELLPACK type subroutine malloc_ell(self,num_rows,num_cols,num_nz_rows) class(ELL_type) :: self - integer, intent(in) :: num_rows !! number of rows - integer, intent(in) :: num_cols !! number of columns - integer, intent(in) :: num_nz_rows !! number of non zeros per row + integer(ilp), intent(in) :: num_rows !! number of rows + integer(ilp), intent(in) :: num_cols !! number of columns + integer(ilp), intent(in) :: num_nz_rows !! number of non zeros per row - integer, allocatable :: temp_idx(:,:) + integer(ilp), allocatable :: temp_idx(:,:) !----------------------------------------------------- self%nrows = num_rows @@ -498,12 +501,12 @@ contains subroutine coo_from_ijv_type(COO,row,col,nrows,ncols) type(COO_type), intent(inout) :: COO - integer, intent(in) :: row(:) - integer, intent(in) :: col(:) - integer, intent(in), optional :: nrows - integer, intent(in), optional :: ncols + integer(ilp), intent(in) :: row(:) + integer(ilp), intent(in) :: col(:) + integer(ilp), intent(in), optional :: nrows + integer(ilp), intent(in), optional :: ncols - integer :: nrows_, ncols_, nnz, ed + integer(ilp) :: nrows_, ncols_, nnz, ed !--------------------------------------------------------- if(present(nrows)) then nrows_ = nrows @@ -528,13 +531,13 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) subroutine coo_from_ijv_${s1}$(COO,row,col,data,nrows,ncols) type(COO_${s1}$), intent(inout) :: COO - integer, intent(in) :: row(:) - integer, intent(in) :: col(:) + integer(ilp), intent(in) :: row(:) + integer(ilp), intent(in) :: col(:) ${t1}$, intent(in), optional :: data(:) - integer, intent(in), optional :: nrows - integer, intent(in), optional :: ncols + integer(ilp), intent(in), optional :: nrows + integer(ilp), intent(in), optional :: ncols - integer :: nrows_, ncols_, nnz, ed + integer(ilp) :: nrows_, ncols_, nnz, ed !--------------------------------------------------------- if(present(nrows)) then nrows_ = nrows @@ -561,13 +564,13 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) subroutine csr_from_ijv_${s1}$(CSR,row,col,data,nrows,ncols) type(CSR_${s1}$), intent(inout) :: CSR - integer, intent(in) :: row(:) - integer, intent(in) :: col(:) + integer(ilp), intent(in) :: row(:) + integer(ilp), intent(in) :: col(:) ${t1}$, intent(in), optional :: data(:) - integer, intent(in), optional :: nrows - integer, intent(in), optional :: ncols + integer(ilp), intent(in), optional :: nrows + integer(ilp), intent(in), optional :: ncols - integer :: nrows_, ncols_ + integer(ilp) :: nrows_, ncols_ !--------------------------------------------------------- if(present(nrows)) then nrows_ = nrows @@ -595,14 +598,14 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) subroutine ell_from_ijv_${s1}$(ELL,row,col,data,nrows,ncols,num_nz_rows) type(ELL_${s1}$), intent(inout) :: ELL - integer, intent(in) :: row(:) - integer, intent(in) :: col(:) + integer(ilp), intent(in) :: row(:) + integer(ilp), intent(in) :: col(:) ${t1}$, intent(in), optional :: data(:) - integer, intent(in), optional :: nrows - integer, intent(in), optional :: ncols + integer(ilp), intent(in), optional :: nrows + integer(ilp), intent(in), optional :: ncols integer, intent(in), optional :: num_nz_rows - integer :: nrows_, ncols_ + integer(ilp) :: nrows_, ncols_ !--------------------------------------------------------- if(present(nrows)) then nrows_ = nrows @@ -636,14 +639,14 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) subroutine sellc_from_ijv_${s1}$(SELLC,row,col,data,nrows,ncols,chunk) type(SELLC_${s1}$), intent(inout) :: SELLC - integer, intent(in) :: row(:) - integer, intent(in) :: col(:) + integer(ilp), intent(in) :: row(:) + integer(ilp), intent(in) :: col(:) ${t1}$, intent(in), optional :: data(:) - integer, intent(in), optional :: nrows - integer, intent(in), optional :: ncols + integer(ilp), intent(in), optional :: nrows + integer(ilp), intent(in), optional :: ncols integer, intent(in), optional :: chunk - integer :: nrows_, ncols_ + integer(ilp) :: nrows_, ncols_ !--------------------------------------------------------- if(present(nrows)) then nrows_ = nrows @@ -678,8 +681,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function at_value_coo_${s1}$(self,ik,jk) result(val) class(COO_${s1}$), intent(in) :: self - integer, intent(in) :: ik, jk - integer :: k, ik_, jk_ + integer(ilp), intent(in) :: ik, jk + integer(ilp) :: k, ik_, jk_ logical :: transpose ! naive implementation if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then @@ -703,8 +706,8 @@ contains subroutine add_value_coo_${s1}$(self,ik,jk,val) class(COO_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val - integer, intent(in) :: ik, jk - integer :: k + integer(ilp), intent(in) :: ik, jk + integer(ilp) :: k ! naive implementation do k = 1,self%nnz if( ik == self%index(1,k) .and. jk == self%index(2,k) ) then @@ -717,8 +720,8 @@ contains subroutine add_block_coo_${s1}$(self,ik,jk,val) class(COO_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val(:,:) - integer, intent(in) :: ik(:), jk(:) - integer :: k, i, j + integer(ilp), intent(in) :: ik(:), jk(:) + integer(ilp) :: k, i, j ! naive implementation do k = 1, self%nnz do i = 1, size(ik) @@ -736,8 +739,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function at_value_csr_${s1}$(self,ik,jk) result(val) class(CSR_${s1}$), intent(in) :: self - integer, intent(in) :: ik, jk - integer :: k, ik_, jk_ + integer(ilp), intent(in) :: ik, jk + integer(ilp) :: k, ik_, jk_ logical :: transpose ! naive implementation if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then @@ -761,8 +764,8 @@ contains subroutine add_value_csr_${s1}$(self,ik,jk,val) class(CSR_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val - integer, intent(in) :: ik, jk - integer :: k + integer(ilp), intent(in) :: ik, jk + integer(ilp) :: k ! naive implementation do k = self%rowptr(ik), self%rowptr(ik+1)-1 if( jk == self%col(k) ) then @@ -775,8 +778,8 @@ contains subroutine add_block_csr_${s1}$(self,ik,jk,val) class(CSR_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val(:,:) - integer, intent(in) :: ik(:), jk(:) - integer :: k, i, j + integer(ilp), intent(in) :: ik(:), jk(:) + integer(ilp) :: k, i, j ! naive implementation do i = 1, size(ik) do k = self%rowptr(ik(i)), self%rowptr(ik(i)+1)-1 @@ -794,8 +797,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function at_value_csc_${s1}$(self,ik,jk) result(val) class(CSC_${s1}$), intent(in) :: self - integer, intent(in) :: ik, jk - integer :: k, ik_, jk_ + integer(ilp), intent(in) :: ik, jk + integer(ilp) :: k, ik_, jk_ logical :: transpose ! naive implementation if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then @@ -819,8 +822,8 @@ contains subroutine add_value_csc_${s1}$(self,ik,jk,val) class(CSC_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val - integer, intent(in) :: ik, jk - integer :: k + integer(ilp), intent(in) :: ik, jk + integer(ilp) :: k ! naive implementation do k = self%colptr(jk), self%colptr(jk+1)-1 if( ik == self%row(k) ) then @@ -833,8 +836,8 @@ contains subroutine add_block_csc_${s1}$(self,ik,jk,val) class(CSC_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val(:,:) - integer, intent(in) :: ik(:), jk(:) - integer :: k, i, j + integer(ilp), intent(in) :: ik(:), jk(:) + integer(ilp) :: k, i, j ! naive implementation do j = 1, size(jk) do k = self%colptr(jk(j)), self%colptr(jk(j)+1)-1 @@ -852,8 +855,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function at_value_ell_${s1}$(self,ik,jk) result(val) class(ELL_${s1}$), intent(in) :: self - integer, intent(in) :: ik, jk - integer :: k, ik_, jk_ + integer(ilp), intent(in) :: ik, jk + integer(ilp) :: k, ik_, jk_ logical :: transpose ! naive implementation if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then @@ -877,8 +880,8 @@ contains subroutine add_value_ell_${s1}$(self,ik,jk,val) class(ELL_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val - integer, intent(in) :: ik, jk - integer :: k + integer(ilp), intent(in) :: ik, jk + integer(ilp) :: k ! naive implementation do k = 1 , self%K if( jk == self%index(ik,k) ) then @@ -891,8 +894,8 @@ contains subroutine add_block_ell_${s1}$(self,ik,jk,val) class(ELL_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val(:,:) - integer, intent(in) :: ik(:), jk(:) - integer :: k, i, j + integer(ilp), intent(in) :: ik(:), jk(:) + integer(ilp) :: k, i, j ! naive implementation do k = 1 , self%K do j = 1, size(jk) @@ -910,8 +913,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function at_value_sellc_${s1}$(self,ik,jk) result(val) class(SELLC_${s1}$), intent(in) :: self - integer, intent(in) :: ik, jk - integer :: k, ik_, jk_, idx + integer(ilp), intent(in) :: ik, jk + integer(ilp) :: k, ik_, jk_, idx logical :: transpose ! naive implementation if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then @@ -937,8 +940,8 @@ contains subroutine add_value_sellc_${s1}$(self,ik,jk,val) class(SELLC_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val - integer, intent(in) :: ik, jk - integer :: k, idx + integer(ilp), intent(in) :: ik, jk + integer(ilp) :: k, idx ! naive implementation idx = self%rowptr((ik - 1)/self%chunk_size + 1) do k = 1, self%chunk_size @@ -952,8 +955,8 @@ contains subroutine add_block_sellc_${s1}$(self,ik,jk,val) class(SELLC_${s1}$), intent(inout) :: self ${t1}$, intent(in) :: val(:,:) - integer, intent(in) :: ik(:), jk(:) - integer :: k, i, j, idx + integer(ilp), intent(in) :: ik(:), jk(:) + integer(ilp) :: k, i, j, idx ! naive implementation do k = 1 , self%chunk_size do j = 1, size(jk) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index b569aafb6..e329c75c0 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -25,7 +25,7 @@ contains ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta ${t1}$ :: alpha_, beta_ - integer :: k, ik, jk + integer(ilp) :: k, ik, jk alpha_ = one_${k1}$ if(present(alpha)) alpha_ = alpha @@ -68,7 +68,7 @@ contains ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta ${t1}$ :: alpha_, beta_ - integer :: i, j + integer(ilp) :: i, j #:if rank == 1 ${t1}$ :: aux, aux2 #:else @@ -148,7 +148,7 @@ contains ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta ${t1}$ :: alpha_, beta_ - integer :: i, j + integer(ilp) :: i, j #:if rank == 1 ${t1}$ :: aux #:else @@ -212,7 +212,7 @@ contains ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta ${t1}$ :: alpha_, beta_ - integer :: i, j, k + integer(ilp) :: i, j, k alpha_ = one_${k1}$ if(present(alpha)) alpha_ = alpha @@ -247,7 +247,7 @@ contains ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta ${t1}$ :: alpha_, beta_ - integer :: i, nz, rowidx, num_chunks, rm + integer(ilp) :: i, nz, rowidx, num_chunks, rm alpha_ = one_${s1}$ if(present(alpha)) alpha_ = alpha @@ -292,7 +292,7 @@ contains pure subroutine chunk_kernel_${chunk}$(nz,a,ja,x,y) integer, value :: nz ${t1}$, intent(in) :: a(${chunk}$,nz), x(*) - integer, intent(in) :: ja(${chunk}$,nz) + integer(ilp), intent(in) :: ja(${chunk}$,nz) ${t1}$, intent(inout) :: y(${chunk}$) integer :: j do j = 1, nz @@ -304,7 +304,7 @@ contains pure subroutine chunk_kernel_remainder(nz,cs,rm,a,ja,x,y) integer, value :: nz, cs, rm ${t1}$, intent(in) :: a(cs,nz), x(*) - integer, intent(in) :: ja(cs,nz) + integer(ilp), intent(in) :: ja(cs,nz) ${t1}$, intent(inout) :: y(rm) integer :: j do j = 1, nz From 3596f3fdd10a444f4abacb40ff6e84d5fcd70c78 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Fri, 12 Jul 2024 23:43:16 +0200 Subject: [PATCH 61/78] add the _type suffix to all sparse types --- doc/specs/stdlib_sparse.md | 10 +- .../linalg/example_sparse_data_accessors.f90 | 4 +- example/linalg/example_sparse_from_ijv.f90 | 6 +- example/linalg/example_sparse_spmv.f90 | 4 +- src/stdlib_sparse_conversion.fypp | 24 ++--- src/stdlib_sparse_kinds.fypp | 98 +++++++++---------- src/stdlib_sparse_spmv.fypp | 10 +- test/linalg/test_sparse_spmv.fypp | 22 ++--- 8 files changed, 89 insertions(+), 89 deletions(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 2e8e6ceb5..88d28d4f0 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -39,7 +39,7 @@ enum, bind(C) enumerator :: sparse_upper !! Symmetric Sparse matrix with triangular supperior storage end enum ``` -In the following, all sparse kinds will be presented in two main flavors: a data-less type `_type` useful for topological graph operations. And real/complex valued types `_` containing the `data` buffer for the matrix values. The following rectangular matrix will be used to showcase how each sparse matrix holds the data internally: +In the following, all sparse kinds will be presented in two main flavors: a data-less type `_type` useful for topological graph operations. And real/complex valued types `__type` containing the `data` buffer for the matrix values. The following rectangular matrix will be used to showcase how each sparse matrix holds the data internally: $$ M = \begin{bmatrix} 9 & 0 & 0 & 0 & -3 \\ @@ -57,7 +57,7 @@ Experimental The `COO`, triplet or `ijv` format defines all non-zero elements of the matrix by explicitly allocating the `i,j` index and the value of the matrix. While some implementations use separate `row` and `col` arrays for the index, here we use a 2D array in order to promote fast memory acces to `ij`. ```Fortran -type(COO_sp) :: COO +type(COO_sp_type) :: COO call COO%malloc(4,5,10) COO%data(:) = real([9,-3,4,7,8,-1,8,4,5,6]) COO%index(1:2,1) = [1,1] @@ -81,7 +81,7 @@ Experimental The Compressed Sparse Row or Yale format `CSR` stores the matrix structure by compressing the row indices with a counter pointer `rowptr` enabling to know the first and last non-zero column index `col` of the given row. ```Fortran -type(CSR_sp) :: CSR +type(CSR_sp_type) :: CSR call CSR%malloc(4,5,10) CSR%data(:) = real([9,-3,4,7,8,-1,8,4,5,6]) CSR%col(:) = [1,5,1,2,2,3,4,1,3,4] @@ -97,7 +97,7 @@ Experimental The Compressed Sparse Colum `CSC` is similar to the `CSR` format but values are accesed first by column, thus an index counter is given by `colptr` which enables to know the first and last non-zero row index of a given colum. ```Fortran -type(CSC_sp) :: CSC +type(CSC_sp_type) :: CSC call CSC%malloc(4,5,10) CSC%data(:) = real([9,4,4,7,8,-1,5,8,6,-3]) CSC%row(:) = [1,2,4,2,3,3,4,3,4,1] @@ -113,7 +113,7 @@ Experimental The `ELL` format stores data in a dense matrix of $nrows \times K$ in column major order. By imposing a constant number of elements per row $K$, this format will incur in additional zeros being stored, but it enables efficient vectorization as memory acces is carried out by constant sized strides. ```Fortran -type(ELL_sp) :: ELL +type(ELL_sp_type) :: ELL call ELL%malloc(num_rows=4,num_cols=5,num_nz_row=3) ELL%data(1,1:3) = real([9,-3,0]) ELL%data(2,1:3) = real([4,7,0]) diff --git a/example/linalg/example_sparse_data_accessors.f90 b/example/linalg/example_sparse_data_accessors.f90 index e4de820f3..e23164524 100644 --- a/example/linalg/example_sparse_data_accessors.f90 +++ b/example/linalg/example_sparse_data_accessors.f90 @@ -5,8 +5,8 @@ program example_sparse_data_accessors real(dp) :: mat(2,2) real(dp), allocatable :: dense(:,:) - type(CSR_dp) :: CSR - type(COO_dp) :: COO + type(CSR_dp_type) :: CSR + type(COO_dp_type) :: COO integer :: i, j, locdof(2) ! Initial data diff --git a/example/linalg/example_sparse_from_ijv.f90 b/example/linalg/example_sparse_from_ijv.f90 index 1382cd3dd..628955361 100644 --- a/example/linalg/example_sparse_from_ijv.f90 +++ b/example/linalg/example_sparse_from_ijv.f90 @@ -5,9 +5,9 @@ program example_sparse_from_ijv integer :: row(10), col(10) real(dp) :: data(10) - type(COO_dp) :: COO - type(CSR_dp) :: CSR - type(ELL_dp) :: ELL + type(COO_dp_type) :: COO + type(CSR_dp_type) :: CSR + type(ELL_dp_type) :: ELL integer :: i, j ! Initial data diff --git a/example/linalg/example_sparse_spmv.f90 b/example/linalg/example_sparse_spmv.f90 index 25052710c..27b27b8db 100644 --- a/example/linalg/example_sparse_spmv.f90 +++ b/example/linalg/example_sparse_spmv.f90 @@ -7,8 +7,8 @@ program example_sparse_spmv real(dp) :: A(m,n), x(n) real(dp) :: y_dense(m), y_coo(m), y_csr(m) real(dp) :: alpha, beta - type(COO_dp) :: COO - type(CSR_dp) :: CSR + type(COO_dp_type) :: COO + type(CSR_dp_type) :: CSR call random_number(A) ! Convert from dense to COO and CSR matrices diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 7918f5ade..d81508ecd 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -23,7 +23,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine dense2coo_${s1}$(dense,COO) ${t1}$, intent(in) :: dense(:,:) - type(COO_${s1}$), intent(out) :: COO + type(COO_${s1}$_type), intent(out) :: COO integer(ilp) :: num_rows, num_cols, nnz integer(ilp) :: i, j, idx @@ -50,7 +50,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine coo2dense_${s1}$(COO,dense) - type(COO_${s1}$), intent(in) :: COO + type(COO_${s1}$_type), intent(in) :: COO ${t1}$, allocatable, intent(out) :: dense(:,:) integer(ilp) :: idx @@ -64,8 +64,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine coo2csr_${s1}$(COO,CSR) - type(COO_${s1}$), intent(in) :: COO - type(CSR_${s1}$), intent(out) :: CSR + type(COO_${s1}$_type), intent(in) :: COO + type(CSR_${s1}$_type), intent(out) :: CSR integer(ilp) :: i CSR%nnz = COO%nnz; CSR%nrows = COO%nrows; CSR%ncols = COO%ncols @@ -94,7 +94,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2dense_${s1}$(CSR,dense) - type(CSR_${s1}$), intent(in) :: CSR + type(CSR_${s1}$_type), intent(in) :: CSR ${t1}$, allocatable, intent(out) :: dense(:,:) integer(ilp) :: i, j @@ -120,8 +120,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2coo_${s1}$(CSR,COO) - type(CSR_${s1}$), intent(in) :: CSR - type(COO_${s1}$), intent(out) :: COO + type(CSR_${s1}$_type), intent(in) :: CSR + type(COO_${s1}$_type), intent(out) :: COO integer(ilp) :: i, j COO%nnz = CSR%nnz; COO%nrows = CSR%nrows; COO%ncols = CSR%ncols @@ -146,8 +146,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows) - type(CSR_${s1}$), intent(in) :: CSR - type(ELL_${s1}$), intent(out) :: ELL + type(CSR_${s1}$_type), intent(in) :: CSR + type(ELL_${s1}$_type), intent(out) :: ELL integer, intent(in), optional :: num_nz_rows !! number of non zeros per row integer(ilp) :: i, j, num_nz_rows_, adr1, adr2 @@ -178,8 +178,8 @@ contains module subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) !! csr2sellc: This function enables transfering data from a CSR matrix to a SELL-C matrix !! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves - type(CSR_${s1}$), intent(in) :: CSR - type(SELLC_${s1}$), intent(out) :: SELLC + type(CSR_${s1}$_type), intent(in) :: CSR + type(SELLC_${s1}$_type), intent(out) :: SELLC integer, intent(in), optional :: chunk ${t1}$, parameter :: zero = zero_${s1}$ integer(ilp) :: i, j, num_chunks @@ -402,7 +402,7 @@ contains type is( COO_type ) call sort_coo(COO%index, COO%nnz, COO%nrows, COO%ncols) #:for k1, t1, s1 in (KINDS_TYPES) - type is( COO_${s1}$ ) + type is( COO_${s1}$_type ) block ${t1}$, allocatable :: temp(:) if( sort_data_ ) then diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 127dbee91..baa21851c 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -52,7 +52,7 @@ module stdlib_sparse_kinds end type #:for k1, t1, s1 in (KINDS_TYPES) - type, public, extends(COO_type) :: COO_${s1}$ + type, public, extends(COO_type) :: COO_${s1}$_type ${t1}$, allocatable :: data(:) contains procedure, non_overridable :: at => at_value_coo_${s1}$ @@ -73,7 +73,7 @@ module stdlib_sparse_kinds end type #:for k1, t1, s1 in (KINDS_TYPES) - type, public, extends(CSR_type) :: CSR_${s1}$ + type, public, extends(CSR_type) :: CSR_${s1}$_type ${t1}$, allocatable :: data(:) contains procedure, non_overridable :: at => at_value_csr_${s1}$ @@ -94,7 +94,7 @@ module stdlib_sparse_kinds end type #:for k1, t1, s1 in (KINDS_TYPES) - type, public, extends(CSC_type) :: CSC_${s1}$ + type, public, extends(CSC_type) :: CSC_${s1}$_type ${t1}$, allocatable :: data(:) contains procedure, non_overridable :: at => at_value_csc_${s1}$ @@ -115,7 +115,7 @@ module stdlib_sparse_kinds end type #:for k1, t1, s1 in (KINDS_TYPES) - type, public, extends(ELL_type) :: ELL_${s1}$ + type, public, extends(ELL_type) :: ELL_${s1}$_type ${t1}$, allocatable :: data(:,:) contains procedure, non_overridable :: at => at_value_ell_${s1}$ @@ -136,7 +136,7 @@ module stdlib_sparse_kinds end type #:for k1, t1, s1 in (KINDS_TYPES) - type, public, extends(SELLC_type) :: SELLC_${s1}$ + type, public, extends(SELLC_type) :: SELLC_${s1}$_type ${t1}$, allocatable :: data(:,:) contains procedure, non_overridable :: at => at_value_sellc_${s1}$ @@ -156,7 +156,7 @@ module stdlib_sparse_kinds #:for k1, t1, s1 in (KINDS_TYPES) module subroutine dense2coo_${s1}$(dense,COO) ${t1}$, intent(in) :: dense(:,:) - type(COO_${s1}$), intent(out) :: COO + type(COO_${s1}$_type), intent(out) :: COO end subroutine #:endfor end interface @@ -171,7 +171,7 @@ module stdlib_sparse_kinds interface coo2dense #:for k1, t1, s1 in (KINDS_TYPES) module subroutine coo2dense_${s1}$(COO,dense) - type(COO_${s1}$), intent(in) :: COO + type(COO_${s1}$_type), intent(in) :: COO ${t1}$, allocatable, intent(out) :: dense(:,:) end subroutine #:endfor @@ -187,8 +187,8 @@ module stdlib_sparse_kinds interface coo2csr #:for k1, t1, s1 in (KINDS_TYPES) module subroutine coo2csr_${s1}$(COO,CSR) - type(COO_${s1}$), intent(in) :: COO - type(CSR_${s1}$), intent(out) :: CSR + type(COO_${s1}$_type), intent(in) :: COO + type(CSR_${s1}$_type), intent(out) :: CSR end subroutine #:endfor end interface @@ -203,7 +203,7 @@ module stdlib_sparse_kinds interface csr2dense #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2dense_${s1}$(CSR,dense) - type(CSR_${s1}$), intent(in) :: CSR + type(CSR_${s1}$_type), intent(in) :: CSR ${t1}$, allocatable, intent(out) :: dense(:,:) end subroutine #:endfor @@ -219,8 +219,8 @@ module stdlib_sparse_kinds interface csr2coo #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2coo_${s1}$(CSR,COO) - type(CSR_${s1}$), intent(in) :: CSR - type(COO_${s1}$), intent(out) :: COO + type(CSR_${s1}$_type), intent(in) :: CSR + type(COO_${s1}$_type), intent(out) :: COO end subroutine #:endfor end interface @@ -235,8 +235,8 @@ module stdlib_sparse_kinds interface csr2ell #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows) - type(CSR_${s1}$), intent(in) :: CSR - type(ELL_${s1}$), intent(out) :: ELL + type(CSR_${s1}$_type), intent(in) :: CSR + type(ELL_${s1}$_type), intent(out) :: ELL integer, intent(in), optional :: num_nz_rows end subroutine #:endfor @@ -252,8 +252,8 @@ module stdlib_sparse_kinds interface csr2sellc #:for k1, t1, s1 in (KINDS_TYPES) module subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) - type(CSR_${s1}$), intent(in) :: CSR - type(SELLC_${s1}$), intent(out) :: SELLC + type(CSR_${s1}$_type), intent(in) :: CSR + type(SELLC_${s1}$_type), intent(out) :: SELLC integer, intent(in), optional :: chunk end subroutine #:endfor @@ -295,28 +295,28 @@ module stdlib_sparse_kinds #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS module subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(COO_${s1}$), intent(in) :: matrix + type(COO_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta end subroutine module subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(CSR_${s1}$), intent(in) :: matrix + type(CSR_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta end subroutine module subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(CSC_${s1}$), intent(in) :: matrix + type(CSC_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta end subroutine module subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(ELL_${s1}$), intent(in) :: matrix + type(ELL_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha @@ -325,7 +325,7 @@ module stdlib_sparse_kinds #:endfor module subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) !! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves - type(SELLC_${s1}$), intent(in) :: matrix + type(SELLC_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x(:) ${t1}$, intent(inout) :: vec_y(:) ${t1}$, intent(in), optional :: alpha @@ -360,7 +360,7 @@ contains select type(self) #:for k1, t1, s1 in (KINDS_TYPES) - type is(COO_${s1}$) + type is(COO_${s1}$_type) block ${t1}$, allocatable :: temp_data_${s1}$(:) if(.not.allocated(self%data)) then @@ -404,7 +404,7 @@ contains select type(self) #:for k1, t1, s1 in (KINDS_TYPES) - type is(CSR_${s1}$) + type is(CSR_${s1}$_type) block ${t1}$, allocatable :: temp_data_${s1}$(:) if(.not.allocated(self%data)) then @@ -448,7 +448,7 @@ contains select type(self) #:for k1, t1, s1 in (KINDS_TYPES) - type is(CSC_${s1}$) + type is(CSC_${s1}$_type) block ${t1}$, allocatable :: temp_data_${s1}$(:) if(.not.allocated(self%data)) then @@ -485,7 +485,7 @@ contains select type(self) #:for k1, t1, s1 in (KINDS_TYPES) - type is(ELL_${s1}$) + type is(ELL_${s1}$_type) block ${t1}$, allocatable :: temp_data_${s1}$(:,:) if(.not.allocated(self%data)) then @@ -530,7 +530,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) subroutine coo_from_ijv_${s1}$(COO,row,col,data,nrows,ncols) - type(COO_${s1}$), intent(inout) :: COO + type(COO_${s1}$_type), intent(inout) :: COO integer(ilp), intent(in) :: row(:) integer(ilp), intent(in) :: col(:) ${t1}$, intent(in), optional :: data(:) @@ -563,7 +563,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) subroutine csr_from_ijv_${s1}$(CSR,row,col,data,nrows,ncols) - type(CSR_${s1}$), intent(inout) :: CSR + type(CSR_${s1}$_type), intent(inout) :: CSR integer(ilp), intent(in) :: row(:) integer(ilp), intent(in) :: col(:) ${t1}$, intent(in), optional :: data(:) @@ -584,7 +584,7 @@ contains end if !--------------------------------------------------------- block - type(COO_${s1}$) :: COO + type(COO_${s1}$_type) :: COO if(present(data)) then call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) else @@ -597,7 +597,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) subroutine ell_from_ijv_${s1}$(ELL,row,col,data,nrows,ncols,num_nz_rows) - type(ELL_${s1}$), intent(inout) :: ELL + type(ELL_${s1}$_type), intent(inout) :: ELL integer(ilp), intent(in) :: row(:) integer(ilp), intent(in) :: col(:) ${t1}$, intent(in), optional :: data(:) @@ -619,8 +619,8 @@ contains end if !--------------------------------------------------------- block - type(COO_${s1}$) :: COO - type(CSR_${s1}$) :: CSR + type(COO_${s1}$_type) :: COO + type(CSR_${s1}$_type) :: CSR if(present(data)) then call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) else @@ -638,7 +638,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) subroutine sellc_from_ijv_${s1}$(SELLC,row,col,data,nrows,ncols,chunk) - type(SELLC_${s1}$), intent(inout) :: SELLC + type(SELLC_${s1}$_type), intent(inout) :: SELLC integer(ilp), intent(in) :: row(:) integer(ilp), intent(in) :: col(:) ${t1}$, intent(in), optional :: data(:) @@ -661,8 +661,8 @@ contains if(present(chunk)) SELLC%chunk_size = chunk !--------------------------------------------------------- block - type(COO_${s1}$) :: COO - type(CSR_${s1}$) :: CSR + type(COO_${s1}$_type) :: COO + type(CSR_${s1}$_type) :: CSR if(present(data)) then call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) else @@ -680,7 +680,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function at_value_coo_${s1}$(self,ik,jk) result(val) - class(COO_${s1}$), intent(in) :: self + class(COO_${s1}$_type), intent(in) :: self integer(ilp), intent(in) :: ik, jk integer(ilp) :: k, ik_, jk_ logical :: transpose @@ -704,7 +704,7 @@ contains end function subroutine add_value_coo_${s1}$(self,ik,jk,val) - class(COO_${s1}$), intent(inout) :: self + class(COO_${s1}$_type), intent(inout) :: self ${t1}$, intent(in) :: val integer(ilp), intent(in) :: ik, jk integer(ilp) :: k @@ -718,7 +718,7 @@ contains end subroutine subroutine add_block_coo_${s1}$(self,ik,jk,val) - class(COO_${s1}$), intent(inout) :: self + class(COO_${s1}$_type), intent(inout) :: self ${t1}$, intent(in) :: val(:,:) integer(ilp), intent(in) :: ik(:), jk(:) integer(ilp) :: k, i, j @@ -738,7 +738,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function at_value_csr_${s1}$(self,ik,jk) result(val) - class(CSR_${s1}$), intent(in) :: self + class(CSR_${s1}$_type), intent(in) :: self integer(ilp), intent(in) :: ik, jk integer(ilp) :: k, ik_, jk_ logical :: transpose @@ -762,7 +762,7 @@ contains end function subroutine add_value_csr_${s1}$(self,ik,jk,val) - class(CSR_${s1}$), intent(inout) :: self + class(CSR_${s1}$_type), intent(inout) :: self ${t1}$, intent(in) :: val integer(ilp), intent(in) :: ik, jk integer(ilp) :: k @@ -776,7 +776,7 @@ contains end subroutine subroutine add_block_csr_${s1}$(self,ik,jk,val) - class(CSR_${s1}$), intent(inout) :: self + class(CSR_${s1}$_type), intent(inout) :: self ${t1}$, intent(in) :: val(:,:) integer(ilp), intent(in) :: ik(:), jk(:) integer(ilp) :: k, i, j @@ -796,7 +796,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function at_value_csc_${s1}$(self,ik,jk) result(val) - class(CSC_${s1}$), intent(in) :: self + class(CSC_${s1}$_type), intent(in) :: self integer(ilp), intent(in) :: ik, jk integer(ilp) :: k, ik_, jk_ logical :: transpose @@ -820,7 +820,7 @@ contains end function subroutine add_value_csc_${s1}$(self,ik,jk,val) - class(CSC_${s1}$), intent(inout) :: self + class(CSC_${s1}$_type), intent(inout) :: self ${t1}$, intent(in) :: val integer(ilp), intent(in) :: ik, jk integer(ilp) :: k @@ -834,7 +834,7 @@ contains end subroutine subroutine add_block_csc_${s1}$(self,ik,jk,val) - class(CSC_${s1}$), intent(inout) :: self + class(CSC_${s1}$_type), intent(inout) :: self ${t1}$, intent(in) :: val(:,:) integer(ilp), intent(in) :: ik(:), jk(:) integer(ilp) :: k, i, j @@ -854,7 +854,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function at_value_ell_${s1}$(self,ik,jk) result(val) - class(ELL_${s1}$), intent(in) :: self + class(ELL_${s1}$_type), intent(in) :: self integer(ilp), intent(in) :: ik, jk integer(ilp) :: k, ik_, jk_ logical :: transpose @@ -878,7 +878,7 @@ contains end function subroutine add_value_ell_${s1}$(self,ik,jk,val) - class(ELL_${s1}$), intent(inout) :: self + class(ELL_${s1}$_type), intent(inout) :: self ${t1}$, intent(in) :: val integer(ilp), intent(in) :: ik, jk integer(ilp) :: k @@ -892,7 +892,7 @@ contains end subroutine subroutine add_block_ell_${s1}$(self,ik,jk,val) - class(ELL_${s1}$), intent(inout) :: self + class(ELL_${s1}$_type), intent(inout) :: self ${t1}$, intent(in) :: val(:,:) integer(ilp), intent(in) :: ik(:), jk(:) integer(ilp) :: k, i, j @@ -912,7 +912,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) pure ${t1}$ function at_value_sellc_${s1}$(self,ik,jk) result(val) - class(SELLC_${s1}$), intent(in) :: self + class(SELLC_${s1}$_type), intent(in) :: self integer(ilp), intent(in) :: ik, jk integer(ilp) :: k, ik_, jk_, idx logical :: transpose @@ -938,7 +938,7 @@ contains end function subroutine add_value_sellc_${s1}$(self,ik,jk,val) - class(SELLC_${s1}$), intent(inout) :: self + class(SELLC_${s1}$_type), intent(inout) :: self ${t1}$, intent(in) :: val integer(ilp), intent(in) :: ik, jk integer(ilp) :: k, idx @@ -953,7 +953,7 @@ contains end subroutine subroutine add_block_sellc_${s1}$(self,ik,jk,val) - class(SELLC_${s1}$), intent(inout) :: self + class(SELLC_${s1}$_type), intent(inout) :: self ${t1}$, intent(in) :: val(:,:) integer(ilp), intent(in) :: ik(:), jk(:) integer(ilp) :: k, i, j, idx diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index e329c75c0..9a2ef3f48 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -19,7 +19,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS module subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(COO_${s1}$), intent(in) :: matrix + type(COO_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha @@ -62,7 +62,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS module subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(CSR_${s1}$), intent(in) :: matrix + type(CSR_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha @@ -142,7 +142,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS module subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(CSC_${s1}$), intent(in) :: matrix + type(CSC_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha @@ -206,7 +206,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS module subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(ELL_${s1}$), intent(in) :: matrix + type(ELL_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha @@ -241,7 +241,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) module subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) !! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves - type(SELLC_${s1}$), intent(in) :: matrix + type(SELLC_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x(:) ${t1}$, intent(inout) :: vec_y(:) ${t1}$, intent(in), optional :: alpha diff --git a/test/linalg/test_sparse_spmv.fypp b/test/linalg/test_sparse_spmv.fypp index 8638ef2cd..0f42cad5b 100644 --- a/test/linalg/test_sparse_spmv.fypp +++ b/test/linalg/test_sparse_spmv.fypp @@ -34,7 +34,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) block integer, parameter :: wp = ${k1}$ - type(COO_${s1}$) :: COO + type(COO_${s1}$_type) :: COO ${t1}$, allocatable :: dense(:,:) ${t1}$, allocatable :: vec_x(:) ${t1}$, allocatable :: vec_y1(:), vec_y2(:) @@ -67,7 +67,7 @@ contains subroutine test_coo2ordered(error) !> Error handling type(error_type), allocatable, intent(out) :: error - type(COO_sp) :: COO + type(COO_sp_type) :: COO integer :: row(12), col(12) real :: data(12) @@ -98,7 +98,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) block integer, parameter :: wp = ${k1}$ - type(CSR_${s1}$) :: CSR + type(CSR_${s1}$_type) :: CSR ${t1}$, allocatable :: vec_x(:) ${t1}$, allocatable :: vec_y(:) @@ -123,7 +123,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) block integer, parameter :: wp = ${k1}$ - type(CSC_${s1}$) :: CSC + type(CSC_${s1}$_type) :: CSC ${t1}$, allocatable :: vec_x(:) ${t1}$, allocatable :: vec_y(:) @@ -148,7 +148,7 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) block integer, parameter :: wp = ${k1}$ - type(ELL_${s1}$) :: ELL + type(ELL_${s1}$_type) :: ELL ${t1}$, allocatable :: vec_x(:) ${t1}$, allocatable :: vec_y(:) @@ -180,8 +180,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) block integer, parameter :: wp = ${k1}$ - type(SELLC_${s1}$) :: SELLC - type(CSR_${s1}$) :: CSR + type(SELLC_${s1}$_type) :: SELLC + type(CSR_${s1}$_type) :: CSR ${t1}$, allocatable :: vec_x(:) ${t1}$, allocatable :: vec_y(:) integer :: i @@ -216,8 +216,8 @@ contains #:for k1, t1, s1 in (KINDS_TYPES) block integer, parameter :: wp = ${k1}$ - type(COO_${s1}$) :: COO - type(CSR_${s1}$) :: CSR + type(COO_${s1}$_type) :: COO + type(CSR_${s1}$_type) :: CSR ${t1}$, allocatable :: dense(:,:) ${t1}$, allocatable :: vec_x(:) ${t1}$, allocatable :: vec_y1(:), vec_y2(:), vec_y3(:) @@ -260,8 +260,8 @@ contains block integer, parameter :: wp = ${k1}$ real(wp) :: dense(5,5), mat(2,2) - type(COO_${s1}$) :: COO - type(CSR_${s1}$) :: CSR + type(COO_${s1}$_type) :: COO + type(CSR_${s1}$_type) :: CSR ${t1}$:: err integer :: i, j, locdof(2) From c8d94a3e2544da0f1d40f21967ac424c751c159a Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Wed, 31 Jul 2024 12:28:54 +0200 Subject: [PATCH 62/78] rollback on submodules --- src/stdlib_sparse.f90 | 2 + src/stdlib_sparse_constants.fypp | 28 +++ src/stdlib_sparse_conversion.fypp | 315 +++++++++++++++++++++++- src/stdlib_sparse_kinds.fypp | 385 +----------------------------- src/stdlib_sparse_spmv.fypp | 34 ++- 5 files changed, 360 insertions(+), 404 deletions(-) create mode 100644 src/stdlib_sparse_constants.fypp diff --git a/src/stdlib_sparse.f90 b/src/stdlib_sparse.f90 index 6465d68d5..4c1cbcf26 100644 --- a/src/stdlib_sparse.f90 +++ b/src/stdlib_sparse.f90 @@ -1,4 +1,6 @@ !! public API module stdlib_sparse use stdlib_sparse_kinds + use stdlib_sparse_conversion + use stdlib_sparse_spmv end module stdlib_sparse \ No newline at end of file diff --git a/src/stdlib_sparse_constants.fypp b/src/stdlib_sparse_constants.fypp new file mode 100644 index 000000000..9fbbe38f6 --- /dev/null +++ b/src/stdlib_sparse_constants.fypp @@ -0,0 +1,28 @@ +#:include "common.fypp" +#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX)) +#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX)) +module stdlib_sparse_constants + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp + + implicit none + public + + enum, bind(C) + enumerator :: sparse_full !! Full Sparse matrix (no symmetry considerations) + enumerator :: sparse_lower !! Symmetric Sparse matrix with triangular inferior storage + enumerator :: sparse_upper !! Symmetric Sparse matrix with triangular supperior storage + end enum + + ! Integer size support for ILP64 builds should be done here + integer, parameter :: ilp = int32 + + #:for k1, t1, s1 in (R_KINDS_TYPES) + ${t1}$, parameter :: zero_${s1}$ = 0._${k1}$ + ${t1}$, parameter :: one_${s1}$ = 1._${k1}$ + #:endfor + #:for k1, t1, s1 in (C_KINDS_TYPES) + ${t1}$, parameter :: zero_${s1}$ = (0._${k1}$,0._${k1}$) + ${t1}$, parameter :: one_${s1}$ = (1._${k1}$,1._${k1}$) + #:endfor + +end module stdlib_sparse_constants diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index d81508ecd..7516a223b 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -5,23 +5,133 @@ !! The `stdlib_sparse_conversion` submodule provides sparse to sparse matrix conversion utilities. !! ! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose -submodule(stdlib_sparse_kinds) stdlib_sparse_conversion +module stdlib_sparse_conversion use stdlib_sorting, only: sort + use stdlib_sparse_constants + use stdlib_sparse_kinds implicit none - + private !! Sort arrays of a COO matrix !! interface sort_coo - module procedure sort_coo_unique + module procedure :: sort_coo_unique + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: sort_coo_unique_${s1}$ + #:endfor + end interface + + !! version: experimental + !! + !! Conversion from dense to coo + !! Enables extracting the non-zero elements of a dense 2D matrix and + !! storing those values in a COO format. The coo matrix is (re)allocated on the fly. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface dense2coo + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: dense2coo_${s1}$ + #:endfor + end interface + public :: dense2coo + + !! version: experimental + !! + !! Conversion from coo to dense + !! Enables creating a dense 2D matrix from the non-zero values stored in a COO format + !! The dense matrix can be allocated on the fly if not pre-allocated by the user. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface coo2dense + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: coo2dense_${s1}$ + #:endfor + end interface + public :: coo2dense + + !! version: experimental + !! + !! Conversion from coo to csr + !! Enables transferring data from a COO matrix to a CSR matrix + !! under the hypothesis that the COO is already ordered. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface coo2csr + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: coo2csr_${s1}$ + #:endfor + end interface + public :: coo2csr + + !! version: experimental + !! + !! Conversion from csr to dense + !! Enables creating a dense 2D matrix from the non-zero values stored in a CSR format + !! The dense matrix can be allocated on the fly if not pre-allocated by the user. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface csr2dense + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: csr2dense_${s1}$ + #:endfor + end interface + public :: csr2dense + + !! version: experimental + !! + !! Conversion from csr to coo + !! Enables transferring data from a CSR matrix to a COO matrix + !! under the hypothesis that the CSR is already ordered. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface csr2coo + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: csr2coo_${s1}$ + #:endfor + end interface + public :: csr2coo + + !! version: experimental + !! + !! Conversion from csr to ell + !! Enables transferring data from a CSR matrix to a ELL matrix + !! under the hypothesis that the CSR is already ordered. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface csr2ell + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: csr2ell_${s1}$ + #:endfor + end interface + public :: csr2ell + + !! version: experimental + !! + !! Conversion from csr to SELL-C + !! Enables transferring data from a CSR matrix to a SELL-C matrix + !! It takes an optional parameter to decide the chunck size 4, 8 or 16 + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface csr2sellc #:for k1, t1, s1 in (KINDS_TYPES) - module procedure sort_coo_unique_${s1}$ + module procedure :: csr2sellc_${s1}$ #:endfor end interface + public :: csr2sellc + + !! version: experimental + !! + !! Enable creating a sparse matrix from ijv (row,col,data) triplet + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface from_ijv + module procedure :: coo_from_ijv_type + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: coo_from_ijv_${s1}$ + module procedure :: csr_from_ijv_${s1}$ + module procedure :: ell_from_ijv_${s1}$ + module procedure :: sellc_from_ijv_${s1}$ + #:endfor + end interface + public :: from_ijv + + public :: coo2ordered contains #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine dense2coo_${s1}$(dense,COO) + subroutine dense2coo_${s1}$(dense,COO) ${t1}$, intent(in) :: dense(:,:) type(COO_${s1}$_type), intent(out) :: COO integer(ilp) :: num_rows, num_cols, nnz @@ -49,7 +159,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine coo2dense_${s1}$(COO,dense) + subroutine coo2dense_${s1}$(COO,dense) type(COO_${s1}$_type), intent(in) :: COO ${t1}$, allocatable, intent(out) :: dense(:,:) integer(ilp) :: idx @@ -63,7 +173,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine coo2csr_${s1}$(COO,CSR) + subroutine coo2csr_${s1}$(COO,CSR) type(COO_${s1}$_type), intent(in) :: COO type(CSR_${s1}$_type), intent(out) :: CSR integer(ilp) :: i @@ -93,7 +203,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine csr2dense_${s1}$(CSR,dense) + subroutine csr2dense_${s1}$(CSR,dense) type(CSR_${s1}$_type), intent(in) :: CSR ${t1}$, allocatable, intent(out) :: dense(:,:) integer(ilp) :: i, j @@ -119,7 +229,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine csr2coo_${s1}$(CSR,COO) + subroutine csr2coo_${s1}$(CSR,COO) type(CSR_${s1}$_type), intent(in) :: CSR type(COO_${s1}$_type), intent(out) :: COO integer(ilp) :: i, j @@ -145,7 +255,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows) + subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows) type(CSR_${s1}$_type), intent(in) :: CSR type(ELL_${s1}$_type), intent(out) :: ELL integer, intent(in), optional :: num_nz_rows !! number of non zeros per row @@ -175,7 +285,7 @@ contains #:endfor #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) + subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) !! csr2sellc: This function enables transfering data from a CSR matrix to a SELL-C matrix !! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves type(CSR_${s1}$_type), intent(in) :: CSR @@ -387,7 +497,11 @@ contains #:endfor - module subroutine coo2ordered(COO,sort_data) + !! version: experimental + !! + !! Transform COO matrix to canonical form with ordered and unique entries + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + subroutine coo2ordered(COO,sort_data) class(COO_type), intent(inout) :: COO logical, intent(in), optional :: sort_data integer(ilp), allocatable :: itemp(:,:) @@ -423,4 +537,179 @@ contains COO%is_sorted = .true. end subroutine -end submodule \ No newline at end of file + subroutine coo_from_ijv_type(COO,row,col,nrows,ncols) + type(COO_type), intent(inout) :: COO + integer(ilp), intent(in) :: row(:) + integer(ilp), intent(in) :: col(:) + integer(ilp), intent(in), optional :: nrows + integer(ilp), intent(in), optional :: ncols + + integer(ilp) :: nrows_, ncols_, nnz, ed + !--------------------------------------------------------- + if(present(nrows)) then + nrows_ = nrows + else + nrows_ = size(row) + end if + if(present(ncols)) then + ncols_ = ncols + else + ncols_ = size(col) + end if + nnz = size(row) + !--------------------------------------------------------- + call COO%malloc(nrows_,ncols_,nnz) + do ed = 1, nnz + COO%index(1:2,ed) = [row(ed),col(ed)] + end do + + call coo2ordered(COO,.true.) + end subroutine + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine coo_from_ijv_${s1}$(COO,row,col,data,nrows,ncols) + type(COO_${s1}$_type), intent(inout) :: COO + integer(ilp), intent(in) :: row(:) + integer(ilp), intent(in) :: col(:) + ${t1}$, intent(in), optional :: data(:) + integer(ilp), intent(in), optional :: nrows + integer(ilp), intent(in), optional :: ncols + + integer(ilp) :: nrows_, ncols_, nnz, ed + !--------------------------------------------------------- + if(present(nrows)) then + nrows_ = nrows + else + nrows_ = maxval(row) + end if + if(present(ncols)) then + ncols_ = ncols + else + ncols_ = maxval(col) + end if + nnz = size(row) + !--------------------------------------------------------- + call COO%malloc(nrows_,ncols_,nnz) + do ed = 1, nnz + COO%index(1:2,ed) = [row(ed),col(ed)] + end do + if(present(data)) COO%data = data + + call coo2ordered(COO,.true.) + end subroutine + #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine csr_from_ijv_${s1}$(CSR,row,col,data,nrows,ncols) + type(CSR_${s1}$_type), intent(inout) :: CSR + integer(ilp), intent(in) :: row(:) + integer(ilp), intent(in) :: col(:) + ${t1}$, intent(in), optional :: data(:) + integer(ilp), intent(in), optional :: nrows + integer(ilp), intent(in), optional :: ncols + + integer(ilp) :: nrows_, ncols_ + !--------------------------------------------------------- + if(present(nrows)) then + nrows_ = nrows + else + nrows_ = maxval(row) + end if + if(present(ncols)) then + ncols_ = ncols + else + ncols_ = maxval(col) + end if + !--------------------------------------------------------- + block + type(COO_${s1}$_type) :: COO + if(present(data)) then + call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) + else + call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_) + end if + call coo2csr(COO,CSR) + end block + end subroutine + #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine ell_from_ijv_${s1}$(ELL,row,col,data,nrows,ncols,num_nz_rows) + type(ELL_${s1}$_type), intent(inout) :: ELL + integer(ilp), intent(in) :: row(:) + integer(ilp), intent(in) :: col(:) + ${t1}$, intent(in), optional :: data(:) + integer(ilp), intent(in), optional :: nrows + integer(ilp), intent(in), optional :: ncols + integer, intent(in), optional :: num_nz_rows + + integer(ilp) :: nrows_, ncols_ + !--------------------------------------------------------- + if(present(nrows)) then + nrows_ = nrows + else + nrows_ = maxval(row) + end if + if(present(ncols)) then + ncols_ = ncols + else + ncols_ = maxval(col) + end if + !--------------------------------------------------------- + block + type(COO_${s1}$_type) :: COO + type(CSR_${s1}$_type) :: CSR + if(present(data)) then + call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) + else + call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_) + end if + call coo2csr(COO,CSR) + if(present(num_nz_rows)) then + call csr2ell(CSR,ELL,num_nz_rows) + else + call csr2ell(CSR,ELL) + end if + end block + end subroutine + #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine sellc_from_ijv_${s1}$(SELLC,row,col,data,nrows,ncols,chunk) + type(SELLC_${s1}$_type), intent(inout) :: SELLC + integer(ilp), intent(in) :: row(:) + integer(ilp), intent(in) :: col(:) + ${t1}$, intent(in), optional :: data(:) + integer(ilp), intent(in), optional :: nrows + integer(ilp), intent(in), optional :: ncols + integer, intent(in), optional :: chunk + + integer(ilp) :: nrows_, ncols_ + !--------------------------------------------------------- + if(present(nrows)) then + nrows_ = nrows + else + nrows_ = maxval(row) + end if + if(present(ncols)) then + ncols_ = ncols + else + ncols_ = maxval(col) + end if + if(present(chunk)) SELLC%chunk_size = chunk + !--------------------------------------------------------- + block + type(COO_${s1}$_type) :: COO + type(CSR_${s1}$_type) :: CSR + if(present(data)) then + call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) + else + call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_) + end if + call coo2csr(COO,CSR) + call csr2sellc(CSR,SELLC) + end block + end subroutine + #:endfor + +end module \ No newline at end of file diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index baa21851c..4bbea1b94 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -8,29 +8,10 @@ ! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose module stdlib_sparse_kinds use ieee_arithmetic - use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp + use stdlib_sparse_constants implicit none private - - enum, bind(C) - enumerator :: sparse_full !! Full Sparse matrix (no symmetry considerations) - enumerator :: sparse_lower !! Symmetric Sparse matrix with triangular inferior storage - enumerator :: sparse_upper !! Symmetric Sparse matrix with triangular supperior storage - end enum public :: sparse_full, sparse_lower, sparse_upper - - ! Integer size support for ILP64 builds should be done here - integer, parameter :: ilp = int32 - - #:for k1, t1, s1 in (R_KINDS_TYPES) - ${t1}$, parameter :: zero_${s1}$ = 0._${k1}$ - ${t1}$, parameter :: one_${s1}$ = 1._${k1}$ - #:endfor - #:for k1, t1, s1 in (C_KINDS_TYPES) - ${t1}$, parameter :: zero_${s1}$ = (0._${k1}$,0._${k1}$) - ${t1}$, parameter :: one_${s1}$ = (1._${k1}$,1._${k1}$) - #:endfor - !! version: experimental !! !! Base sparse type holding the meta data related to the storage capacity of a matrix. @@ -146,195 +127,6 @@ module stdlib_sparse_kinds end type #:endfor - !! version: experimental - !! - !! Conversion from dense to coo - !! Enables extracting the non-zero elements of a dense 2D matrix and - !! storing those values in a COO format. The coo matrix is (re)allocated on the fly. - !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) - interface dense2coo - #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine dense2coo_${s1}$(dense,COO) - ${t1}$, intent(in) :: dense(:,:) - type(COO_${s1}$_type), intent(out) :: COO - end subroutine - #:endfor - end interface - public :: dense2coo - - !! version: experimental - !! - !! Conversion from coo to dense - !! Enables creating a dense 2D matrix from the non-zero values stored in a COO format - !! The dense matrix can be allocated on the fly if not pre-allocated by the user. - !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) - interface coo2dense - #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine coo2dense_${s1}$(COO,dense) - type(COO_${s1}$_type), intent(in) :: COO - ${t1}$, allocatable, intent(out) :: dense(:,:) - end subroutine - #:endfor - end interface - public :: coo2dense - - !! version: experimental - !! - !! Conversion from coo to csr - !! Enables transferring data from a COO matrix to a CSR matrix - !! under the hypothesis that the COO is already ordered. - !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) - interface coo2csr - #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine coo2csr_${s1}$(COO,CSR) - type(COO_${s1}$_type), intent(in) :: COO - type(CSR_${s1}$_type), intent(out) :: CSR - end subroutine - #:endfor - end interface - public :: coo2csr - - !! version: experimental - !! - !! Conversion from csr to dense - !! Enables creating a dense 2D matrix from the non-zero values stored in a CSR format - !! The dense matrix can be allocated on the fly if not pre-allocated by the user. - !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) - interface csr2dense - #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine csr2dense_${s1}$(CSR,dense) - type(CSR_${s1}$_type), intent(in) :: CSR - ${t1}$, allocatable, intent(out) :: dense(:,:) - end subroutine - #:endfor - end interface - public :: csr2dense - - !! version: experimental - !! - !! Conversion from csr to coo - !! Enables transferring data from a CSR matrix to a COO matrix - !! under the hypothesis that the CSR is already ordered. - !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) - interface csr2coo - #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine csr2coo_${s1}$(CSR,COO) - type(CSR_${s1}$_type), intent(in) :: CSR - type(COO_${s1}$_type), intent(out) :: COO - end subroutine - #:endfor - end interface - public :: csr2coo - - !! version: experimental - !! - !! Conversion from csr to ell - !! Enables transferring data from a CSR matrix to a ELL matrix - !! under the hypothesis that the CSR is already ordered. - !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) - interface csr2ell - #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows) - type(CSR_${s1}$_type), intent(in) :: CSR - type(ELL_${s1}$_type), intent(out) :: ELL - integer, intent(in), optional :: num_nz_rows - end subroutine - #:endfor - end interface - public :: csr2ell - - !! version: experimental - !! - !! Conversion from csr to SELL-C - !! Enables transferring data from a CSR matrix to a SELL-C matrix - !! It takes an optional parameter to decide the chunck size 4, 8 or 16 - !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) - interface csr2sellc - #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine csr2sellc_${s1}$(CSR,SELLC,chunk) - type(CSR_${s1}$_type), intent(in) :: CSR - type(SELLC_${s1}$_type), intent(out) :: SELLC - integer, intent(in), optional :: chunk - end subroutine - #:endfor - end interface - public :: csr2sellc - - !! version: experimental - !! - !! Transform COO matrix to canonical form with ordered and unique entries - !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) - interface coo2ordered - module subroutine coo2ordered(COO,sort_data) - class(COO_type), intent(inout) :: COO - logical, intent(in), optional :: sort_data - end subroutine - end interface - public :: coo2ordered - - !! version: experimental - !! - !! Enable creating a sparse matrix from ijv (row,col,data) triplet - !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) - interface from_ijv - module procedure :: coo_from_ijv_type - #:for k1, t1, s1 in (KINDS_TYPES) - module procedure :: coo_from_ijv_${s1}$ - module procedure :: csr_from_ijv_${s1}$ - module procedure :: ell_from_ijv_${s1}$ - module procedure :: sellc_from_ijv_${s1}$ - #:endfor - end interface - public :: from_ijv - - !! Version experimental - !! - !! Applay the sparse matrix-vector product $$y = \alpha * M * x + \beta * y $$ - !! [Specifications](../page/specs/stdlib_sparse.html#spmv) - interface spmv - #:for k1, t1, s1 in (KINDS_TYPES) - #:for rank in RANKS - module subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(COO_${s1}$_type), intent(in) :: matrix - ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ - ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ - ${t1}$, intent(in), optional :: alpha - ${t1}$, intent(in), optional :: beta - end subroutine - module subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(CSR_${s1}$_type), intent(in) :: matrix - ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ - ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ - ${t1}$, intent(in), optional :: alpha - ${t1}$, intent(in), optional :: beta - end subroutine - module subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(CSC_${s1}$_type), intent(in) :: matrix - ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ - ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ - ${t1}$, intent(in), optional :: alpha - ${t1}$, intent(in), optional :: beta - end subroutine - module subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) - type(ELL_${s1}$_type), intent(in) :: matrix - ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ - ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ - ${t1}$, intent(in), optional :: alpha - ${t1}$, intent(in), optional :: beta - end subroutine - #:endfor - module subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) - !! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves - type(SELLC_${s1}$_type), intent(in) :: matrix - ${t1}$, intent(in) :: vec_x(:) - ${t1}$, intent(inout) :: vec_y(:) - ${t1}$, intent(in), optional :: alpha - ${t1}$, intent(in), optional :: beta - end subroutine - #:endfor - end interface - public :: spmv - contains !! (re)Allocate matrix memory for the COO type @@ -499,181 +291,6 @@ contains end select end subroutine - subroutine coo_from_ijv_type(COO,row,col,nrows,ncols) - type(COO_type), intent(inout) :: COO - integer(ilp), intent(in) :: row(:) - integer(ilp), intent(in) :: col(:) - integer(ilp), intent(in), optional :: nrows - integer(ilp), intent(in), optional :: ncols - - integer(ilp) :: nrows_, ncols_, nnz, ed - !--------------------------------------------------------- - if(present(nrows)) then - nrows_ = nrows - else - nrows_ = size(row) - end if - if(present(ncols)) then - ncols_ = ncols - else - ncols_ = size(col) - end if - nnz = size(row) - !--------------------------------------------------------- - call COO%malloc(nrows_,ncols_,nnz) - do ed = 1, nnz - COO%index(1:2,ed) = [row(ed),col(ed)] - end do - - call coo2ordered(COO,.true.) - end subroutine - - #:for k1, t1, s1 in (KINDS_TYPES) - subroutine coo_from_ijv_${s1}$(COO,row,col,data,nrows,ncols) - type(COO_${s1}$_type), intent(inout) :: COO - integer(ilp), intent(in) :: row(:) - integer(ilp), intent(in) :: col(:) - ${t1}$, intent(in), optional :: data(:) - integer(ilp), intent(in), optional :: nrows - integer(ilp), intent(in), optional :: ncols - - integer(ilp) :: nrows_, ncols_, nnz, ed - !--------------------------------------------------------- - if(present(nrows)) then - nrows_ = nrows - else - nrows_ = maxval(row) - end if - if(present(ncols)) then - ncols_ = ncols - else - ncols_ = maxval(col) - end if - nnz = size(row) - !--------------------------------------------------------- - call COO%malloc(nrows_,ncols_,nnz) - do ed = 1, nnz - COO%index(1:2,ed) = [row(ed),col(ed)] - end do - if(present(data)) COO%data = data - - call coo2ordered(COO,.true.) - end subroutine - #:endfor - - #:for k1, t1, s1 in (KINDS_TYPES) - subroutine csr_from_ijv_${s1}$(CSR,row,col,data,nrows,ncols) - type(CSR_${s1}$_type), intent(inout) :: CSR - integer(ilp), intent(in) :: row(:) - integer(ilp), intent(in) :: col(:) - ${t1}$, intent(in), optional :: data(:) - integer(ilp), intent(in), optional :: nrows - integer(ilp), intent(in), optional :: ncols - - integer(ilp) :: nrows_, ncols_ - !--------------------------------------------------------- - if(present(nrows)) then - nrows_ = nrows - else - nrows_ = maxval(row) - end if - if(present(ncols)) then - ncols_ = ncols - else - ncols_ = maxval(col) - end if - !--------------------------------------------------------- - block - type(COO_${s1}$_type) :: COO - if(present(data)) then - call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) - else - call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_) - end if - call coo2csr(COO,CSR) - end block - end subroutine - #:endfor - - #:for k1, t1, s1 in (KINDS_TYPES) - subroutine ell_from_ijv_${s1}$(ELL,row,col,data,nrows,ncols,num_nz_rows) - type(ELL_${s1}$_type), intent(inout) :: ELL - integer(ilp), intent(in) :: row(:) - integer(ilp), intent(in) :: col(:) - ${t1}$, intent(in), optional :: data(:) - integer(ilp), intent(in), optional :: nrows - integer(ilp), intent(in), optional :: ncols - integer, intent(in), optional :: num_nz_rows - - integer(ilp) :: nrows_, ncols_ - !--------------------------------------------------------- - if(present(nrows)) then - nrows_ = nrows - else - nrows_ = maxval(row) - end if - if(present(ncols)) then - ncols_ = ncols - else - ncols_ = maxval(col) - end if - !--------------------------------------------------------- - block - type(COO_${s1}$_type) :: COO - type(CSR_${s1}$_type) :: CSR - if(present(data)) then - call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) - else - call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_) - end if - call coo2csr(COO,CSR) - if(present(num_nz_rows)) then - call csr2ell(CSR,ELL,num_nz_rows) - else - call csr2ell(CSR,ELL) - end if - end block - end subroutine - #:endfor - - #:for k1, t1, s1 in (KINDS_TYPES) - subroutine sellc_from_ijv_${s1}$(SELLC,row,col,data,nrows,ncols,chunk) - type(SELLC_${s1}$_type), intent(inout) :: SELLC - integer(ilp), intent(in) :: row(:) - integer(ilp), intent(in) :: col(:) - ${t1}$, intent(in), optional :: data(:) - integer(ilp), intent(in), optional :: nrows - integer(ilp), intent(in), optional :: ncols - integer, intent(in), optional :: chunk - - integer(ilp) :: nrows_, ncols_ - !--------------------------------------------------------- - if(present(nrows)) then - nrows_ = nrows - else - nrows_ = maxval(row) - end if - if(present(ncols)) then - ncols_ = ncols - else - ncols_ = maxval(col) - end if - if(present(chunk)) SELLC%chunk_size = chunk - !--------------------------------------------------------- - block - type(COO_${s1}$_type) :: COO - type(CSR_${s1}$_type) :: CSR - if(present(data)) then - call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_) - else - call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_) - end if - call coo2csr(COO,CSR) - call csr2sellc(CSR,SELLC) - end block - end subroutine - #:endfor - !================================================================== ! data accessors !================================================================== diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index 9a2ef3f48..5bcc067a4 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -10,15 +10,35 @@ !! The `stdlib_sparse_spmv` submodule provides matrix-vector product kernels. !! ! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose -submodule(stdlib_sparse_kinds) stdlib_sparse_spmv +module stdlib_sparse_spmv + use stdlib_sparse_constants + use stdlib_sparse_kinds implicit none + private + + !! Version experimental + !! + !! Applay the sparse matrix-vector product $$y = \alpha * M * x + \beta * y $$ + !! [Specifications](../page/specs/stdlib_sparse.html#spmv) + interface spmv + #:for k1, t1, s1 in (KINDS_TYPES) + #:for rank in RANKS + module procedure :: spmv_coo_${rank}$d_${s1}$ + module procedure :: spmv_csr_${rank}$d_${s1}$ + module procedure :: spmv_csc_${rank}$d_${s1}$ + module procedure :: spmv_ell_${rank}$d_${s1}$ + #:endfor + module procedure :: spmv_sellc_${s1}$ + #:endfor + end interface + public :: spmv contains !! spmv_coo #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - module subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(COO_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -61,7 +81,7 @@ contains !! spmv_csr #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - module subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(CSR_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -141,7 +161,7 @@ contains !! spmv_csc #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - module subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(CSC_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -205,7 +225,7 @@ contains !! spmv_ell #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - module subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) type(ELL_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ @@ -239,7 +259,7 @@ contains !! spmv_sellc #:set CHUNKS = [4,8,16] #:for k1, t1, s1 in (KINDS_TYPES) - module subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) !! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves type(SELLC_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x(:) @@ -316,4 +336,4 @@ contains #:endfor -end submodule \ No newline at end of file +end module \ No newline at end of file From 82dbe02a1a38320ffd1f09612cf2dfd7452668ca Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Wed, 31 Jul 2024 12:31:57 +0200 Subject: [PATCH 63/78] forgotten file in cmake --- src/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 877d690fb..7a868dadc 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -39,6 +39,7 @@ set(fppFiles stdlib_sorting_ord_sort.fypp stdlib_sorting_sort.fypp stdlib_sorting_sort_index.fypp + stdlib_sparse_constants.fypp stdlib_sparse_conversion.fypp stdlib_sparse_kinds.fypp stdlib_sparse_spmv.fypp From bc0021b0885f653ba0d519877368cf25be6ce17c Mon Sep 17 00:00:00 2001 From: jalvesz Date: Fri, 20 Sep 2024 23:28:16 +0200 Subject: [PATCH 64/78] add csc/coo conversions and diagonal extraction --- doc/specs/stdlib_sparse.md | 32 +++++ src/stdlib_sparse_conversion.fypp | 222 ++++++++++++++++++++++++++++++ test/linalg/test_sparse_spmv.fypp | 45 ++++++ 3 files changed, 299 insertions(+) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 88d28d4f0..54bf42365 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -259,6 +259,18 @@ This module provides facility functions for converting between storage formats. ```fortran {!example/linalg/example_sparse_from_ijv.f90!} ``` +### Syntax + +`call ` [[stdlib_sparse_conversion(module):diag(interface)]] `(matrix,diagonal)` + +### Arguments + +`matrix` : Shall be a `dense`, `COO`, `CSR` or `ELL` type. It is an `intent(in)` argument. + +`diagonal` : A rank-1 array of the same type as the `matrix`. It is an `intent(inout)` and `allocatable` argument. + +#### Note +If the `diagonal` array has not been previously allocated, the `diag` subroutine will allocate it using the `nrows` of the `matrix`. ### Syntax @@ -292,6 +304,16 @@ This module provides facility functions for converting between storage formats. ### Syntax +`call ` [[stdlib_sparse_conversion(module):coo2csc(interface)]] `(coo,csc)` + +### Arguments + +`coo` : Shall be a `COO` type of `real` or `complex` type. It is an `intent(in)` argument. + +`csc` : Shall be a `CSC` type of `real` or `complex` type. It is an `intent(out)` argument. + +### Syntax + `call ` [[stdlib_sparse_conversion(module):csr2coo(interface)]] `(csr,coo)` ### Arguments @@ -312,6 +334,16 @@ This module provides facility functions for converting between storage formats. `chunk`, `optional`: chunk size for the Sliced ELLPACK format. It is an `intent(in)` argument. +### Syntax + +`call ` [[stdlib_sparse_conversion(module):csc2coo(interface)]] `(csc,coo)` + +### Arguments + +`csc` : Shall be a `CSC` type of `real` or `complex` type. It is an `intent(in)` argument. + +`coo` : Shall be a `COO` type of `real` or `complex` type. It is an `intent(out)` argument. + ## Example ```fortran {!example/linalg/example_sparse_spmv.f90!} diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 7516a223b..78b546190 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -58,6 +58,19 @@ module stdlib_sparse_conversion #:endfor end interface public :: coo2csr + + !! version: experimental + !! + !! Conversion from coo to csc + !! Enables transferring data from a COO matrix to a CSC matrix + !! under the hypothesis that the COO is already ordered. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface coo2csc + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: coo2csc_${s1}$ + #:endfor + end interface + public :: coo2csc !! version: experimental !! @@ -111,6 +124,34 @@ module stdlib_sparse_conversion end interface public :: csr2sellc + !! version: experimental + !! + !! Conversion from csc to coo + !! Enables transferring data from a CSC matrix to a COO matrix + !! under the hypothesis that the CSC is already ordered. + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface csc2coo + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: csc2coo_${s1}$ + #:endfor + end interface + public :: csc2coo + + !! version: experimental + !! + !! Extraction of diagonal values + !! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion) + interface diag + #:for k1, t1, s1 in (KINDS_TYPES) + module procedure :: dense2diagonal_${s1}$ + module procedure :: coo2diagonal_${s1}$ + module procedure :: csr2diagonal_${s1}$ + module procedure :: csc2diagonal_${s1}$ + module procedure :: ell2diagonal_${s1}$ + #:endfor + end interface + public :: diag + !! version: experimental !! !! Enable creating a sparse matrix from ijv (row,col,data) triplet @@ -202,6 +243,45 @@ contains #:endfor + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine coo2csc_${s1}$(COO,CSC) + type(COO_${s1}$_type), intent(in) :: COO + type(CSC_${s1}$_type), intent(out) :: CSC + ${t1}$, allocatable :: data(:) + integer(ilp), allocatable :: temp(:,:) + integer(ilp) :: i, nnz + + CSC%nnz = COO%nnz; CSC%nrows = COO%nrows; CSC%ncols = COO%ncols + CSC%storage = COO%storage + + allocate(temp(2,COO%nnz)) + temp(1,1:COO%nnz) = COO%index(2,1:COO%nnz) + temp(2,1:COO%nnz) = COO%index(1,1:COO%nnz) + allocate(data, source = COO%data ) + nnz = COO%nnz + call sort_coo_unique_${s1}$( temp, data, nnz, COO%nrows, COO%ncols ) + + if( allocated(CSC%row) ) then + CSC%row(1:COO%nnz) = temp(2,1:COO%nnz) + CSC%colptr(1:CSC%ncols) = 0 + CSC%data(1:CSC%nnz) = data(1:COO%nnz) + else + allocate( CSC%row(CSC%nnz) , source = temp(2,1:COO%nnz) ) + allocate( CSC%colptr(CSC%ncols+1) , source = 0 ) + allocate( CSC%data(CSC%nnz) , source = data(1:COO%nnz) ) + end if + + CSC%colptr(1) = 1 + do i = 1, COO%nnz + CSC%colptr( temp(1,i)+1 ) = CSC%colptr( temp(1,i)+1 ) + 1 + end do + do i = 1, CSC%ncols + CSC%colptr( i+1 ) = CSC%colptr( i+1 ) + CSC%colptr( i ) + end do + end subroutine + + #:endfor + #:for k1, t1, s1 in (KINDS_TYPES) subroutine csr2dense_${s1}$(CSR,dense) type(CSR_${s1}$_type), intent(in) :: CSR @@ -254,6 +334,33 @@ contains #:endfor + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine csc2coo_${s1}$(CSC,COO) + type(CSC_${s1}$_type), intent(in) :: CSC + type(COO_${s1}$_type), intent(out) :: COO + integer(ilp) :: i, j + + COO%nnz = CSC%nnz; COO%nrows = CSC%nrows; COO%ncols = CSC%ncols + COO%storage = CSC%storage + + if( .not.allocated(COO%data) ) then + allocate( COO%data(CSC%nnz) , source = CSC%data(1:CSC%nnz) ) + else + COO%data(1:CSC%nnz) = CSC%data(1:CSC%nnz) + end if + + if( .not.allocated(COO%index) ) allocate( COO%index(2,CSC%nnz) ) + + do j = 1, CSC%ncols + do i = CSC%colptr(j), CSC%colptr(j+1)-1 + COO%index(1:2,i) = [CSC%row(i),j] + end do + end do + call sort_coo_unique_${s1}$( COO%index, COO%data, COO%nnz, COO%nrows, COO%ncols ) + end subroutine + + #:endfor + #:for k1, t1, s1 in (KINDS_TYPES) subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows) type(CSR_${s1}$_type), intent(in) :: CSR @@ -712,4 +819,119 @@ contains end subroutine #:endfor + !! Diagonal extraction + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine dense2diagonal_${s1}$(dense,diagonal) + ${t1}$, intent(in) :: dense(:,:) + ${t1}$, intent(inout), allocatable :: diagonal(:) + integer :: num_rows + integer :: i + + num_rows = size(dense,dim=1) + if(.not.allocated(diagonal)) allocate(diagonal(num_rows)) + + do i = 1, num_rows + diagonal(i) = dense(i,i) + end do + end subroutine + + #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine coo2diagonal_${s1}$(COO,diagonal) + type(COO_${s1}$_type), intent(in) :: COO + ${t1}$, intent(inout), allocatable :: diagonal(:) + integer :: idx + + if(.not.allocated(diagonal)) allocate(diagonal(COO%nrows)) + + do concurrent(idx = 1:COO%nnz) + if(COO%index(1,idx)==COO%index(2,idx)) & + & diagonal( COO%index(1,idx) ) = COO%data(idx) + end do + end subroutine + + #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine csr2diagonal_${s1}$(CSR,diagonal) + type(CSR_${s1}$_type), intent(in) :: CSR + ${t1}$, intent(inout), allocatable :: diagonal(:) + integer :: i, j + + if(.not.allocated(diagonal)) allocate(diagonal(CSR%nrows)) + + select case(CSR%storage) + case(sparse_lower) + do i = 1, CSR%nrows + diagonal(i) = CSR%data( CSR%rowptr(i+1)-1 ) + end do + case(sparse_upper) + do i = 1, CSR%nrows + diagonal(i) = CSR%data( CSR%rowptr(i) ) + end do + case(sparse_full) + do i = 1, CSR%nrows + do j = CSR%rowptr(i), CSR%rowptr(i+1)-1 + if( CSR%col(j) == i ) then + diagonal(i) = CSR%data(j) + exit + end if + end do + end do + end select + end subroutine + + #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine csc2diagonal_${s1}$(CSC,diagonal) + type(CSC_${s1}$_type), intent(in) :: CSC + ${t1}$, intent(inout), allocatable :: diagonal(:) + integer :: i, j + + if(.not.allocated(diagonal)) allocate(diagonal(CSC%nrows)) + + select case(CSC%storage) + case(sparse_lower) + do i = 1, CSC%ncols + diagonal(i) = CSC%data( CSC%colptr(i+1)-1 ) + end do + case(sparse_upper) + do i = 1, CSC%ncols + diagonal(i) = CSC%data( CSC%colptr(i) ) + end do + case(sparse_full) + do i = 1, CSC%ncols + do j = CSC%colptr(i), CSC%colptr(i+1)-1 + if( CSC%row(j) == i ) then + diagonal(i) = CSC%data(j) + exit + end if + end do + end do + end select + end subroutine + + #:endfor + + #:for k1, t1, s1 in (KINDS_TYPES) + subroutine ell2diagonal_${s1}$(ELL,diagonal) + type(ELL_${s1}$_type), intent(in) :: ELL + ${t1}$, intent(inout), allocatable :: diagonal(:) + integer :: i, k + + if(.not.allocated(diagonal)) allocate(diagonal(ELL%nrows)) + if( ELL%storage == sparse_full) then + do i = 1, ELL%nrows + do k = 1, ELL%K + if(ELL%index(i,k)==i) diagonal(i) = ELL%data(i,k) + end do + end do + end if + end subroutine + + #:endfor + end module \ No newline at end of file diff --git a/test/linalg/test_sparse_spmv.fypp b/test/linalg/test_sparse_spmv.fypp index 0f42cad5b..1be0c778b 100644 --- a/test/linalg/test_sparse_spmv.fypp +++ b/test/linalg/test_sparse_spmv.fypp @@ -24,6 +24,7 @@ contains new_unittest('ell', test_ell), & new_unittest('sellc', test_sellc), & new_unittest('symmetries', test_symmetries), & + new_unittest('diagonal', test_diagonal), & new_unittest('add_get_values', test_add_get_values) & ] end subroutine @@ -253,6 +254,50 @@ contains #:endfor end subroutine + subroutine test_diagonal(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + #:for k1, t1, s1 in (KINDS_TYPES) + block + integer, parameter :: wp = ${k1}$ + ${t1}$, allocatable :: dense(:,:) + type(COO_${s1}$_type) :: COO + type(CSR_${s1}$_type) :: CSR + type(CSC_${s1}$_type) :: CSC + type(ELL_${s1}$_type) :: ELL + ${t1}$, allocatable :: diagonal(:) + + allocate( dense(4,4) , source = & + reshape(real([1,0,0,5, & + 0,2,0,0, & + 0,6,3,0,& + 0,0,7,4],kind=wp),[4,4]) ) + + call diag(dense,diagonal) + call check(error, all(diagonal == [1,2,3,4]) ) + if (allocated(error)) return + + diagonal = 0.0 + call dense2coo( dense , COO ) + call diag( COO , diagonal ) + call check(error, all(diagonal == [1,2,3,4]) ) + if (allocated(error)) return + + diagonal = 0.0 + call coo2csr( COO, CSR ) + call diag( CSR , diagonal ) + call check(error, all(diagonal == [1,2,3,4]) ) + if (allocated(error)) return + + diagonal = 0.0 + call coo2csc( COO, CSC ) + call diag( CSC , diagonal ) + call check(error, all(diagonal == [1,2,3,4]) ) + if (allocated(error)) return + end block + #:endfor + end subroutine + subroutine test_add_get_values(error) !> Error handling type(error_type), allocatable, intent(out) :: error From a4d9306734b256f3a0c8e83d374ebc9d216b70a0 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 19 Oct 2024 14:30:38 +0200 Subject: [PATCH 65/78] Add in place operator for coo and csr spmv --- doc/specs/stdlib_sparse.md | 6 +- src/stdlib_sparse_constants.fypp | 4 + src/stdlib_sparse_kinds.fypp | 1 + src/stdlib_sparse_spmv.fypp | 144 ++++++++++++++++++++++++++++--- 4 files changed, 140 insertions(+), 15 deletions(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index 54bf42365..df95a2f88 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -194,11 +194,11 @@ Experimental Provide sparse matrix-vector product kernels for the current supported sparse matrix types. -$$y=\alpha*M*x+\beta*y$$ +$$y=\alpha*op(M)*x+\beta*y$$ ### Syntax -`call ` [[stdlib_sparse_spmv(module):spmv(interface)]] `(matrix,vec_x,vec_y [,alpha,beta])` +`call ` [[stdlib_sparse_spmv(module):spmv(interface)]] `(matrix,vec_x,vec_y [,alpha,beta,op])` ### Arguments @@ -212,6 +212,8 @@ $$y=\alpha*M*x+\beta*y$$ `beta`, `optional` : Shall be a scalar value of the same type as `vec_x`. Default value `beta=0`. It is an `intent(in)` argument. +`op`, `optional`: In-place operator identifier. Shall be a `character(1)` argument. It can have any of the following values: `N`: no transpose, `T`: transpose, `H`: hermitian or complex transpose. These values are provided as constants by the `stdlib_sparse` module: `sparse_op_none`, `sparse_op_transpose`, `sparse_op_hermitian` + ## Sparse matrix to matrix conversions diff --git a/src/stdlib_sparse_constants.fypp b/src/stdlib_sparse_constants.fypp index 9fbbe38f6..1e8374bd9 100644 --- a/src/stdlib_sparse_constants.fypp +++ b/src/stdlib_sparse_constants.fypp @@ -12,6 +12,10 @@ module stdlib_sparse_constants enumerator :: sparse_lower !! Symmetric Sparse matrix with triangular inferior storage enumerator :: sparse_upper !! Symmetric Sparse matrix with triangular supperior storage end enum + + character(1), parameter :: sparse_op_none = 'N' !! no transpose + character(1), parameter :: sparse_op_transpose = 'T' !! transpose + character(1), parameter :: sparse_op_hermitian = 'H' !! conjugate or hermitian transpose ! Integer size support for ILP64 builds should be done here integer, parameter :: ilp = int32 diff --git a/src/stdlib_sparse_kinds.fypp b/src/stdlib_sparse_kinds.fypp index 4bbea1b94..ceba2a62d 100644 --- a/src/stdlib_sparse_kinds.fypp +++ b/src/stdlib_sparse_kinds.fypp @@ -12,6 +12,7 @@ module stdlib_sparse_kinds implicit none private public :: sparse_full, sparse_lower, sparse_upper + public :: sparse_op_none, sparse_op_transpose, sparse_op_hermitian !! version: experimental !! !! Base sparse type holding the meta data related to the storage capacity of a matrix. diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index 5bcc067a4..d506d96c0 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -18,7 +18,7 @@ module stdlib_sparse_spmv !! Version experimental !! - !! Applay the sparse matrix-vector product $$y = \alpha * M * x + \beta * y $$ + !! Applay the sparse matrix-vector product $$y = \alpha * op(M) * x + \beta * y $$ !! [Specifications](../page/specs/stdlib_sparse.html#spmv) interface spmv #:for k1, t1, s1 in (KINDS_TYPES) @@ -38,15 +38,18 @@ contains !! spmv_coo #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta,op) type(COO_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta + character(1), intent(in), optional :: op ${t1}$ :: alpha_, beta_ + character(1) :: op_ integer(ilp) :: k, ik, jk + op_ = sparse_op_none; if(present(op)) op_ = op alpha_ = one_${k1}$ if(present(alpha)) alpha_ = alpha if(present(beta)) then @@ -55,7 +58,9 @@ contains vec_y = zero_${s1}$ endif associate( data => matrix%data, index => matrix%index, storage => matrix%storage, nnz => matrix%nnz ) - if( storage == sparse_full) then + select case(op_) + case(sparse_op_none) + if(storage == sparse_full) then do concurrent (k = 1:nnz) ik = index(1,k) jk = index(2,k) @@ -72,6 +77,45 @@ contains end do end if + case(sparse_op_transpose) + if(storage == sparse_full) then + do concurrent (k = 1:nnz) + jk = index(1,k) + ik = index(2,k) + vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$jk) + end do + + else + do concurrent (k = 1:nnz) + jk = index(1,k) + ik = index(2,k) + vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$jk) + if( ik==jk ) cycle + vec_y(${rksfx2(rank-1)}$jk) = vec_y(${rksfx2(rank-1)}$jk) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$ik) + end do + + end if + #:if t1.startswith('complex') + case(sparse_op_hermitian) + if(storage == sparse_full) then + do concurrent (k = 1:nnz) + jk = index(1,k) + ik = index(2,k) + vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*conjg(data(k)) * vec_x(${rksfx2(rank-1)}$jk) + end do + + else + do concurrent (k = 1:nnz) + jk = index(1,k) + ik = index(2,k) + vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*conjg(data(k)) * vec_x(${rksfx2(rank-1)}$jk) + if( ik==jk ) cycle + vec_y(${rksfx2(rank-1)}$jk) = vec_y(${rksfx2(rank-1)}$jk) + alpha_*conjg(data(k)) * vec_x(${rksfx2(rank-1)}$ik) + end do + + end if + #:endif + end select end associate end subroutine @@ -81,13 +125,15 @@ contains !! spmv_csr #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta,op) type(CSR_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta + character(1), intent(in), optional :: op ${t1}$ :: alpha_, beta_ + character(1) :: op_ integer(ilp) :: i, j #:if rank == 1 ${t1}$ :: aux, aux2 @@ -95,6 +141,7 @@ contains ${t1}$ :: aux(size(vec_x,dim=1)), aux2(size(vec_x,dim=1)) #:endif + op_ = sparse_op_none; if(present(op)) op_ = op alpha_ = one_${k1}$ if(present(alpha)) alpha_ = alpha beta_ = zero_${k1}$ @@ -102,7 +149,8 @@ contains associate( data => matrix%data, col => matrix%col, rowptr => matrix%rowptr, & & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage ) - if( storage == sparse_full) then + + if( storage == sparse_full .and. op_==sparse_op_none ) then do i = 1, nrows aux = zero_${k1}$ do j = rowptr(i), rowptr(i+1)-1 @@ -114,8 +162,21 @@ contains vec_y(${rksfx2(rank-1)}$i) = alpha_ * aux end if end do + + else if( storage == sparse_full .and. op_==sparse_op_transpose ) then + if(present(beta)) then + vec_y = beta * vec_y + else + vec_y = zero_${s1}$ + endif + do i = 1, nrows + aux = alpha_ * vec_x(${rksfx2(rank-1)}$i) + do j = rowptr(i), rowptr(i+1)-1 + vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * aux + end do + end do - else if( storage == sparse_lower )then + else if( storage == sparse_lower .and. op_/=sparse_op_hermitian )then do i = 1 , nrows aux = zero_${s1}$ aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i) @@ -132,7 +193,7 @@ contains end if end do - else if( storage == sparse_upper )then + else if( storage == sparse_upper .and. op_/=sparse_op_hermitian )then do i = 1 , nrows aux = vec_x(${rksfx2(rank-1)}$i) * data(rowptr(i)) aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i) @@ -150,7 +211,57 @@ contains end if vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux end do + + #:if t1.startswith('complex') + else if( storage == sparse_full .and. op_==sparse_op_hermitian) then + if(present(beta)) then + vec_y = beta * vec_y + else + vec_y = zero_${s1}$ + endif + do i = 1, nrows + aux = alpha_ * vec_x(${rksfx2(rank-1)}$i) + do j = rowptr(i), rowptr(i+1)-1 + vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + conjg(data(j)) * aux + end do + end do + + else if( storage == sparse_lower .and. op_==sparse_op_hermitian )then + do i = 1 , nrows + aux = zero_${s1}$ + aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i) + do j = rowptr(i), rowptr(i+1)-2 + aux = aux + conjg(data(j)) * vec_x(${rksfx2(rank-1)}$col(j)) + vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + conjg(data(j)) * aux2 + end do + aux = alpha_ * aux + conjg(data(j)) * aux2 + + if(present(beta)) then + vec_y(${rksfx2(rank-1)}$i) = beta_ * vec_y(${rksfx2(rank-1)}$i) + aux + else + vec_y(${rksfx2(rank-1)}$i) = aux + end if + end do + else if( storage == sparse_upper .and. op_==sparse_op_hermitian )then + do i = 1 , nrows + aux = vec_x(${rksfx2(rank-1)}$i) * conjg(data(rowptr(i))) + aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i) + do j = rowptr(i)+1, rowptr(i+1)-1 + aux = aux + conjg(data(j)) * vec_x(${rksfx2(rank-1)}$col(j)) + end do + if(present(beta)) then + do j = rowptr(i)+1, rowptr(i+1)-1 + vec_y(${rksfx2(rank-1)}$col(j)) = beta_ * vec_y(${rksfx2(rank-1)}$col(j)) + conjg(data(j)) * aux2 + end do + else + do j = rowptr(i)+1, rowptr(i+1)-1 + vec_y(${rksfx2(rank-1)}$col(j)) = conjg(data(j)) * aux2 + end do + end if + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux + end do + #:endif end if end associate end subroutine @@ -161,13 +272,15 @@ contains !! spmv_csc #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta,op) type(CSC_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta + character(1), intent(in), optional :: op ${t1}$ :: alpha_, beta_ + character(1) :: op_ integer(ilp) :: i, j #:if rank == 1 ${t1}$ :: aux @@ -175,6 +288,7 @@ contains ${t1}$ :: aux(size(vec_x,dim=1)) #:endif + op_ = sparse_op_none; if(present(op)) op_ = op alpha_ = one_${k1}$ if(present(alpha)) alpha_ = alpha if(present(beta)) then @@ -193,7 +307,6 @@ contains end do else if( storage == sparse_lower )then - ! NOT TESTED do j = 1 , ncols aux = vec_x(${rksfx2(rank-1)}$j) * data(colptr(j)) do i = colptr(j)+1, colptr(j+1)-1 @@ -204,7 +317,6 @@ contains end do else if( storage == sparse_upper )then - ! NOT TESTED do j = 1 , ncols aux = zero_${s1}$ do i = colptr(j), colptr(i+1)-2 @@ -225,15 +337,18 @@ contains !! spmv_ell #:for k1, t1, s1 in (KINDS_TYPES) #:for rank in RANKS - subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta,op) type(ELL_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$ ${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$ ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta + character(1), intent(in), optional :: op ${t1}$ :: alpha_, beta_ + character(1) :: op_ integer(ilp) :: i, j, k - + + op_ = sparse_op_none; if(present(op)) op_ = op alpha_ = one_${k1}$ if(present(alpha)) alpha_ = alpha if(present(beta)) then @@ -259,16 +374,19 @@ contains !! spmv_sellc #:set CHUNKS = [4,8,16] #:for k1, t1, s1 in (KINDS_TYPES) - subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta) + subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta,op) !! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves type(SELLC_${s1}$_type), intent(in) :: matrix ${t1}$, intent(in) :: vec_x(:) ${t1}$, intent(inout) :: vec_y(:) ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta + character(1), intent(in), optional :: op ${t1}$ :: alpha_, beta_ + character(1) :: op_ integer(ilp) :: i, nz, rowidx, num_chunks, rm + op_ = sparse_op_none; if(present(op)) op_ = op alpha_ = one_${s1}$ if(present(alpha)) alpha_ = alpha if(present(beta)) then From cd30636befb12ddbad963815b2cb39a87a99df2f Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 19 Oct 2024 14:44:08 +0200 Subject: [PATCH 66/78] add support for op with ellpack --- src/stdlib_sparse_spmv.fypp | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index d506d96c0..1ac961561 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -358,12 +358,23 @@ contains endif associate( data => matrix%data, index => matrix%index, MNZ_P_ROW => matrix%K, & & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage ) - if( storage == sparse_full) then + if( storage == sparse_full .and. op_==sparse_op_none ) then do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW) j = index(i,k) if(j>0) vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$j) end do - + else if( storage == sparse_full .and. op_==sparse_op_transpose ) then + do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW) + j = index(i,k) + if(j>0) vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$i) + end do + #:if t1.startswith('complex') + else if( storage == sparse_full .and. op_==sparse_op_hermitian ) then + do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW) + j = index(i,k) + if(j>0) vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_*conjg(data(i,k)) * vec_x(${rksfx2(rank-1)}$i) + end do + #:endif end if end associate end subroutine From b68b4c8fd6e73ca87e59f10294396bf2147b2389 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 19 Oct 2024 15:14:20 +0200 Subject: [PATCH 67/78] add support for op with csc format --- src/stdlib_sparse_spmv.fypp | 51 +++++++++++++++++++++++++++++++++---- 1 file changed, 46 insertions(+), 5 deletions(-) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index 1ac961561..48db61732 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -299,14 +299,24 @@ contains associate( data => matrix%data, colptr => matrix%colptr, row => matrix%row, & & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage ) - if( storage == sparse_full) then + if( storage == sparse_full .and. op_==sparse_op_none ) then do concurrent(j=1:ncols) + aux = alpha_ * vec_x(${rksfx2(rank-1)}$j) do i = colptr(j), colptr(j+1)-1 - vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + alpha_ * data(i) * vec_x(${rksfx2(rank-1)}$j) + vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + data(i) * aux + end do + end do + + else if( storage == sparse_full .and. op_==sparse_op_transpose ) then + do concurrent(j=1:ncols) + aux = zero_${k1}$ + do i = colptr(j), colptr(j+1)-1 + aux = aux + data(i) * vec_x(${rksfx2(rank-1)}$row(i)) end do + vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux end do - else if( storage == sparse_lower )then + else if( storage == sparse_lower .and. op_/=sparse_op_hermitian )then do j = 1 , ncols aux = vec_x(${rksfx2(rank-1)}$j) * data(colptr(j)) do i = colptr(j)+1, colptr(j+1)-1 @@ -316,7 +326,7 @@ contains vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux end do - else if( storage == sparse_upper )then + else if( storage == sparse_upper .and. op_/=sparse_op_hermitian )then do j = 1 , ncols aux = zero_${s1}$ do i = colptr(j), colptr(i+1)-2 @@ -326,7 +336,38 @@ contains aux = aux + data(colptr(j)) * vec_x(${rksfx2(rank-1)}$j) vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux end do - + + #:if t1.startswith('complex') + else if( storage == sparse_full .and. op_==sparse_op_hermitian ) then + do concurrent(j=1:ncols) + aux = zero_${k1}$ + do i = colptr(j), colptr(j+1)-1 + aux = aux + conjg(data(i)) * vec_x(${rksfx2(rank-1)}$row(i)) + end do + vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux + end do + + else if( storage == sparse_lower .and. op_==sparse_op_hermitian )then + do j = 1 , ncols + aux = vec_x(${rksfx2(rank-1)}$j) * conjg(data(colptr(j))) + do i = colptr(j)+1, colptr(j+1)-1 + aux = aux + conjg(data(i)) * vec_x(${rksfx2(rank-1)}$row(i)) + vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + alpha_ * conjg(data(i)) * vec_x(${rksfx2(rank-1)}$j) + end do + vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux + end do + + else if( storage == sparse_upper .and. op_==sparse_op_hermitian )then + do j = 1 , ncols + aux = zero_${s1}$ + do i = colptr(j), colptr(i+1)-2 + aux = aux + conjg(data(i)) * vec_x(${rksfx2(rank-1)}$j) + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * conjg(data(i)) * vec_x(${rksfx2(rank-1)}$row(i)) + end do + aux = aux + conjg(data(colptr(j))) * vec_x(${rksfx2(rank-1)}$j) + vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux + end do + #:endif end if end associate end subroutine From 62c702be14e3839c429af79c8aa0ae1c2639517b Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 19 Oct 2024 15:17:04 +0200 Subject: [PATCH 68/78] unit test in-place transpose --- test/linalg/test_sparse_spmv.fypp | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/test/linalg/test_sparse_spmv.fypp b/test/linalg/test_sparse_spmv.fypp index 1be0c778b..f1fac9e2c 100644 --- a/test/linalg/test_sparse_spmv.fypp +++ b/test/linalg/test_sparse_spmv.fypp @@ -61,6 +61,12 @@ contains call spmv( COO, vec_x, vec_y2 ) call check(error, all(vec_y1 == vec_y2) ) if (allocated(error)) return + + ! Test in-place transpose + vec_y1 = 1._wp + call spmv( COO, vec_y1, vec_x, op=sparse_op_transpose ) + call check(error, all(vec_x == real([17,15,4,14,-3],kind=wp)) ) + if (allocated(error)) return end block #:endfor end subroutine @@ -114,6 +120,12 @@ contains call check(error, all(vec_y == real([6,11,15,15],kind=wp)) ) if (allocated(error)) return + + ! Test in-place transpose + vec_y = 1._wp + call spmv( CSR, vec_y, vec_x, op=sparse_op_transpose ) + call check(error, all(vec_x == real([17,15,4,14,-3],kind=wp)) ) + if (allocated(error)) return end block #:endfor end subroutine @@ -139,6 +151,12 @@ contains call check(error, all(vec_y == real([6,11,15,15],kind=wp)) ) if (allocated(error)) return + + ! Test in-place transpose + vec_y = 1._wp + call spmv( CSC, vec_y, vec_x, op=sparse_op_transpose ) + call check(error, all(vec_x == real([17,15,4,14,-3],kind=wp)) ) + if (allocated(error)) return end block #:endfor end subroutine @@ -170,6 +188,12 @@ contains call check(error, all(vec_y == real([6,11,15,15],kind=wp)) ) if (allocated(error)) return + + ! Test in-place transpose + vec_y = 1._wp + call spmv( ELL, vec_y, vec_x, op=sparse_op_transpose ) + call check(error, all(vec_x == real([17,15,4,14,-3],kind=wp)) ) + if (allocated(error)) return end block #:endfor From 59d33f034e44c421e66f099617bb1acc474db12f Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 19 Oct 2024 17:07:37 +0200 Subject: [PATCH 69/78] complete spmv for the ellpack format including symmetric representations --- doc/specs/stdlib_sparse.md | 12 ++++++++++++ src/stdlib_sparse_conversion.fypp | 1 + src/stdlib_sparse_spmv.fypp | 18 ++++++++++++++++++ test/linalg/test_sparse_spmv.fypp | 9 ++++++++- 4 files changed, 39 insertions(+), 1 deletion(-) diff --git a/doc/specs/stdlib_sparse.md b/doc/specs/stdlib_sparse.md index df95a2f88..fc9d0a0c0 100644 --- a/doc/specs/stdlib_sparse.md +++ b/doc/specs/stdlib_sparse.md @@ -338,6 +338,18 @@ If the `diagonal` array has not been previously allocated, the `diag` subroutine ### Syntax +`call ` [[stdlib_sparse_conversion(module):csr2sellc(interface)]] `(csr,ell[,num_nz_rows])` + +### Arguments + +`csr` : Shall be a `CSR` type of `real` or `complex` type. It is an `intent(in)` argument. + +`ell` : Shall be a `ELL` type of `real` or `complex` type. It is an `intent(out)` argument. + +`num_nz_rows`, `optional`: number of non zeros per row. If not give, it will correspond to the size of the longest row in the `CSR` matrix. It is an `intent(in)` argument. + +### Syntax + `call ` [[stdlib_sparse_conversion(module):csc2coo(interface)]] `(csc,coo)` ### Arguments diff --git a/src/stdlib_sparse_conversion.fypp b/src/stdlib_sparse_conversion.fypp index 78b546190..d2f4936c5 100644 --- a/src/stdlib_sparse_conversion.fypp +++ b/src/stdlib_sparse_conversion.fypp @@ -378,6 +378,7 @@ contains end do end if call ELL%malloc(CSR%nrows,CSR%ncols,num_nz_rows_) + ELL%storage = CSR%storage !------------------------------------------- do i = 1, CSR%nrows adr1 = CSR%rowptr(i) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index 48db61732..841c064e1 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -409,12 +409,30 @@ contains j = index(i,k) if(j>0) vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$i) end do + else if( storage /= sparse_full .and. op_/=sparse_op_hermitian ) then + do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW) + j = index(i,k) + if(j>0) then + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$j) + if(i==j) cycle + vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$i) + end if + end do #:if t1.startswith('complex') else if( storage == sparse_full .and. op_==sparse_op_hermitian ) then do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW) j = index(i,k) if(j>0) vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_*conjg(data(i,k)) * vec_x(${rksfx2(rank-1)}$i) end do + else if( storage /= sparse_full .and. op_==sparse_op_hermitian ) then + do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW) + j = index(i,k) + if(j>0) then + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_*conjg(data(i,k)) * vec_x(${rksfx2(rank-1)}$j) + if(i==j) cycle + vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_*conjg(data(i,k)) * vec_x(${rksfx2(rank-1)}$i) + end if + end do #:endif end if end associate diff --git a/test/linalg/test_sparse_spmv.fypp b/test/linalg/test_sparse_spmv.fypp index f1fac9e2c..838243505 100644 --- a/test/linalg/test_sparse_spmv.fypp +++ b/test/linalg/test_sparse_spmv.fypp @@ -243,14 +243,16 @@ contains integer, parameter :: wp = ${k1}$ type(COO_${s1}$_type) :: COO type(CSR_${s1}$_type) :: CSR + type(ELL_${s1}$_type) :: ELL ${t1}$, allocatable :: dense(:,:) ${t1}$, allocatable :: vec_x(:) - ${t1}$, allocatable :: vec_y1(:), vec_y2(:), vec_y3(:) + ${t1}$, allocatable :: vec_y1(:), vec_y2(:), vec_y3(:), vec_y4(:) allocate( vec_x(4) , source = 1._wp ) allocate( vec_y1(4) , source = 0._wp ) allocate( vec_y2(4) , source = 0._wp ) allocate( vec_y3(4) , source = 0._wp ) + allocate( vec_y4(4) , source = 0._wp ) allocate( dense(4,4) , source = & reshape(real([1,0,0,0, & @@ -261,6 +263,7 @@ contains call dense2coo( dense , COO ) COO%storage = sparse_upper call coo2csr(COO, CSR) + call csr2ell(CSR, ELL) dense(2,1) = 2._wp; dense(3,2) = 2._wp; dense(4,3) = 2._wp vec_y1 = matmul( dense, vec_x ) @@ -274,6 +277,10 @@ contains call spmv( CSR , vec_x, vec_y3 ) call check(error, all(vec_y1 == vec_y3) ) if (allocated(error)) return + + call spmv( ELL , vec_x, vec_y4 ) + call check(error, all(vec_y1 == vec_y4) ) + if (allocated(error)) return end block #:endfor end subroutine From beafb3c78d0270bf3cd6ff7f093942f7f934c37f Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sun, 20 Oct 2024 23:58:45 +0200 Subject: [PATCH 70/78] simplify csr spmv, remove unused var beta_ --- src/stdlib_sparse_spmv.fypp | 68 +++++++++---------------------------- 1 file changed, 16 insertions(+), 52 deletions(-) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index 841c064e1..04fe7dd2b 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -45,7 +45,7 @@ contains ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta character(1), intent(in), optional :: op - ${t1}$ :: alpha_, beta_ + ${t1}$ :: alpha_ character(1) :: op_ integer(ilp) :: k, ik, jk @@ -57,6 +57,7 @@ contains else vec_y = zero_${s1}$ endif + associate( data => matrix%data, index => matrix%index, storage => matrix%storage, nnz => matrix%nnz ) select case(op_) case(sparse_op_none) @@ -132,7 +133,7 @@ contains ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta character(1), intent(in), optional :: op - ${t1}$ :: alpha_, beta_ + ${t1}$ :: alpha_ character(1) :: op_ integer(ilp) :: i, j #:if rank == 1 @@ -144,8 +145,11 @@ contains op_ = sparse_op_none; if(present(op)) op_ = op alpha_ = one_${k1}$ if(present(alpha)) alpha_ = alpha - beta_ = zero_${k1}$ - if(present(beta)) beta_ = beta + if(present(beta)) then + vec_y = beta * vec_y + else + vec_y = zero_${s1}$ + endif associate( data => matrix%data, col => matrix%col, rowptr => matrix%rowptr, & & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage ) @@ -156,19 +160,10 @@ contains do j = rowptr(i), rowptr(i+1)-1 aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j)) end do - if(present(beta)) then - vec_y(${rksfx2(rank-1)}$i) = beta_ * vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux - else - vec_y(${rksfx2(rank-1)}$i) = alpha_ * aux - end if + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux end do else if( storage == sparse_full .and. op_==sparse_op_transpose ) then - if(present(beta)) then - vec_y = beta * vec_y - else - vec_y = zero_${s1}$ - endif do i = 1, nrows aux = alpha_ * vec_x(${rksfx2(rank-1)}$i) do j = rowptr(i), rowptr(i+1)-1 @@ -185,12 +180,7 @@ contains vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * aux2 end do aux = alpha_ * aux + data(j) * aux2 - - if(present(beta)) then - vec_y(${rksfx2(rank-1)}$i) = beta_ * vec_y(${rksfx2(rank-1)}$i) + aux - else - vec_y(${rksfx2(rank-1)}$i) = aux - end if + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + aux end do else if( storage == sparse_upper .and. op_/=sparse_op_hermitian )then @@ -199,26 +189,13 @@ contains aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i) do j = rowptr(i)+1, rowptr(i+1)-1 aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j)) + vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * aux2 end do - if(present(beta)) then - do j = rowptr(i)+1, rowptr(i+1)-1 - vec_y(${rksfx2(rank-1)}$col(j)) = beta_ * vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * aux2 - end do - else - do j = rowptr(i)+1, rowptr(i+1)-1 - vec_y(${rksfx2(rank-1)}$col(j)) = data(j) * aux2 - end do - end if vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux end do #:if t1.startswith('complex') else if( storage == sparse_full .and. op_==sparse_op_hermitian) then - if(present(beta)) then - vec_y = beta * vec_y - else - vec_y = zero_${s1}$ - endif do i = 1, nrows aux = alpha_ * vec_x(${rksfx2(rank-1)}$i) do j = rowptr(i), rowptr(i+1)-1 @@ -235,12 +212,7 @@ contains vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + conjg(data(j)) * aux2 end do aux = alpha_ * aux + conjg(data(j)) * aux2 - - if(present(beta)) then - vec_y(${rksfx2(rank-1)}$i) = beta_ * vec_y(${rksfx2(rank-1)}$i) + aux - else - vec_y(${rksfx2(rank-1)}$i) = aux - end if + vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + aux end do else if( storage == sparse_upper .and. op_==sparse_op_hermitian )then @@ -249,16 +221,8 @@ contains aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i) do j = rowptr(i)+1, rowptr(i+1)-1 aux = aux + conjg(data(j)) * vec_x(${rksfx2(rank-1)}$col(j)) + vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + conjg(data(j)) * aux2 end do - if(present(beta)) then - do j = rowptr(i)+1, rowptr(i+1)-1 - vec_y(${rksfx2(rank-1)}$col(j)) = beta_ * vec_y(${rksfx2(rank-1)}$col(j)) + conjg(data(j)) * aux2 - end do - else - do j = rowptr(i)+1, rowptr(i+1)-1 - vec_y(${rksfx2(rank-1)}$col(j)) = conjg(data(j)) * aux2 - end do - end if vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux end do #:endif @@ -279,7 +243,7 @@ contains ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta character(1), intent(in), optional :: op - ${t1}$ :: alpha_, beta_ + ${t1}$ :: alpha_ character(1) :: op_ integer(ilp) :: i, j #:if rank == 1 @@ -385,7 +349,7 @@ contains ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta character(1), intent(in), optional :: op - ${t1}$ :: alpha_, beta_ + ${t1}$ :: alpha_ character(1) :: op_ integer(ilp) :: i, j, k @@ -452,7 +416,7 @@ contains ${t1}$, intent(in), optional :: alpha ${t1}$, intent(in), optional :: beta character(1), intent(in), optional :: op - ${t1}$ :: alpha_, beta_ + ${t1}$ :: alpha_ character(1) :: op_ integer(ilp) :: i, nz, rowidx, num_chunks, rm From 7a26174440c312eea238a2e1c3527c2c1c787cd6 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Mon, 21 Oct 2024 00:16:17 +0200 Subject: [PATCH 71/78] typo --- src/stdlib_sparse_spmv.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index 04fe7dd2b..dd53f5596 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -18,7 +18,7 @@ module stdlib_sparse_spmv !! Version experimental !! - !! Applay the sparse matrix-vector product $$y = \alpha * op(M) * x + \beta * y $$ + !! Apply the sparse matrix-vector product $$y = \alpha * op(M) * x + \beta * y $$ !! [Specifications](../page/specs/stdlib_sparse.html#spmv) interface spmv #:for k1, t1, s1 in (KINDS_TYPES) From 3746331262de55d8d56f6a42d77846256f2d2028 Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Wed, 30 Oct 2024 16:01:24 +0100 Subject: [PATCH 72/78] change file name --- test/linalg/CMakeLists.txt | 2 +- test/linalg/{test_sparse_spmv.fypp => test_linalg_sparse.fypp} | 0 2 files changed, 1 insertion(+), 1 deletion(-) rename test/linalg/{test_sparse_spmv.fypp => test_linalg_sparse.fypp} (100%) diff --git a/test/linalg/CMakeLists.txt b/test/linalg/CMakeLists.txt index c3b3a721f..58469833d 100644 --- a/test/linalg/CMakeLists.txt +++ b/test/linalg/CMakeLists.txt @@ -12,7 +12,7 @@ set( "test_linalg_qr.fypp" "test_linalg_svd.fypp" "test_linalg_matrix_property_checks.fypp" - "test_sparse_spmv.fypp" + "test_linalg_sparse.fypp" ) fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) diff --git a/test/linalg/test_sparse_spmv.fypp b/test/linalg/test_linalg_sparse.fypp similarity index 100% rename from test/linalg/test_sparse_spmv.fypp rename to test/linalg/test_linalg_sparse.fypp From 3dfcecd11d75496ab14e6b1779d7a06ca3ebe309 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Thu, 31 Oct 2024 15:02:04 +0100 Subject: [PATCH 73/78] addtest --- test/linalg/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/test/linalg/CMakeLists.txt b/test/linalg/CMakeLists.txt index 58469833d..ad41e5bb0 100644 --- a/test/linalg/CMakeLists.txt +++ b/test/linalg/CMakeLists.txt @@ -28,3 +28,4 @@ ADDTEST(linalg_lstsq) ADDTEST(linalg_qr) ADDTEST(linalg_svd) ADDTEST(blas_lapack) +ADDTEST(linalg_sparse) \ No newline at end of file From 89a993e00258211565ffd2a08b955e91cb486c9c Mon Sep 17 00:00:00 2001 From: jalvesz Date: Thu, 31 Oct 2024 18:19:27 +0100 Subject: [PATCH 74/78] add in place transpose spmv for SELLC --- src/stdlib_sparse_spmv.fypp | 83 +++++++++++++++++++++++------ test/linalg/test_linalg_sparse.fypp | 14 ++++- 2 files changed, 79 insertions(+), 18 deletions(-) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index dd53f5596..8835a4cea 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -428,11 +428,18 @@ contains else vec_y = zero_${s1}$ endif + associate( data => matrix%data, ia => matrix%rowptr , ja => matrix%col, cs => matrix%chunk_size, & & nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage ) + + if( .not.any( ${CHUNKS}$ == cs ) ) then + print *, "error: sellc chunk size not supported." + return + end if + num_chunks = nrows / cs rm = nrows - num_chunks * cs - if( storage == sparse_full) then + if( storage == sparse_full .and. op_==sparse_op_none ) then select case(cs) #:for chunk in CHUNKS @@ -443,9 +450,6 @@ contains call chunk_kernel_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x,vec_y(rowidx:)) end do #:endfor - case default - print *, "error: chunk size not supported." - return end select ! remainder @@ -455,32 +459,79 @@ contains rowidx = (i - 1)*cs + 1 call chunk_kernel_remainder(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x,vec_y(rowidx:)) end if + + else if( storage == sparse_full .and. op_==sparse_op_transpose ) then + select case(cs) + #:for chunk in CHUNKS + case(${chunk}$) + do i = 1, num_chunks + nz = ia(i+1) - ia(i) + rowidx = (i - 1)*${chunk}$ + 1 + call chunk_kernel_trans_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y) + end do + #:endfor + end select + + ! remainder + if(rm>0)then + i = num_chunks + 1 + nz = ia(i+1) - ia(i) + rowidx = (i - 1)*cs + 1 + call chunk_kernel_remainder_trans(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y) + end if + else + print *, "error: sellc format for spmv operation not yet supported." + return end if end associate contains #:for chunk in CHUNKS - pure subroutine chunk_kernel_${chunk}$(nz,a,ja,x,y) - integer, value :: nz - ${t1}$, intent(in) :: a(${chunk}$,nz), x(*) - integer(ilp), intent(in) :: ja(${chunk}$,nz) + pure subroutine chunk_kernel_${chunk}$(n,a,col,x,y) + integer, value :: n + ${t1}$, intent(in) :: a(${chunk}$,n), x(*) + integer(ilp), intent(in) :: col(${chunk}$,n) ${t1}$, intent(inout) :: y(${chunk}$) integer :: j - do j = 1, nz - where(ja(:,j) > 0) y = y + alpha_ * a(:,j) * x(ja(:,j)) + do j = 1, n + where(col(:,j) > 0) y = y + alpha_ * a(:,j) * x(col(:,j)) + end do + end subroutine + pure subroutine chunk_kernel_trans_${chunk}$(n,a,col,x,y) + integer, value :: n + ${t1}$, intent(in) :: a(${chunk}$,n), x(${chunk}$) + integer(ilp), intent(in) :: col(${chunk}$,n) + ${t1}$, intent(inout) :: y(*) + integer :: j, k + do j = 1, n + do k = 1, ${chunk}$ + if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * a(k,j) * x(k) + end do end do end subroutine #:endfor - pure subroutine chunk_kernel_remainder(nz,cs,rm,a,ja,x,y) - integer, value :: nz, cs, rm - ${t1}$, intent(in) :: a(cs,nz), x(*) - integer(ilp), intent(in) :: ja(cs,nz) + pure subroutine chunk_kernel_remainder(n,cs,rm,a,col,x,y) + integer, value :: n, cs, rm + ${t1}$, intent(in) :: a(cs,n), x(*) + integer(ilp), intent(in) :: col(cs,n) ${t1}$, intent(inout) :: y(rm) integer :: j - do j = 1, nz - where(ja(1:rm,j) > 0) y = y + alpha_ * a(1:rm,j) * x(ja(1:rm,j)) + do j = 1, n + where(col(1:rm,j) > 0) y = y + alpha_ * a(1:rm,j) * x(col(1:rm,j)) + end do + end subroutine + pure subroutine chunk_kernel_remainder_trans(n,cs,rm,a,col,x,y) + integer, value :: n, cs, rm + ${t1}$, intent(in) :: a(cs,n), x(rm) + integer(ilp), intent(in) :: col(cs,n) + ${t1}$, intent(inout) :: y(*) + integer :: j, k + do j = 1, n + do k = 1, rm + if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * a(k,j) * x(k) + end do end do end subroutine diff --git a/test/linalg/test_linalg_sparse.fypp b/test/linalg/test_linalg_sparse.fypp index 838243505..969f84dd4 100644 --- a/test/linalg/test_linalg_sparse.fypp +++ b/test/linalg/test_linalg_sparse.fypp @@ -208,7 +208,7 @@ contains type(SELLC_${s1}$_type) :: SELLC type(CSR_${s1}$_type) :: CSR ${t1}$, allocatable :: vec_x(:) - ${t1}$, allocatable :: vec_y(:) + ${t1}$, allocatable :: vec_y(:), vec_y2(:) integer :: i call CSR%malloc(6,6,17) @@ -226,11 +226,21 @@ contains allocate( vec_x(6) , source = 1._wp ) allocate( vec_y(6) , source = 0._wp ) - + call spmv( SELLC, vec_x, vec_y ) call check(error, all(vec_y == real([6,22,27,23,27,48],kind=wp)) ) if (allocated(error)) return + + ! Test in-place transpose + vec_x = real( [1,2,3,4,5,6] , kind=wp ) + call spmv( CSR, vec_x, vec_y , op = sparse_op_transpose ) + allocate( vec_y2(6) , source = 0._wp ) + call spmv( SELLC, vec_x, vec_y2 , op = sparse_op_transpose ) + + call check(error, all(vec_y == vec_y2)) + if (allocated(error)) return + end block #:endfor end subroutine From ae02481ee097114c64298665baf18c3744929905 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Thu, 31 Oct 2024 18:59:39 +0100 Subject: [PATCH 75/78] simplify sellc spmv kernel --- src/stdlib_sparse_spmv.fypp | 83 +++++++++++++------------------------ 1 file changed, 29 insertions(+), 54 deletions(-) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index 8835a4cea..a56a51e9c 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -418,7 +418,7 @@ contains character(1), intent(in), optional :: op ${t1}$ :: alpha_ character(1) :: op_ - integer(ilp) :: i, nz, rowidx, num_chunks, rm + integer(ilp) :: i, j, k, nz, rowidx, num_chunks, rm op_ = sparse_op_none; if(present(op)) op_ = op alpha_ = one_${s1}$ @@ -447,7 +447,12 @@ contains do i = 1, num_chunks nz = ia(i+1) - ia(i) rowidx = (i - 1)*${chunk}$ + 1 - call chunk_kernel_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x,vec_y(rowidx:)) + associate(col => ja(1:${chunk}$,ia(i):ia(i)+nz-1), mat => data(1:${chunk}$,ia(i):ia(i)+nz-1), & + & x => vec_x, y => vec_y(rowidx:rowidx+${chunk}$-1) ) + do j = 1, nz + where(col(:,j) > 0) y = y + alpha_ * mat(:,j) * x(col(:,j)) + end do + end associate end do #:endfor end select @@ -457,7 +462,12 @@ contains i = num_chunks + 1 nz = ia(i+1) - ia(i) rowidx = (i - 1)*cs + 1 - call chunk_kernel_remainder(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x,vec_y(rowidx:)) + associate(col => ja(1:${chunk}$,ia(i):ia(i)+nz-1), mat => data(1:${chunk}$,ia(i):ia(i)+nz-1), & + & x => vec_x, y => vec_y(rowidx:rowidx+rm-1) ) + do j = 1, nz + where(col(1:rm,j) > 0) y = y + alpha_ * mat(1:rm,j) * x(col(1:rm,j)) + end do + end associate end if else if( storage == sparse_full .and. op_==sparse_op_transpose ) then @@ -468,7 +478,14 @@ contains do i = 1, num_chunks nz = ia(i+1) - ia(i) rowidx = (i - 1)*${chunk}$ + 1 - call chunk_kernel_trans_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y) + associate(col => ja(1:${chunk}$,ia(i):ia(i)+nz-1), mat => data(1:${chunk}$,ia(i):ia(i)+nz-1), & + & x => vec_x(rowidx:rowidx+${chunk}$-1), y => vec_y ) + do j = 1, nz + do k = 1, ${chunk}$ + if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * mat(k,j) * x(k) + end do + end do + end associate end do #:endfor end select @@ -478,7 +495,14 @@ contains i = num_chunks + 1 nz = ia(i+1) - ia(i) rowidx = (i - 1)*cs + 1 - call chunk_kernel_remainder_trans(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y) + associate(col => ja(1:${chunk}$,ia(i):ia(i)+nz-1), mat => data(1:${chunk}$,ia(i):ia(i)+nz-1), & + & x => vec_x(rowidx:rowidx+rm-1), y => vec_y ) + do j = 1, nz + do k = 1, rm + if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * mat(k,j) * x(k) + end do + end do + end associate end if else print *, "error: sellc format for spmv operation not yet supported." @@ -486,55 +510,6 @@ contains end if end associate - contains - #:for chunk in CHUNKS - pure subroutine chunk_kernel_${chunk}$(n,a,col,x,y) - integer, value :: n - ${t1}$, intent(in) :: a(${chunk}$,n), x(*) - integer(ilp), intent(in) :: col(${chunk}$,n) - ${t1}$, intent(inout) :: y(${chunk}$) - integer :: j - do j = 1, n - where(col(:,j) > 0) y = y + alpha_ * a(:,j) * x(col(:,j)) - end do - end subroutine - pure subroutine chunk_kernel_trans_${chunk}$(n,a,col,x,y) - integer, value :: n - ${t1}$, intent(in) :: a(${chunk}$,n), x(${chunk}$) - integer(ilp), intent(in) :: col(${chunk}$,n) - ${t1}$, intent(inout) :: y(*) - integer :: j, k - do j = 1, n - do k = 1, ${chunk}$ - if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * a(k,j) * x(k) - end do - end do - end subroutine - #:endfor - - pure subroutine chunk_kernel_remainder(n,cs,rm,a,col,x,y) - integer, value :: n, cs, rm - ${t1}$, intent(in) :: a(cs,n), x(*) - integer(ilp), intent(in) :: col(cs,n) - ${t1}$, intent(inout) :: y(rm) - integer :: j - do j = 1, n - where(col(1:rm,j) > 0) y = y + alpha_ * a(1:rm,j) * x(col(1:rm,j)) - end do - end subroutine - pure subroutine chunk_kernel_remainder_trans(n,cs,rm,a,col,x,y) - integer, value :: n, cs, rm - ${t1}$, intent(in) :: a(cs,n), x(rm) - integer(ilp), intent(in) :: col(cs,n) - ${t1}$, intent(inout) :: y(*) - integer :: j, k - do j = 1, n - do k = 1, rm - if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * a(k,j) * x(k) - end do - end do - end subroutine - end subroutine #:endfor From 680d35dbfdff4e13936112966d28304af19d94f2 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Thu, 31 Oct 2024 20:08:45 +0100 Subject: [PATCH 76/78] fix out-of-bounds --- src/stdlib_sparse_spmv.fypp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index a56a51e9c..b3f636093 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -462,7 +462,7 @@ contains i = num_chunks + 1 nz = ia(i+1) - ia(i) rowidx = (i - 1)*cs + 1 - associate(col => ja(1:${chunk}$,ia(i):ia(i)+nz-1), mat => data(1:${chunk}$,ia(i):ia(i)+nz-1), & + associate(col => ja(1:cs,ia(i):ia(i)+nz-1), mat => data(1:cs,ia(i):ia(i)+nz-1), & & x => vec_x, y => vec_y(rowidx:rowidx+rm-1) ) do j = 1, nz where(col(1:rm,j) > 0) y = y + alpha_ * mat(1:rm,j) * x(col(1:rm,j)) @@ -495,7 +495,7 @@ contains i = num_chunks + 1 nz = ia(i+1) - ia(i) rowidx = (i - 1)*cs + 1 - associate(col => ja(1:${chunk}$,ia(i):ia(i)+nz-1), mat => data(1:${chunk}$,ia(i):ia(i)+nz-1), & + associate(col => ja(1:cs,ia(i):ia(i)+nz-1), mat => data(1:cs,ia(i):ia(i)+nz-1), & & x => vec_x(rowidx:rowidx+rm-1), y => vec_y ) do j = 1, nz do k = 1, rm From 7e45901aa20b88d6c08df03e678325543e195e66 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Thu, 31 Oct 2024 21:26:55 +0100 Subject: [PATCH 77/78] sellc hermitian transpose --- src/stdlib_sparse_spmv.fypp | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index b3f636093..c9cdbcac9 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -504,6 +504,43 @@ contains end do end associate end if + + #:if t1.startswith('complex') + else if( storage == sparse_full .and. op_==sparse_op_hermitian ) then + + select case(cs) + #:for chunk in CHUNKS + case(${chunk}$) + do i = 1, num_chunks + nz = ia(i+1) - ia(i) + rowidx = (i - 1)*${chunk}$ + 1 + associate(col => ja(1:${chunk}$,ia(i):ia(i)+nz-1), mat => data(1:${chunk}$,ia(i):ia(i)+nz-1), & + & x => vec_x(rowidx:rowidx+${chunk}$-1), y => vec_y ) + do j = 1, nz + do k = 1, ${chunk}$ + if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * conjg(mat(k,j)) * x(k) + end do + end do + end associate + end do + #:endfor + end select + + ! remainder + if(rm>0)then + i = num_chunks + 1 + nz = ia(i+1) - ia(i) + rowidx = (i - 1)*cs + 1 + associate(col => ja(1:cs,ia(i):ia(i)+nz-1), mat => data(1:cs,ia(i):ia(i)+nz-1), & + & x => vec_x(rowidx:rowidx+rm-1), y => vec_y ) + do j = 1, nz + do k = 1, rm + if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * conjg(mat(k,j)) * x(k) + end do + end do + end associate + end if + #:endif else print *, "error: sellc format for spmv operation not yet supported." return From 22cd23e88d57007fa2dc24421c7bae21531f54d5 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Tue, 5 Nov 2024 22:12:37 +0100 Subject: [PATCH 78/78] sellc: rollback on local associates, use embedded chunk kernels --- src/stdlib_sparse_spmv.fypp | 129 +++++++++++++++++++++++------------- 1 file changed, 84 insertions(+), 45 deletions(-) diff --git a/src/stdlib_sparse_spmv.fypp b/src/stdlib_sparse_spmv.fypp index c9cdbcac9..2f2e4bb45 100644 --- a/src/stdlib_sparse_spmv.fypp +++ b/src/stdlib_sparse_spmv.fypp @@ -418,7 +418,7 @@ contains character(1), intent(in), optional :: op ${t1}$ :: alpha_ character(1) :: op_ - integer(ilp) :: i, j, k, nz, rowidx, num_chunks, rm + integer(ilp) :: i, nz, rowidx, num_chunks, rm op_ = sparse_op_none; if(present(op)) op_ = op alpha_ = one_${s1}$ @@ -447,12 +447,7 @@ contains do i = 1, num_chunks nz = ia(i+1) - ia(i) rowidx = (i - 1)*${chunk}$ + 1 - associate(col => ja(1:${chunk}$,ia(i):ia(i)+nz-1), mat => data(1:${chunk}$,ia(i):ia(i)+nz-1), & - & x => vec_x, y => vec_y(rowidx:rowidx+${chunk}$-1) ) - do j = 1, nz - where(col(:,j) > 0) y = y + alpha_ * mat(:,j) * x(col(:,j)) - end do - end associate + call chunk_kernel_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x,vec_y(rowidx:)) end do #:endfor end select @@ -462,12 +457,7 @@ contains i = num_chunks + 1 nz = ia(i+1) - ia(i) rowidx = (i - 1)*cs + 1 - associate(col => ja(1:cs,ia(i):ia(i)+nz-1), mat => data(1:cs,ia(i):ia(i)+nz-1), & - & x => vec_x, y => vec_y(rowidx:rowidx+rm-1) ) - do j = 1, nz - where(col(1:rm,j) > 0) y = y + alpha_ * mat(1:rm,j) * x(col(1:rm,j)) - end do - end associate + call chunk_kernel_rm(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x,vec_y(rowidx:)) end if else if( storage == sparse_full .and. op_==sparse_op_transpose ) then @@ -478,14 +468,7 @@ contains do i = 1, num_chunks nz = ia(i+1) - ia(i) rowidx = (i - 1)*${chunk}$ + 1 - associate(col => ja(1:${chunk}$,ia(i):ia(i)+nz-1), mat => data(1:${chunk}$,ia(i):ia(i)+nz-1), & - & x => vec_x(rowidx:rowidx+${chunk}$-1), y => vec_y ) - do j = 1, nz - do k = 1, ${chunk}$ - if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * mat(k,j) * x(k) - end do - end do - end associate + call chunk_kernel_trans_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y) end do #:endfor end select @@ -495,14 +478,7 @@ contains i = num_chunks + 1 nz = ia(i+1) - ia(i) rowidx = (i - 1)*cs + 1 - associate(col => ja(1:cs,ia(i):ia(i)+nz-1), mat => data(1:cs,ia(i):ia(i)+nz-1), & - & x => vec_x(rowidx:rowidx+rm-1), y => vec_y ) - do j = 1, nz - do k = 1, rm - if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * mat(k,j) * x(k) - end do - end do - end associate + call chunk_kernel_rm_trans(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y) end if #:if t1.startswith('complex') @@ -514,14 +490,7 @@ contains do i = 1, num_chunks nz = ia(i+1) - ia(i) rowidx = (i - 1)*${chunk}$ + 1 - associate(col => ja(1:${chunk}$,ia(i):ia(i)+nz-1), mat => data(1:${chunk}$,ia(i):ia(i)+nz-1), & - & x => vec_x(rowidx:rowidx+${chunk}$-1), y => vec_y ) - do j = 1, nz - do k = 1, ${chunk}$ - if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * conjg(mat(k,j)) * x(k) - end do - end do - end associate + call chunk_kernel_herm_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y) end do #:endfor end select @@ -531,14 +500,7 @@ contains i = num_chunks + 1 nz = ia(i+1) - ia(i) rowidx = (i - 1)*cs + 1 - associate(col => ja(1:cs,ia(i):ia(i)+nz-1), mat => data(1:cs,ia(i):ia(i)+nz-1), & - & x => vec_x(rowidx:rowidx+rm-1), y => vec_y ) - do j = 1, nz - do k = 1, rm - if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * conjg(mat(k,j)) * x(k) - end do - end do - end associate + call chunk_kernel_rm_herm(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y) end if #:endif else @@ -547,6 +509,83 @@ contains end if end associate + contains + #:for chunk in CHUNKS + pure subroutine chunk_kernel_${chunk}$(n,a,col,x,y) + integer, value :: n + ${t1}$, intent(in) :: a(${chunk}$,n), x(*) + integer(ilp), intent(in) :: col(${chunk}$,n) + ${t1}$, intent(inout) :: y(${chunk}$) + integer :: j + do j = 1, n + where(col(:,j) > 0) y = y + alpha_ * a(:,j) * x(col(:,j)) + end do + end subroutine + pure subroutine chunk_kernel_trans_${chunk}$(n,a,col,x,y) + integer, value :: n + ${t1}$, intent(in) :: a(${chunk}$,n), x(${chunk}$) + integer(ilp), intent(in) :: col(${chunk}$,n) + ${t1}$, intent(inout) :: y(*) + integer :: j, k + do j = 1, n + do k = 1, ${chunk}$ + if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * a(k,j) * x(k) + end do + end do + end subroutine + #:if t1.startswith('complex') + pure subroutine chunk_kernel_herm_${chunk}$(n,a,col,x,y) + integer, value :: n + ${t1}$, intent(in) :: a(${chunk}$,n), x(${chunk}$) + integer(ilp), intent(in) :: col(${chunk}$,n) + ${t1}$, intent(inout) :: y(*) + integer :: j, k + do j = 1, n + do k = 1, ${chunk}$ + if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * conjg(a(k,j)) * x(k) + end do + end do + end subroutine + #:endif + #:endfor + + pure subroutine chunk_kernel_rm(n,cs,r,a,col,x,y) + integer, value :: n, cs, r + ${t1}$, intent(in) :: a(cs,n), x(*) + integer(ilp), intent(in) :: col(cs,n) + ${t1}$, intent(inout) :: y(r) + integer :: j + do j = 1, n + where(col(1:r,j) > 0) y = y + alpha_ * a(1:r,j) * x(col(1:r,j)) + end do + end subroutine + pure subroutine chunk_kernel_rm_trans(n,cs,r,a,col,x,y) + integer, value :: n, cs, r + ${t1}$, intent(in) :: a(cs,n), x(r) + integer(ilp), intent(in) :: col(cs,n) + ${t1}$, intent(inout) :: y(*) + integer :: j, k + do j = 1, n + do k = 1, r + if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * a(k,j) * x(k) + end do + end do + end subroutine + #:if t1.startswith('complex') + pure subroutine chunk_kernel_rm_herm(n,cs,r,a,col,x,y) + integer, value :: n, cs, r + ${t1}$, intent(in) :: a(cs,n), x(r) + integer(ilp), intent(in) :: col(cs,n) + ${t1}$, intent(inout) :: y(*) + integer :: j, k + do j = 1, n + do k = 1, r + if(col(k,j) > 0) y(col(k,j)) = y(col(k,j)) + alpha_ * conjg(a(k,j)) * x(k) + end do + end do + end subroutine + #:endif + end subroutine #:endfor